op.c

   1 #line 2 "op.c"
   2 /*    op.c
   3  *
   4  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
   5  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
   6  *
   7  *    You may distribute under the terms of either the GNU General Public
   8  *    License or the Artistic License, as specified in the README file.
   9  *
  10  */
  11
  12 /*
  13  * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck.  She was
  14  *  our Mr. Bilbo's first cousin on the mother's side (her mother being the
  15  *  youngest of the Old Took's daughters); and Mr. Drogo was his second
  16  *  cousin.  So Mr. Frodo is his first *and* second cousin, once removed
  17  *  either way, as the saying is, if you follow me.'       --the Gaffer
  18  *
  19  *     [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
  20  */
  21
  22 /* This file contains the functions that create, manipulate and optimize
  23  * the OP structures that hold a compiled perl program.
  24  *
  25  * Note that during the build of miniperl, a temporary copy of this file
  26  * is made, called opmini.c.
  27  *
  28  * A Perl program is compiled into a tree of OP nodes. Each op contains:
  29  *  * structural OP pointers to its children and siblings (op_sibling,
  30  *    op_first etc) that define the tree structure;
  31  *  * execution order OP pointers (op_next, plus sometimes op_other,
  32  *    op_lastop  etc) that define the execution sequence plus variants;
  33  *  * a pointer to the C "pp" function that would execute the op;
  34  *  * any data specific to that op.
  35  * For example, an OP_CONST op points to the pp_const() function and to an
  36  * SV containing the constant value. When pp_const() is executed, its job
  37  * is to push that SV onto the stack.
  38  *
  39  * OPs are mainly created by the newFOO() functions, which are mainly
  40  * called from the parser (in perly.y) as the code is parsed. For example
  41  * the Perl code $a + $b * $c would cause the equivalent of the following
  42  * to be called (oversimplifying a bit):
  43  *
  44  *  newBINOP(OP_ADD, flags,
  45  *      newSVREF($a),
  46  *      newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
  47  *  )
  48  *
  49  * As the parser reduces low-level rules, it creates little op subtrees;
  50  * as higher-level rules are resolved, these subtrees get joined together
  51  * as branches on a bigger subtree, until eventually a top-level rule like
  52  * a subroutine definition is reduced, at which point there is one large
  53  * parse tree left.
  54  *
  55  * The execution order pointers (op_next) are generated as the subtrees
  56  * are joined together. Consider this sub-expression: A*B + C/D: at the
  57  * point when it's just been parsed, the op tree looks like:
  58  *
  59  *   [+]
  60  *    |
  61  *   [*]------[/]
  62  *    |        |
  63  *    A---B    C---D
  64  *
  65  * with the intended execution order being:
  66  *
  67  *   [PREV] => A => B => [*] => C => D => [/] =>  [+] => [NEXT]
  68  *
  69  * At this point all the nodes' op_next pointers will have been set,
  70  * except that:
  71  *    * we don't know what the [NEXT] node will be yet;
  72  *    * we don't know what the [PREV] node will be yet, but when it gets
  73  *      created and needs its op_next set, it needs to be set to point to
  74  *      A, which is non-obvious.
  75  * To handle both those cases, we temporarily set the top node's
  76  * op_next to point to the first node to be executed in this subtree (A in
  77  * this case). This means that initially a subtree's op_next chain,
  78  * starting from the top node, will visit each node in execution sequence
  79  * then point back at the top node.
  80  * When we embed this subtree in a larger tree, its top op_next is used
  81  * to get the start node, then is set to point to its new neighbour.
  82  * For example the two separate [*],A,B and [/],C,D subtrees would
  83  * initially have had:
  84  *   [*] => A;  A => B;  B => [*]
  85  * and
  86  *   [/] => C;  C => D;  D => [/]
  87  * When these two subtrees were joined together to make the [+] subtree,
  88  * [+]'s op_next was set to [*]'s op_next, i.e. A; then [*]'s op_next was
  89  * set to point to [/]'s op_next, i.e. C.
  90  *
  91  * This op_next linking is done by the LINKLIST() macro and its underlying
  92  * op_linklist() function. Given a top-level op, if its op_next is
  93  * non-null, it's already been linked, so leave it. Otherwise link it with
  94  * its children as described above, possibly recursively if any of the
  95  * children have a null op_next.
  96  *
  97  * In summary: given a subtree, its top-level node's op_next will either
  98  * be:
  99  *   NULL: the subtree hasn't been LINKLIST()ed yet;
 100  *   fake: points to the start op for this subtree;
 101  *   real: once the subtree has been embedded into a larger tree
 102  */
 103
 104 /*
 105
 106 Here's an older description from Larry.
 107
 108 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
 109
 110     A bottom-up pass
 111     A top-down pass
 112     An execution-order pass
 113
 114 The bottom-up pass is represented by all the "newOP" routines and
 115 the ck_ routines.  The bottom-upness is actually driven by yacc.
 116 So at the point that a ck_ routine fires, we have no idea what the
 117 context is, either upward in the syntax tree, or either forward or
 118 backward in the execution order.  (The bottom-up parser builds that
 119 part of the execution order it knows about, but if you follow the "next"
 120 links around, you'll find it's actually a closed loop through the
 121 top level node.)
 122
 123 Whenever the bottom-up parser gets to a node that supplies context to
 124 its components, it invokes that portion of the top-down pass that applies
 125 to that part of the subtree (and marks the top node as processed, so
 126 if a node further up supplies context, it doesn't have to take the
 127 plunge again).  As a particular subcase of this, as the new node is
 128 built, it takes all the closed execution loops of its subcomponents
 129 and links them into a new closed loop for the higher level node.  But
 130 it's still not the real execution order.
 131
 132 The actual execution order is not known till we get a grammar reduction
 133 to a top-level unit like a subroutine or file that will be called by
 134 "name" rather than via a "next" pointer.  At that point, we can call
 135 into peep() to do that code's portion of the 3rd pass.  It has to be
 136 recursive, but it's recursive on basic blocks, not on tree nodes.
 137 */
 138
 139 /* To implement user lexical pragmas, there needs to be a way at run time to
 140    get the compile time state of %^H for that block.  Storing %^H in every
 141    block (or even COP) would be very expensive, so a different approach is
 142    taken.  The (running) state of %^H is serialised into a tree of HE-like
 143    structs.  Stores into %^H are chained onto the current leaf as a struct
 144    refcounted_he * with the key and the value.  Deletes from %^H are saved
 145    with a value of PL_sv_placeholder.  The state of %^H at any point can be
 146    turned back into a regular HV by walking back up the tree from that point's
 147    leaf, ignoring any key you've already seen (placeholder or not), storing
 148    the rest into the HV structure, then removing the placeholders. Hence
 149    memory is only used to store the %^H deltas from the enclosing COP, rather
 150    than the entire %^H on each COP.
 151
 152    To cause actions on %^H to write out the serialisation records, it has
 153    magic type 'H'. This magic (itself) does nothing, but its presence causes
 154    the values to gain magic type 'h', which has entries for set and clear.
 155    C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
 156    record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
 157    saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
 158    it will be correctly restored when any inner compiling scope is exited.
 159 */
 160
 161 #include "EXTERN.h"
 162 #define PERL_IN_OP_C
 163 #include "perl.h"
 164 #include "keywords.h"
 165 #include "feature.h"
 166 #include "regcomp.h"
 167
 168 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
 169 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
 170 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
 171
 172 static const char array_passed_to_stat[] = "Array passed to stat will be coerced to a scalar";
 173
 174 /* Used to avoid recursion through the op tree in scalarvoid() and
 175    op_free()
 176 */
 177
 178 #define DEFERRED_OP_STEP 100
 179 #define DEFER_OP(o) \
 180   STMT_START { \
 181     if (UNLIKELY(defer_ix == (defer_stack_alloc-1))) {    \
 182         defer_stack_alloc += DEFERRED_OP_STEP; \
 183         assert(defer_stack_alloc > 0); \
 184         Renew(defer_stack, defer_stack_alloc, OP *); \
 185     } \
 186     defer_stack[++defer_ix] = o; \
 187   } STMT_END
 188
 189 #define POP_DEFERRED_OP() (defer_ix >= 0 ? defer_stack[defer_ix--] : (OP *)NULL)
 190
 191 /* remove any leading "empty" ops from the op_next chain whose first
 192  * node's address is stored in op_p. Store the updated address of the
 193  * first node in op_p.
 194  */
 195
 196 STATIC void
 197 S_prune_chain_head(OP** op_p)
 198 {
 199     while (*op_p
 200         && (   (*op_p)->op_type == OP_NULL
 201             || (*op_p)->op_type == OP_SCOPE
 202             || (*op_p)->op_type == OP_SCALAR
 203             || (*op_p)->op_type == OP_LINESEQ)
 204     )
 205         *op_p = (*op_p)->op_next;
 206 }
 207
 208
 209 /* See the explanatory comments above struct opslab in op.h. */
 210
 211 #ifdef PERL_DEBUG_READONLY_OPS
 212 #  define PERL_SLAB_SIZE 128
 213 #  define PERL_MAX_SLAB_SIZE 4096
 214 #  include <sys/mman.h>
 215 #endif
 216
 217 #ifndef PERL_SLAB_SIZE
 218 #  define PERL_SLAB_SIZE 64
 219 #endif
 220 #ifndef PERL_MAX_SLAB_SIZE
 221 #  define PERL_MAX_SLAB_SIZE 2048
 222 #endif
 223
 224 /* rounds up to nearest pointer */
 225 #define SIZE_TO_PSIZE(x)        (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
 226 #define DIFF(o,p)               ((size_t)((I32 **)(p) - (I32**)(o)))
 227
 228 static OPSLAB *
 229 S_new_slab(pTHX_ size_t sz)
 230 {
 231 #ifdef PERL_DEBUG_READONLY_OPS
 232     OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
 233                                    PROT_READ|PROT_WRITE,
 234                                    MAP_ANON|MAP_PRIVATE, -1, 0);
 235     DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
 236                           (unsigned long) sz, slab));
 237     if (slab == MAP_FAILED) {
 238         perror("mmap failed");
 239         abort();
 240     }
 241     slab->opslab_size = (U16)sz;
 242 #else
 243     OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
 244 #endif
 245 #ifndef WIN32
 246     /* The context is unused in non-Windows */
 247     PERL_UNUSED_CONTEXT;
 248 #endif
 249     slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
 250     return slab;
 251 }
 252
 253 /* requires double parens and aTHX_ */
 254 #define DEBUG_S_warn(args)                                             \
 255     DEBUG_S(                                                            \
 256         PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
 257     )
 258
 259 void *
 260 Perl_Slab_Alloc(pTHX_ size_t sz)
 261 {
 262     OPSLAB *slab;
 263     OPSLAB *slab2;
 264     OPSLOT *slot;
 265     OP *o;
 266     size_t opsz, space;
 267
 268     /* We only allocate ops from the slab during subroutine compilation.
 269        We find the slab via PL_compcv, hence that must be non-NULL. It could
 270        also be pointing to a subroutine which is now fully set up (CvROOT()
 271        pointing to the top of the optree for that sub), or a subroutine
 272        which isn't using the slab allocator. If our sanity checks aren't met,
 273        don't use a slab, but allocate the OP directly from the heap.  */
 274     if (!PL_compcv || CvROOT(PL_compcv)
 275      || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
 276     {
 277         o = (OP*)PerlMemShared_calloc(1, sz);
 278         goto gotit;
 279     }
 280
 281     /* While the subroutine is under construction, the slabs are accessed via
 282        CvSTART(), to avoid needing to expand PVCV by one pointer for something
 283        unneeded at runtime. Once a subroutine is constructed, the slabs are
 284        accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
 285        allocated yet.  See the commit message for 8be227ab5eaa23f2 for more
 286        details.  */
 287     if (!CvSTART(PL_compcv)) {
 288         CvSTART(PL_compcv) =
 289             (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
 290         CvSLABBED_on(PL_compcv);
 291         slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
 292     }
 293     else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
 294
 295     opsz = SIZE_TO_PSIZE(sz);
 296     sz = opsz + OPSLOT_HEADER_P;
 297
 298     /* The slabs maintain a free list of OPs. In particular, constant folding
 299        will free up OPs, so it makes sense to re-use them where possible. A
 300        freed up slot is used in preference to a new allocation.  */
 301     if (slab->opslab_freed) {
 302         OP **too = &slab->opslab_freed;
 303         o = *too;
 304         DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", (void*)o, (void*)slab));
 305         while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
 306             DEBUG_S_warn((aTHX_ "Alas! too small"));
 307             o = *(too = &o->op_next);
 308             if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", (void*)o)); }
 309         }
 310         if (o) {
 311             *too = o->op_next;
 312             Zero(o, opsz, I32 *);
 313             o->op_slabbed = 1;
 314             goto gotit;
 315         }
 316     }
 317
 318 #define INIT_OPSLOT \
 319             slot->opslot_slab = slab;                   \
 320             slot->opslot_next = slab2->opslab_first;    \
 321             slab2->opslab_first = slot;                 \
 322             o = &slot->opslot_op;                       \
 323             o->op_slabbed = 1
 324
 325     /* The partially-filled slab is next in the chain. */
 326     slab2 = slab->opslab_next ? slab->opslab_next : slab;
 327     if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
 328         /* Remaining space is too small. */
 329
 330         /* If we can fit a BASEOP, add it to the free chain, so as not
 331            to waste it. */
 332         if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
 333             slot = &slab2->opslab_slots;
 334             INIT_OPSLOT;
 335             o->op_type = OP_FREED;
 336             o->op_next = slab->opslab_freed;
 337             slab->opslab_freed = o;
 338         }
 339
 340         /* Create a new slab.  Make this one twice as big. */
 341         slot = slab2->opslab_first;
 342         while (slot->opslot_next) slot = slot->opslot_next;
 343         slab2 = S_new_slab(aTHX_
 344                             (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
 345                                         ? PERL_MAX_SLAB_SIZE
 346                                         : (DIFF(slab2, slot)+1)*2);
 347         slab2->opslab_next = slab->opslab_next;
 348         slab->opslab_next = slab2;
 349     }
 350     assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
 351
 352     /* Create a new op slot */
 353     slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
 354     assert(slot >= &slab2->opslab_slots);
 355     if (DIFF(&slab2->opslab_slots, slot)
 356          < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
 357         slot = &slab2->opslab_slots;
 358     INIT_OPSLOT;
 359     DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab));
 360
 361   gotit:
 362 #ifdef PERL_OP_PARENT
 363     /* moresib == 0, op_sibling == 0 implies a solitary unattached op */
 364     assert(!o->op_moresib);
 365     assert(!o->op_sibparent);
 366 #endif
 367
 368     return (void *)o;
 369 }
 370
 371 #undef INIT_OPSLOT
 372
 373 #ifdef PERL_DEBUG_READONLY_OPS
 374 void
 375 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
 376 {
 377     PERL_ARGS_ASSERT_SLAB_TO_RO;
 378
 379     if (slab->opslab_readonly) return;
 380     slab->opslab_readonly = 1;
 381     for (; slab; slab = slab->opslab_next) {
 382         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
 383                               (unsigned long) slab->opslab_size, slab));*/
 384         if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
 385             Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
 386                              (unsigned long)slab->opslab_size, errno);
 387     }
 388 }
 389
 390 void
 391 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
 392 {
 393     OPSLAB *slab2;
 394
 395     PERL_ARGS_ASSERT_SLAB_TO_RW;
 396
 397     if (!slab->opslab_readonly) return;
 398     slab2 = slab;
 399     for (; slab2; slab2 = slab2->opslab_next) {
 400         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
 401                               (unsigned long) size, slab2));*/
 402         if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
 403                      PROT_READ|PROT_WRITE)) {
 404             Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
 405                              (unsigned long)slab2->opslab_size, errno);
 406         }
 407     }
 408     slab->opslab_readonly = 0;
 409 }
 410
 411 #else
 412 #  define Slab_to_rw(op)    NOOP
 413 #endif
 414
 415 /* This cannot possibly be right, but it was copied from the old slab
 416    allocator, to which it was originally added, without explanation, in
 417    commit 083fcd5. */
 418 #ifdef NETWARE
 419 #    define PerlMemShared PerlMem
 420 #endif
 421
 422 void
 423 Perl_Slab_Free(pTHX_ void *op)
 424 {
 425     OP * const o = (OP *)op;
 426     OPSLAB *slab;
 427
 428     PERL_ARGS_ASSERT_SLAB_FREE;
 429
 430     if (!o->op_slabbed) {
 431         if (!o->op_static)
 432             PerlMemShared_free(op);
 433         return;
 434     }
 435
 436     slab = OpSLAB(o);
 437     /* If this op is already freed, our refcount will get screwy. */
 438     assert(o->op_type != OP_FREED);
 439     o->op_type = OP_FREED;
 440     o->op_next = slab->opslab_freed;
 441     slab->opslab_freed = o;
 442     DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", (void*)o, (void*)slab));
 443     OpslabREFCNT_dec_padok(slab);
 444 }
 445
 446 void
 447 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
 448 {
 449     const bool havepad = !!PL_comppad;
 450     PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
 451     if (havepad) {
 452         ENTER;
 453         PAD_SAVE_SETNULLPAD();
 454     }
 455     opslab_free(slab);
 456     if (havepad) LEAVE;
 457 }
 458
 459 void
 460 Perl_opslab_free(pTHX_ OPSLAB *slab)
 461 {
 462     OPSLAB *slab2;
 463     PERL_ARGS_ASSERT_OPSLAB_FREE;
 464     PERL_UNUSED_CONTEXT;
 465     DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
 466     assert(slab->opslab_refcnt == 1);
 467     do {
 468         slab2 = slab->opslab_next;
 469 #ifdef DEBUGGING
 470         slab->opslab_refcnt = ~(size_t)0;
 471 #endif
 472 #ifdef PERL_DEBUG_READONLY_OPS
 473         DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
 474                                                (void*)slab));
 475         if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
 476             perror("munmap failed");
 477             abort();
 478         }
 479 #else
 480         PerlMemShared_free(slab);
 481 #endif
 482         slab = slab2;
 483     } while (slab);
 484 }
 485
 486 void
 487 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
 488 {
 489     OPSLAB *slab2;
 490     OPSLOT *slot;
 491 #ifdef DEBUGGING
 492     size_t savestack_count = 0;
 493 #endif
 494     PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
 495     slab2 = slab;
 496     do {
 497         for (slot = slab2->opslab_first;
 498              slot->opslot_next;
 499              slot = slot->opslot_next) {
 500             if (slot->opslot_op.op_type != OP_FREED
 501              && !(slot->opslot_op.op_savefree
 502 #ifdef DEBUGGING
 503                   && ++savestack_count
 504 #endif
 505                  )
 506             ) {
 507                 assert(slot->opslot_op.op_slabbed);
 508                 op_free(&slot->opslot_op);
 509                 if (slab->opslab_refcnt == 1) goto free;
 510             }
 511         }
 512     } while ((slab2 = slab2->opslab_next));
 513     /* > 1 because the CV still holds a reference count. */
 514     if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
 515 #ifdef DEBUGGING
 516         assert(savestack_count == slab->opslab_refcnt-1);
 517 #endif
 518         /* Remove the CV’s reference count. */
 519         slab->opslab_refcnt--;
 520         return;
 521     }
 522    free:
 523     opslab_free(slab);
 524 }
 525
 526 #ifdef PERL_DEBUG_READONLY_OPS
 527 OP *
 528 Perl_op_refcnt_inc(pTHX_ OP *o)
 529 {
 530     if(o) {
 531         OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
 532         if (slab && slab->opslab_readonly) {
 533             Slab_to_rw(slab);
 534             ++o->op_targ;
 535             Slab_to_ro(slab);
 536         } else {
 537             ++o->op_targ;
 538         }
 539     }
 540     return o;
 541
 542 }
 543
 544 PADOFFSET
 545 Perl_op_refcnt_dec(pTHX_ OP *o)
 546 {
 547     PADOFFSET result;
 548     OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
 549
 550     PERL_ARGS_ASSERT_OP_REFCNT_DEC;
 551
 552     if (slab && slab->opslab_readonly) {
 553         Slab_to_rw(slab);
 554         result = --o->op_targ;
 555         Slab_to_ro(slab);
 556     } else {
 557         result = --o->op_targ;
 558     }
 559     return result;
 560 }
 561 #endif
 562 /*
 563  * In the following definition, the ", (OP*)0" is just to make the compiler
 564  * think the expression is of the right type: croak actually does a Siglongjmp.
 565  */
 566 #define CHECKOP(type,o) \
 567     ((PL_op_mask && PL_op_mask[type])                           \
 568      ? ( op_free((OP*)o),                                       \
 569          Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]),  \
 570          (OP*)0 )                                               \
 571      : PL_check[type](aTHX_ (OP*)o))
 572
 573 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
 574
 575 #define OpTYPE_set(o,type) \
 576     STMT_START {                                \
 577         o->op_type = (OPCODE)type;              \
 578         o->op_ppaddr = PL_ppaddr[type];         \
 579     } STMT_END
 580
 581 STATIC OP *
 582 S_no_fh_allowed(pTHX_ OP *o)
 583 {
 584     PERL_ARGS_ASSERT_NO_FH_ALLOWED;
 585
 586     yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
 587                  OP_DESC(o)));
 588     return o;
 589 }
 590
 591 STATIC OP *
 592 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
 593 {
 594     PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
 595     yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
 596     return o;
 597 }
 598
 599 STATIC OP *
 600 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
 601 {
 602     PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
 603
 604     yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
 605     return o;
 606 }
 607
 608 STATIC void
 609 S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid)
 610 {
 611     PERL_ARGS_ASSERT_BAD_TYPE_PV;
 612
 613     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
 614                  (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);
 615 }
 616
 617 /* remove flags var, its unused in all callers, move to to right end since gv
 618   and kid are always the same */
 619 STATIC void
 620 S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)
 621 {
 622     SV * const namesv = cv_name((CV *)gv, NULL, 0);
 623     PERL_ARGS_ASSERT_BAD_TYPE_GV;
 624
 625     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
 626                  (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
 627 }
 628
 629 STATIC void
 630 S_no_bareword_allowed(pTHX_ OP *o)
 631 {
 632     PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
 633
 634     qerror(Perl_mess(aTHX_
 635                      "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
 636                      SVfARG(cSVOPo_sv)));
 637     o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
 638 }
 639
 640 /* "register" allocation */
 641
 642 PADOFFSET
 643 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
 644 {
 645     PADOFFSET off;
 646     const bool is_our = (PL_parser->in_my == KEY_our);
 647
 648     PERL_ARGS_ASSERT_ALLOCMY;
 649
 650     if (flags & ~SVf_UTF8)
 651         Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
 652                    (UV)flags);
 653
 654     /* complain about "my $<special_var>" etc etc */
 655     if (len &&
 656         !(is_our ||
 657           isALPHA(name[1]) ||
 658           ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
 659           (name[1] == '_' && len > 2)))
 660     {
 661         if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
 662          && isASCII(name[1])
 663          && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
 664             yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
 665                               name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
 666                               PL_parser->in_my == KEY_state ? "state" : "my"));
 667         } else {
 668             yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
 669                               PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
 670         }
 671     }
 672
 673     /* allocate a spare slot and store the name in that slot */
 674
 675     off = pad_add_name_pvn(name, len,
 676                        (is_our ? padadd_OUR :
 677                         PL_parser->in_my == KEY_state ? padadd_STATE : 0),
 678                     PL_parser->in_my_stash,
 679                     (is_our
 680                         /* $_ is always in main::, even with our */
 681                         ? (PL_curstash && !memEQs(name,len,"$_")
 682                             ? PL_curstash
 683                             : PL_defstash)
 684                         : NULL
 685                     )
 686     );
 687     /* anon sub prototypes contains state vars should always be cloned,
 688      * otherwise the state var would be shared between anon subs */
 689
 690     if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
 691         CvCLONE_on(PL_compcv);
 692
 693     return off;
 694 }
 695
 696 /*
 697 =head1 Optree Manipulation Functions
 698
 699 =for apidoc alloccopstash
 700
 701 Available only under threaded builds, this function allocates an entry in
 702 C<PL_stashpad> for the stash passed to it.
 703
 704 =cut
 705 */
 706
 707 #ifdef USE_ITHREADS
 708 PADOFFSET
 709 Perl_alloccopstash(pTHX_ HV *hv)
 710 {
 711     PADOFFSET off = 0, o = 1;
 712     bool found_slot = FALSE;
 713
 714     PERL_ARGS_ASSERT_ALLOCCOPSTASH;
 715
 716     if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
 717
 718     for (; o < PL_stashpadmax; ++o) {
 719         if (PL_stashpad[o] == hv) return PL_stashpadix = o;
 720         if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
 721             found_slot = TRUE, off = o;
 722     }
 723     if (!found_slot) {
 724         Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
 725         Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
 726         off = PL_stashpadmax;
 727         PL_stashpadmax += 10;
 728     }
 729
 730     PL_stashpad[PL_stashpadix = off] = hv;
 731     return off;
 732 }
 733 #endif
 734
 735 /* free the body of an op without examining its contents.
 736  * Always use this rather than FreeOp directly */
 737
 738 static void
 739 S_op_destroy(pTHX_ OP *o)
 740 {
 741     FreeOp(o);
 742 }
 743
 744 /* Destructor */
 745
 746 /*
 747 =for apidoc Am|void|op_free|OP *o
 748
 749 Free an op.  Only use this when an op is no longer linked to from any
 750 optree.
 751
 752 =cut
 753 */
 754
 755 void
 756 Perl_op_free(pTHX_ OP *o)
 757 {
 758     dVAR;
 759     OPCODE type;
 760     SSize_t defer_ix = -1;
 761     SSize_t defer_stack_alloc = 0;
 762     OP **defer_stack = NULL;
 763
 764     do {
 765
 766         /* Though ops may be freed twice, freeing the op after its slab is a
 767            big no-no. */
 768         assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
 769         /* During the forced freeing of ops after compilation failure, kidops
 770            may be freed before their parents. */
 771         if (!o || o->op_type == OP_FREED)
 772             continue;
 773
 774         type = o->op_type;
 775
 776         /* an op should only ever acquire op_private flags that we know about.
 777          * If this fails, you may need to fix something in regen/op_private.
 778          * Don't bother testing if:
 779          *   * the op_ppaddr doesn't match the op; someone may have
 780          *     overridden the op and be doing strange things with it;
 781          *   * we've errored, as op flags are often left in an
 782          *     inconsistent state then. Note that an error when
 783          *     compiling the main program leaves PL_parser NULL, so
 784          *     we can't spot faults in the main code, only
 785          *     evaled/required code */
 786 #ifdef DEBUGGING
 787         if (   o->op_ppaddr == PL_ppaddr[o->op_type]
 788             && PL_parser
 789             && !PL_parser->error_count)
 790         {
 791             assert(!(o->op_private & ~PL_op_private_valid[type]));
 792         }
 793 #endif
 794
 795         if (o->op_private & OPpREFCOUNTED) {
 796             switch (type) {
 797             case OP_LEAVESUB:
 798             case OP_LEAVESUBLV:
 799             case OP_LEAVEEVAL:
 800             case OP_LEAVE:
 801             case OP_SCOPE:
 802             case OP_LEAVEWRITE:
 803                 {
 804                 PADOFFSET refcnt;
 805                 OP_REFCNT_LOCK;
 806                 refcnt = OpREFCNT_dec(o);
 807                 OP_REFCNT_UNLOCK;
 808                 if (refcnt) {
 809                     /* Need to find and remove any pattern match ops from the list
 810                        we maintain for reset().  */
 811                     find_and_forget_pmops(o);
 812                     continue;
 813                 }
 814                 }
 815                 break;
 816             default:
 817                 break;
 818             }
 819         }
 820
 821         /* Call the op_free hook if it has been set. Do it now so that it's called
 822          * at the right time for refcounted ops, but still before all of the kids
 823          * are freed. */
 824         CALL_OPFREEHOOK(o);
 825
 826         if (o->op_flags & OPf_KIDS) {
 827             OP *kid, *nextkid;
 828             for (kid = cUNOPo->op_first; kid; kid = nextkid) {
 829                 nextkid = OpSIBLING(kid); /* Get before next freeing kid */
 830                 if (!kid || kid->op_type == OP_FREED)
 831                     /* During the forced freeing of ops after
 832                        compilation failure, kidops may be freed before
 833                        their parents. */
 834                     continue;
 835                 if (!(kid->op_flags & OPf_KIDS))
 836                     /* If it has no kids, just free it now */
 837                     op_free(kid);
 838                 else
 839                     DEFER_OP(kid);
 840             }
 841         }
 842         if (type == OP_NULL)
 843             type = (OPCODE)o->op_targ;
 844
 845         if (o->op_slabbed)
 846             Slab_to_rw(OpSLAB(o));
 847
 848         /* COP* is not cleared by op_clear() so that we may track line
 849          * numbers etc even after null() */
 850         if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
 851             cop_free((COP*)o);
 852         }
 853
 854         op_clear(o);
 855         FreeOp(o);
 856 #ifdef DEBUG_LEAKING_SCALARS
 857         if (PL_op == o)
 858             PL_op = NULL;
 859 #endif
 860     } while ( (o = POP_DEFERRED_OP()) );
 861
 862     Safefree(defer_stack);
 863 }
 864
 865 /* S_op_clear_gv(): free a GV attached to an OP */
 866
 867 STATIC
 868 #ifdef USE_ITHREADS
 869 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
 870 #else
 871 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
 872 #endif
 873 {
 874
 875     GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
 876             || o->op_type == OP_MULTIDEREF)
 877 #ifdef USE_ITHREADS
 878                 && PL_curpad
 879                 ? ((GV*)PAD_SVl(*ixp)) : NULL;
 880 #else
 881                 ? (GV*)(*svp) : NULL;
 882 #endif
 883     /* It's possible during global destruction that the GV is freed
 884        before the optree. Whilst the SvREFCNT_inc is happy to bump from
 885        0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
 886        will trigger an assertion failure, because the entry to sv_clear
 887        checks that the scalar is not already freed.  A check of for
 888        !SvIS_FREED(gv) turns out to be invalid, because during global
 889        destruction the reference count can be forced down to zero
 890        (with SVf_BREAK set).  In which case raising to 1 and then
 891        dropping to 0 triggers cleanup before it should happen.  I
 892        *think* that this might actually be a general, systematic,
 893        weakness of the whole idea of SVf_BREAK, in that code *is*
 894        allowed to raise and lower references during global destruction,
 895        so any *valid* code that happens to do this during global
 896        destruction might well trigger premature cleanup.  */
 897     bool still_valid = gv && SvREFCNT(gv);
 898
 899     if (still_valid)
 900         SvREFCNT_inc_simple_void(gv);
 901 #ifdef USE_ITHREADS
 902     if (*ixp > 0) {
 903         pad_swipe(*ixp, TRUE);
 904         *ixp = 0;
 905     }
 906 #else
 907     SvREFCNT_dec(*svp);
 908     *svp = NULL;
 909 #endif
 910     if (still_valid) {
 911         int try_downgrade = SvREFCNT(gv) == 2;
 912         SvREFCNT_dec_NN(gv);
 913         if (try_downgrade)
 914             gv_try_downgrade(gv);
 915     }
 916 }
 917
 918
 919 void
 920 Perl_op_clear(pTHX_ OP *o)
 921 {
 922
 923     dVAR;
 924
 925     PERL_ARGS_ASSERT_OP_CLEAR;
 926
 927     switch (o->op_type) {
 928     case OP_NULL:       /* Was holding old type, if any. */
 929         /* FALLTHROUGH */
 930     case OP_ENTERTRY:
 931     case OP_ENTEREVAL:  /* Was holding hints. */
 932         o->op_targ = 0;
 933         break;
 934     default:
 935         if (!(o->op_flags & OPf_REF)
 936             || (PL_check[o->op_type] != Perl_ck_ftst))
 937             break;
 938         /* FALLTHROUGH */
 939     case OP_GVSV:
 940     case OP_GV:
 941     case OP_AELEMFAST:
 942 #ifdef USE_ITHREADS
 943             S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
 944 #else
 945             S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
 946 #endif
 947         break;
 948     case OP_METHOD_REDIR:
 949     case OP_METHOD_REDIR_SUPER:
 950 #ifdef USE_ITHREADS
 951         if (cMETHOPx(o)->op_rclass_targ) {
 952             pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
 953             cMETHOPx(o)->op_rclass_targ = 0;
 954         }
 955 #else
 956         SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
 957         cMETHOPx(o)->op_rclass_sv = NULL;
 958 #endif
 959     case OP_METHOD_NAMED:
 960     case OP_METHOD_SUPER:
 961         SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
 962         cMETHOPx(o)->op_u.op_meth_sv = NULL;
 963 #ifdef USE_ITHREADS
 964         if (o->op_targ) {
 965             pad_swipe(o->op_targ, 1);
 966             o->op_targ = 0;
 967         }
 968 #endif
 969         break;
 970     case OP_CONST:
 971     case OP_HINTSEVAL:
 972         SvREFCNT_dec(cSVOPo->op_sv);
 973         cSVOPo->op_sv = NULL;
 974 #ifdef USE_ITHREADS
 975         /** Bug #15654
 976           Even if op_clear does a pad_free for the target of the op,
 977           pad_free doesn't actually remove the sv that exists in the pad;
 978           instead it lives on. This results in that it could be reused as
 979           a target later on when the pad was reallocated.
 980         **/
 981         if(o->op_targ) {
 982           pad_swipe(o->op_targ,1);
 983           o->op_targ = 0;
 984         }
 985 #endif
 986         break;
 987     case OP_DUMP:
 988     case OP_GOTO:
 989     case OP_NEXT:
 990     case OP_LAST:
 991     case OP_REDO:
 992         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
 993             break;
 994         /* FALLTHROUGH */
 995     case OP_TRANS:
 996     case OP_TRANSR:
 997         if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
 998             assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
 999 #ifdef USE_ITHREADS
1000             if (cPADOPo->op_padix > 0) {
1001                 pad_swipe(cPADOPo->op_padix, TRUE);
1002                 cPADOPo->op_padix = 0;
1003             }
1004 #else
1005             SvREFCNT_dec(cSVOPo->op_sv);
1006             cSVOPo->op_sv = NULL;
1007 #endif
1008         }
1009         else {
1010             PerlMemShared_free(cPVOPo->op_pv);
1011             cPVOPo->op_pv = NULL;
1012         }
1013         break;
1014     case OP_SUBST:
1015         op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
1016         goto clear_pmop;
1017     case OP_PUSHRE:
1018 #ifdef USE_ITHREADS
1019         if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
1020             pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
1021         }
1022 #else
1023         SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
1024 #endif
1025         /* FALLTHROUGH */
1026     case OP_MATCH:
1027     case OP_QR:
1028     clear_pmop:
1029         if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
1030             op_free(cPMOPo->op_code_list);
1031         cPMOPo->op_code_list = NULL;
1032         forget_pmop(cPMOPo);
1033         cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
1034         /* we use the same protection as the "SAFE" version of the PM_ macros
1035          * here since sv_clean_all might release some PMOPs
1036          * after PL_regex_padav has been cleared
1037          * and the clearing of PL_regex_padav needs to
1038          * happen before sv_clean_all
1039          */
1040 #ifdef USE_ITHREADS
1041         if(PL_regex_pad) {        /* We could be in destruction */
1042             const IV offset = (cPMOPo)->op_pmoffset;
1043             ReREFCNT_dec(PM_GETRE(cPMOPo));
1044             PL_regex_pad[offset] = &PL_sv_undef;
1045             sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
1046                            sizeof(offset));
1047         }
1048 #else
1049         ReREFCNT_dec(PM_GETRE(cPMOPo));
1050         PM_SETRE(cPMOPo, NULL);
1051 #endif
1052
1053         break;
1054
1055     case OP_MULTIDEREF:
1056         {
1057             UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1058             UV actions = items->uv;
1059             bool last = 0;
1060             bool is_hash = FALSE;
1061
1062             while (!last) {
1063                 switch (actions & MDEREF_ACTION_MASK) {
1064
1065                 case MDEREF_reload:
1066                     actions = (++items)->uv;
1067                     continue;
1068
1069                 case MDEREF_HV_padhv_helem:
1070                     is_hash = TRUE;
1071                 case MDEREF_AV_padav_aelem:
1072                     pad_free((++items)->pad_offset);
1073                     goto do_elem;
1074
1075                 case MDEREF_HV_gvhv_helem:
1076                     is_hash = TRUE;
1077                 case MDEREF_AV_gvav_aelem:
1078 #ifdef USE_ITHREADS
1079                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1080 #else
1081                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1082 #endif
1083                     goto do_elem;
1084
1085                 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1086                     is_hash = TRUE;
1087                 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1088 #ifdef USE_ITHREADS
1089                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1090 #else
1091                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1092 #endif
1093                     goto do_vivify_rv2xv_elem;
1094
1095                 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1096                     is_hash = TRUE;
1097                 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1098                     pad_free((++items)->pad_offset);
1099                     goto do_vivify_rv2xv_elem;
1100
1101                 case MDEREF_HV_pop_rv2hv_helem:
1102                 case MDEREF_HV_vivify_rv2hv_helem:
1103                     is_hash = TRUE;
1104                 do_vivify_rv2xv_elem:
1105                 case MDEREF_AV_pop_rv2av_aelem:
1106                 case MDEREF_AV_vivify_rv2av_aelem:
1107                 do_elem:
1108                     switch (actions & MDEREF_INDEX_MASK) {
1109                     case MDEREF_INDEX_none:
1110                         last = 1;
1111                         break;
1112                     case MDEREF_INDEX_const:
1113                         if (is_hash) {
1114 #ifdef USE_ITHREADS
1115                             /* see RT #15654 */
1116                             pad_swipe((++items)->pad_offset, 1);
1117 #else
1118                             SvREFCNT_dec((++items)->sv);
1119 #endif
1120                         }
1121                         else
1122                             items++;
1123                         break;
1124                     case MDEREF_INDEX_padsv:
1125                         pad_free((++items)->pad_offset);
1126                         break;
1127                     case MDEREF_INDEX_gvsv:
1128 #ifdef USE_ITHREADS
1129                         S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1130 #else
1131                         S_op_clear_gv(aTHX_ o, &((++items)->sv));
1132 #endif
1133                         break;
1134                     }
1135
1136                     if (actions & MDEREF_FLAG_last)
1137                         last = 1;
1138                     is_hash = FALSE;
1139
1140                     break;
1141
1142                 default:
1143                     assert(0);
1144                     last = 1;
1145                     break;
1146
1147                 } /* switch */
1148
1149                 actions >>= MDEREF_SHIFT;
1150             } /* while */
1151
1152             /* start of malloc is at op_aux[-1], where the length is
1153              * stored */
1154             PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1155         }
1156         break;
1157     }
1158
1159     if (o->op_targ > 0) {
1160         pad_free(o->op_targ);
1161         o->op_targ = 0;
1162     }
1163 }
1164
1165 STATIC void
1166 S_cop_free(pTHX_ COP* cop)
1167 {
1168     PERL_ARGS_ASSERT_COP_FREE;
1169
1170     CopFILE_free(cop);
1171     if (! specialWARN(cop->cop_warnings))
1172         PerlMemShared_free(cop->cop_warnings);
1173     cophh_free(CopHINTHASH_get(cop));
1174     if (PL_curcop == cop)
1175        PL_curcop = NULL;
1176 }
1177
1178 STATIC void
1179 S_forget_pmop(pTHX_ PMOP *const o
1180               )
1181 {
1182     HV * const pmstash = PmopSTASH(o);
1183
1184     PERL_ARGS_ASSERT_FORGET_PMOP;
1185
1186     if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1187         MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1188         if (mg) {
1189             PMOP **const array = (PMOP**) mg->mg_ptr;
1190             U32 count = mg->mg_len / sizeof(PMOP**);
1191             U32 i = count;
1192
1193             while (i--) {
1194                 if (array[i] == o) {
1195                     /* Found it. Move the entry at the end to overwrite it.  */
1196                     array[i] = array[--count];
1197                     mg->mg_len = count * sizeof(PMOP**);
1198                     /* Could realloc smaller at this point always, but probably
1199                        not worth it. Probably worth free()ing if we're the
1200                        last.  */
1201                     if(!count) {
1202                         Safefree(mg->mg_ptr);
1203                         mg->mg_ptr = NULL;
1204                     }
1205                     break;
1206                 }
1207             }
1208         }
1209     }
1210     if (PL_curpm == o)
1211         PL_curpm = NULL;
1212 }
1213
1214 STATIC void
1215 S_find_and_forget_pmops(pTHX_ OP *o)
1216 {
1217     PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1218
1219     if (o->op_flags & OPf_KIDS) {
1220         OP *kid = cUNOPo->op_first;
1221         while (kid) {
1222             switch (kid->op_type) {
1223             case OP_SUBST:
1224             case OP_PUSHRE:
1225             case OP_MATCH:
1226             case OP_QR:
1227                 forget_pmop((PMOP*)kid);
1228             }
1229             find_and_forget_pmops(kid);
1230             kid = OpSIBLING(kid);
1231         }
1232     }
1233 }
1234
1235 /*
1236 =for apidoc Am|void|op_null|OP *o
1237
1238 Neutralizes an op when it is no longer needed, but is still linked to from
1239 other ops.
1240
1241 =cut
1242 */
1243
1244 void
1245 Perl_op_null(pTHX_ OP *o)
1246 {
1247     dVAR;
1248
1249     PERL_ARGS_ASSERT_OP_NULL;
1250
1251     if (o->op_type == OP_NULL)
1252         return;
1253     op_clear(o);
1254     o->op_targ = o->op_type;
1255     OpTYPE_set(o, OP_NULL);
1256 }
1257
1258 void
1259 Perl_op_refcnt_lock(pTHX)
1260   PERL_TSA_ACQUIRE(PL_op_mutex)
1261 {
1262 #ifdef USE_ITHREADS
1263     dVAR;
1264 #endif
1265     PERL_UNUSED_CONTEXT;
1266     OP_REFCNT_LOCK;
1267 }
1268
1269 void
1270 Perl_op_refcnt_unlock(pTHX)
1271   PERL_TSA_RELEASE(PL_op_mutex)
1272 {
1273 #ifdef USE_ITHREADS
1274     dVAR;
1275 #endif
1276     PERL_UNUSED_CONTEXT;
1277     OP_REFCNT_UNLOCK;
1278 }
1279
1280
1281 /*
1282 =for apidoc op_sibling_splice
1283
1284 A general function for editing the structure of an existing chain of
1285 op_sibling nodes.  By analogy with the perl-level C<splice()> function, allows
1286 you to delete zero or more sequential nodes, replacing them with zero or
1287 more different nodes.  Performs the necessary op_first/op_last
1288 housekeeping on the parent node and op_sibling manipulation on the
1289 children.  The last deleted node will be marked as as the last node by
1290 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1291
1292 Note that op_next is not manipulated, and nodes are not freed; that is the
1293 responsibility of the caller.  It also won't create a new list op for an
1294 empty list etc; use higher-level functions like op_append_elem() for that.
1295
1296 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1297 the splicing doesn't affect the first or last op in the chain.
1298
1299 C<start> is the node preceding the first node to be spliced.  Node(s)
1300 following it will be deleted, and ops will be inserted after it.  If it is
1301 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1302 beginning.
1303
1304 C<del_count> is the number of nodes to delete.  If zero, no nodes are deleted.
1305 If -1 or greater than or equal to the number of remaining kids, all
1306 remaining kids are deleted.
1307
1308 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1309 If C<NULL>, no nodes are inserted.
1310
1311 The head of the chain of deleted ops is returned, or C<NULL> if no ops were
1312 deleted.
1313
1314 For example:
1315
1316     action                    before      after         returns
1317     ------                    -----       -----         -------
1318
1319                               P           P
1320     splice(P, A, 2, X-Y-Z)    |           |             B-C
1321                               A-B-C-D     A-X-Y-Z-D
1322
1323                               P           P
1324     splice(P, NULL, 1, X-Y)   |           |             A
1325                               A-B-C-D     X-Y-B-C-D
1326
1327                               P           P
1328     splice(P, NULL, 3, NULL)  |           |             A-B-C
1329                               A-B-C-D     D
1330
1331                               P           P
1332     splice(P, B, 0, X-Y)      |           |             NULL
1333                               A-B-C-D     A-B-X-Y-C-D
1334
1335
1336 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1337 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
1338
1339 =cut
1340 */
1341
1342 OP *
1343 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1344 {
1345     OP *first;
1346     OP *rest;
1347     OP *last_del = NULL;
1348     OP *last_ins = NULL;
1349
1350     if (start)
1351         first = OpSIBLING(start);
1352     else if (!parent)
1353         goto no_parent;
1354     else
1355         first = cLISTOPx(parent)->op_first;
1356
1357     assert(del_count >= -1);
1358
1359     if (del_count && first) {
1360         last_del = first;
1361         while (--del_count && OpHAS_SIBLING(last_del))
1362             last_del = OpSIBLING(last_del);
1363         rest = OpSIBLING(last_del);
1364         OpLASTSIB_set(last_del, NULL);
1365     }
1366     else
1367         rest = first;
1368
1369     if (insert) {
1370         last_ins = insert;
1371         while (OpHAS_SIBLING(last_ins))
1372             last_ins = OpSIBLING(last_ins);
1373         OpMAYBESIB_set(last_ins, rest, NULL);
1374     }
1375     else
1376         insert = rest;
1377
1378     if (start) {
1379         OpMAYBESIB_set(start, insert, NULL);
1380     }
1381     else {
1382         if (!parent)
1383             goto no_parent;
1384         cLISTOPx(parent)->op_first = insert;
1385         if (insert)
1386             parent->op_flags |= OPf_KIDS;
1387         else
1388             parent->op_flags &= ~OPf_KIDS;
1389     }
1390
1391     if (!rest) {
1392         /* update op_last etc */
1393         U32 type;
1394         OP *lastop;
1395
1396         if (!parent)
1397             goto no_parent;
1398
1399         /* ought to use OP_CLASS(parent) here, but that can't handle
1400          * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1401          * either */
1402         type = parent->op_type;
1403         if (type == OP_CUSTOM) {
1404             dTHX;
1405             type = XopENTRYCUSTOM(parent, xop_class);
1406         }
1407         else {
1408             if (type == OP_NULL)
1409                 type = parent->op_targ;
1410             type = PL_opargs[type] & OA_CLASS_MASK;
1411         }
1412
1413         lastop = last_ins ? last_ins : start ? start : NULL;
1414         if (   type == OA_BINOP
1415             || type == OA_LISTOP
1416             || type == OA_PMOP
1417             || type == OA_LOOP
1418         )
1419             cLISTOPx(parent)->op_last = lastop;
1420
1421         if (lastop)
1422             OpLASTSIB_set(lastop, parent);
1423     }
1424     return last_del ? first : NULL;
1425
1426   no_parent:
1427     Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1428 }
1429
1430
1431 #ifdef PERL_OP_PARENT
1432
1433 /*
1434 =for apidoc op_parent
1435
1436 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1437 This function is only available on perls built with C<-DPERL_OP_PARENT>.
1438
1439 =cut
1440 */
1441
1442 OP *
1443 Perl_op_parent(OP *o)
1444 {
1445     PERL_ARGS_ASSERT_OP_PARENT;
1446     while (OpHAS_SIBLING(o))
1447         o = OpSIBLING(o);
1448     return o->op_sibparent;
1449 }
1450
1451 #endif
1452
1453
1454 /* replace the sibling following start with a new UNOP, which becomes
1455  * the parent of the original sibling; e.g.
1456  *
1457  *  op_sibling_newUNOP(P, A, unop-args...)
1458  *
1459  *  P              P
1460  *  |      becomes |
1461  *  A-B-C          A-U-C
1462  *                   |
1463  *                   B
1464  *
1465  * where U is the new UNOP.
1466  *
1467  * parent and start args are the same as for op_sibling_splice();
1468  * type and flags args are as newUNOP().
1469  *
1470  * Returns the new UNOP.
1471  */
1472
1473 STATIC OP *
1474 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1475 {
1476     OP *kid, *newop;
1477
1478     kid = op_sibling_splice(parent, start, 1, NULL);
1479     newop = newUNOP(type, flags, kid);
1480     op_sibling_splice(parent, start, 0, newop);
1481     return newop;
1482 }
1483
1484
1485 /* lowest-level newLOGOP-style function - just allocates and populates
1486  * the struct. Higher-level stuff should be done by S_new_logop() /
1487  * newLOGOP(). This function exists mainly to avoid op_first assignment
1488  * being spread throughout this file.
1489  */
1490
1491 STATIC LOGOP *
1492 S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1493 {
1494     dVAR;
1495     LOGOP *logop;
1496     OP *kid = first;
1497     NewOp(1101, logop, 1, LOGOP);
1498     OpTYPE_set(logop, type);
1499     logop->op_first = first;
1500     logop->op_other = other;
1501     logop->op_flags = OPf_KIDS;
1502     while (kid && OpHAS_SIBLING(kid))
1503         kid = OpSIBLING(kid);
1504     if (kid)
1505         OpLASTSIB_set(kid, (OP*)logop);
1506     return logop;
1507 }
1508
1509
1510 /* Contextualizers */
1511
1512 /*
1513 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1514
1515 Applies a syntactic context to an op tree representing an expression.
1516 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
1517 or C<G_VOID> to specify the context to apply.  The modified op tree
1518 is returned.
1519
1520 =cut
1521 */
1522
1523 OP *
1524 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1525 {
1526     PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1527     switch (context) {
1528         case G_SCALAR: return scalar(o);
1529         case G_ARRAY:  return list(o);
1530         case G_VOID:   return scalarvoid(o);
1531         default:
1532             Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1533                        (long) context);
1534     }
1535 }
1536
1537 /*
1538
1539 =for apidoc Am|OP*|op_linklist|OP *o
1540 This function is the implementation of the L</LINKLIST> macro.  It should
1541 not be called directly.
1542
1543 =cut
1544 */
1545
1546 OP *
1547 Perl_op_linklist(pTHX_ OP *o)
1548 {
1549     OP *first;
1550
1551     PERL_ARGS_ASSERT_OP_LINKLIST;
1552
1553     if (o->op_next)
1554         return o->op_next;
1555
1556     /* establish postfix order */
1557     first = cUNOPo->op_first;
1558     if (first) {
1559         OP *kid;
1560         o->op_next = LINKLIST(first);
1561         kid = first;
1562         for (;;) {
1563             OP *sibl = OpSIBLING(kid);
1564             if (sibl) {
1565                 kid->op_next = LINKLIST(sibl);
1566                 kid = sibl;
1567             } else {
1568                 kid->op_next = o;
1569                 break;
1570             }
1571         }
1572     }
1573     else
1574         o->op_next = o;
1575
1576     return o->op_next;
1577 }
1578
1579 static OP *
1580 S_scalarkids(pTHX_ OP *o)
1581 {
1582     if (o && o->op_flags & OPf_KIDS) {
1583         OP *kid;
1584         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1585             scalar(kid);
1586     }
1587     return o;
1588 }
1589
1590 STATIC OP *
1591 S_scalarboolean(pTHX_ OP *o)
1592 {
1593     PERL_ARGS_ASSERT_SCALARBOOLEAN;
1594
1595     if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1596          !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1597         (o->op_type == OP_NOT     && cUNOPo->op_first->op_type == OP_SASSIGN &&
1598          cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1599          !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
1600         if (ckWARN(WARN_SYNTAX)) {
1601             const line_t oldline = CopLINE(PL_curcop);
1602
1603             if (PL_parser && PL_parser->copline != NOLINE) {
1604                 /* This ensures that warnings are reported at the first line
1605                    of the conditional, not the last.  */
1606                 CopLINE_set(PL_curcop, PL_parser->copline);
1607             }
1608             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1609             CopLINE_set(PL_curcop, oldline);
1610         }
1611     }
1612     return scalar(o);
1613 }
1614
1615 static SV *
1616 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1617 {
1618     assert(o);
1619     assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1620            o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1621     {
1622         const char funny  = o->op_type == OP_PADAV
1623                          || o->op_type == OP_RV2AV ? '@' : '%';
1624         if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1625             GV *gv;
1626             if (cUNOPo->op_first->op_type != OP_GV
1627              || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1628                 return NULL;
1629             return varname(gv, funny, 0, NULL, 0, subscript_type);
1630         }
1631         return
1632             varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1633     }
1634 }
1635
1636 static SV *
1637 S_op_varname(pTHX_ const OP *o)
1638 {
1639     return S_op_varname_subscript(aTHX_ o, 1);
1640 }
1641
1642 static void
1643 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1644 { /* or not so pretty :-) */
1645     if (o->op_type == OP_CONST) {
1646         *retsv = cSVOPo_sv;
1647         if (SvPOK(*retsv)) {
1648             SV *sv = *retsv;
1649             *retsv = sv_newmortal();
1650             pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1651                       PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1652         }
1653         else if (!SvOK(*retsv))
1654             *retpv = "undef";
1655     }
1656     else *retpv = "...";
1657 }
1658
1659 static void
1660 S_scalar_slice_warning(pTHX_ const OP *o)
1661 {
1662     OP *kid;
1663     const char lbrack =
1664         o->op_type == OP_HSLICE ? '{' : '[';
1665     const char rbrack =
1666         o->op_type == OP_HSLICE ? '}' : ']';
1667     SV *name;
1668     SV *keysv = NULL; /* just to silence compiler warnings */
1669     const char *key = NULL;
1670
1671     if (!(o->op_private & OPpSLICEWARNING))
1672         return;
1673     if (PL_parser && PL_parser->error_count)
1674         /* This warning can be nonsensical when there is a syntax error. */
1675         return;
1676
1677     kid = cLISTOPo->op_first;
1678     kid = OpSIBLING(kid); /* get past pushmark */
1679     /* weed out false positives: any ops that can return lists */
1680     switch (kid->op_type) {
1681     case OP_BACKTICK:
1682     case OP_GLOB:
1683     case OP_READLINE:
1684     case OP_MATCH:
1685     case OP_RV2AV:
1686     case OP_EACH:
1687     case OP_VALUES:
1688     case OP_KEYS:
1689     case OP_SPLIT:
1690     case OP_LIST:
1691     case OP_SORT:
1692     case OP_REVERSE:
1693     case OP_ENTERSUB:
1694     case OP_CALLER:
1695     case OP_LSTAT:
1696     case OP_STAT:
1697     case OP_READDIR:
1698     case OP_SYSTEM:
1699     case OP_TMS:
1700     case OP_LOCALTIME:
1701     case OP_GMTIME:
1702     case OP_ENTEREVAL:
1703         return;
1704     }
1705
1706     /* Don't warn if we have a nulled list either. */
1707     if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1708         return;
1709
1710     assert(OpSIBLING(kid));
1711     name = S_op_varname(aTHX_ OpSIBLING(kid));
1712     if (!name) /* XS module fiddling with the op tree */
1713         return;
1714     S_op_pretty(aTHX_ kid, &keysv, &key);
1715     assert(SvPOK(name));
1716     sv_chop(name,SvPVX(name)+1);
1717     if (key)
1718        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1719         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1720                    "Scalar value @%"SVf"%c%s%c better written as $%"SVf
1721                    "%c%s%c",
1722                     SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1723                     lbrack, key, rbrack);
1724     else
1725        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1726         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1727                    "Scalar value @%"SVf"%c%"SVf"%c better written as $%"
1728                     SVf"%c%"SVf"%c",
1729                     SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1730                     SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1731 }
1732
1733 OP *
1734 Perl_scalar(pTHX_ OP *o)
1735 {
1736     OP *kid;
1737
1738     /* assumes no premature commitment */
1739     if (!o || (PL_parser && PL_parser->error_count)
1740          || (o->op_flags & OPf_WANT)
1741          || o->op_type == OP_RETURN)
1742     {
1743         return o;
1744     }
1745
1746     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1747
1748     switch (o->op_type) {
1749     case OP_REPEAT:
1750         scalar(cBINOPo->op_first);
1751         if (o->op_private & OPpREPEAT_DOLIST) {
1752             kid = cLISTOPx(cUNOPo->op_first)->op_first;
1753             assert(kid->op_type == OP_PUSHMARK);
1754             if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1755                 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1756                 o->op_private &=~ OPpREPEAT_DOLIST;
1757             }
1758         }
1759         break;
1760     case OP_OR:
1761     case OP_AND:
1762     case OP_COND_EXPR:
1763         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
1764             scalar(kid);
1765         break;
1766         /* FALLTHROUGH */
1767     case OP_SPLIT:
1768     case OP_MATCH:
1769     case OP_QR:
1770     case OP_SUBST:
1771     case OP_NULL:
1772     default:
1773         if (o->op_flags & OPf_KIDS) {
1774             for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1775                 scalar(kid);
1776         }
1777         break;
1778     case OP_LEAVE:
1779     case OP_LEAVETRY:
1780         kid = cLISTOPo->op_first;
1781         scalar(kid);
1782         kid = OpSIBLING(kid);
1783     do_kids:
1784         while (kid) {
1785             OP *sib = OpSIBLING(kid);
1786             if (sib && kid->op_type != OP_LEAVEWHEN
1787              && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
1788                 || (  sib->op_targ != OP_NEXTSTATE
1789                    && sib->op_targ != OP_DBSTATE  )))
1790                 scalarvoid(kid);
1791             else
1792                 scalar(kid);
1793             kid = sib;
1794         }
1795         PL_curcop = &PL_compiling;
1796         break;
1797     case OP_SCOPE:
1798     case OP_LINESEQ:
1799     case OP_LIST:
1800         kid = cLISTOPo->op_first;
1801         goto do_kids;
1802     case OP_SORT:
1803         Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1804         break;
1805     case OP_KVHSLICE:
1806     case OP_KVASLICE:
1807     {
1808         /* Warn about scalar context */
1809         const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1810         const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1811         SV *name;
1812         SV *keysv;
1813         const char *key = NULL;
1814
1815         /* This warning can be nonsensical when there is a syntax error. */
1816         if (PL_parser && PL_parser->error_count)
1817             break;
1818
1819         if (!ckWARN(WARN_SYNTAX)) break;
1820
1821         kid = cLISTOPo->op_first;
1822         kid = OpSIBLING(kid); /* get past pushmark */
1823         assert(OpSIBLING(kid));
1824         name = S_op_varname(aTHX_ OpSIBLING(kid));
1825         if (!name) /* XS module fiddling with the op tree */
1826             break;
1827         S_op_pretty(aTHX_ kid, &keysv, &key);
1828         assert(SvPOK(name));
1829         sv_chop(name,SvPVX(name)+1);
1830         if (key)
1831   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1832             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1833                        "%%%"SVf"%c%s%c in scalar context better written "
1834                        "as $%"SVf"%c%s%c",
1835                         SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1836                         lbrack, key, rbrack);
1837         else
1838   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1839             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1840                        "%%%"SVf"%c%"SVf"%c in scalar context better "
1841                        "written as $%"SVf"%c%"SVf"%c",
1842                         SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1843                         SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1844     }
1845     }
1846     return o;
1847 }
1848
1849 OP *
1850 Perl_scalarvoid(pTHX_ OP *arg)
1851 {
1852     dVAR;
1853     OP *kid;
1854     SV* sv;
1855     U8 want;
1856     SSize_t defer_stack_alloc = 0;
1857     SSize_t defer_ix = -1;
1858     OP **defer_stack = NULL;
1859     OP *o = arg;
1860
1861     PERL_ARGS_ASSERT_SCALARVOID;
1862
1863     do {
1864         SV *useless_sv = NULL;
1865         const char* useless = NULL;
1866
1867         if (o->op_type == OP_NEXTSTATE
1868             || o->op_type == OP_DBSTATE
1869             || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1870                                           || o->op_targ == OP_DBSTATE)))
1871             PL_curcop = (COP*)o;                /* for warning below */
1872
1873         /* assumes no premature commitment */
1874         want = o->op_flags & OPf_WANT;
1875         if ((want && want != OPf_WANT_SCALAR)
1876             || (PL_parser && PL_parser->error_count)
1877             || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1878         {
1879             continue;
1880         }
1881
1882         if ((o->op_private & OPpTARGET_MY)
1883             && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1884         {
1885             /* newASSIGNOP has already applied scalar context, which we
1886                leave, as if this op is inside SASSIGN.  */
1887             continue;
1888         }
1889
1890         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1891
1892         switch (o->op_type) {
1893         default:
1894             if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1895                 break;
1896             /* FALLTHROUGH */
1897         case OP_REPEAT:
1898             if (o->op_flags & OPf_STACKED)
1899                 break;
1900             if (o->op_type == OP_REPEAT)
1901                 scalar(cBINOPo->op_first);
1902             goto func_ops;
1903         case OP_SUBSTR:
1904             if (o->op_private == 4)
1905                 break;
1906             /* FALLTHROUGH */
1907         case OP_WANTARRAY:
1908         case OP_GV:
1909         case OP_SMARTMATCH:
1910         case OP_AV2ARYLEN:
1911         case OP_REF:
1912         case OP_REFGEN:
1913         case OP_SREFGEN:
1914         case OP_DEFINED:
1915         case OP_HEX:
1916         case OP_OCT:
1917         case OP_LENGTH:
1918         case OP_VEC:
1919         case OP_INDEX:
1920         case OP_RINDEX:
1921         case OP_SPRINTF:
1922         case OP_KVASLICE:
1923         case OP_KVHSLICE:
1924         case OP_UNPACK:
1925         case OP_PACK:
1926         case OP_JOIN:
1927         case OP_LSLICE:
1928         case OP_ANONLIST:
1929         case OP_ANONHASH:
1930         case OP_SORT:
1931         case OP_REVERSE:
1932         case OP_RANGE:
1933         case OP_FLIP:
1934         case OP_FLOP:
1935         case OP_CALLER:
1936         case OP_FILENO:
1937         case OP_EOF:
1938         case OP_TELL:
1939         case OP_GETSOCKNAME:
1940         case OP_GETPEERNAME:
1941         case OP_READLINK:
1942         case OP_TELLDIR:
1943         case OP_GETPPID:
1944         case OP_GETPGRP:
1945         case OP_GETPRIORITY:
1946         case OP_TIME:
1947         case OP_TMS:
1948         case OP_LOCALTIME:
1949         case OP_GMTIME:
1950         case OP_GHBYNAME:
1951         case OP_GHBYADDR:
1952         case OP_GHOSTENT:
1953         case OP_GNBYNAME:
1954         case OP_GNBYADDR:
1955         case OP_GNETENT:
1956         case OP_GPBYNAME:
1957         case OP_GPBYNUMBER:
1958         case OP_GPROTOENT:
1959         case OP_GSBYNAME:
1960         case OP_GSBYPORT:
1961         case OP_GSERVENT:
1962         case OP_GPWNAM:
1963         case OP_GPWUID:
1964         case OP_GGRNAM:
1965         case OP_GGRGID:
1966         case OP_GETLOGIN:
1967         case OP_PROTOTYPE:
1968         case OP_RUNCV:
1969         func_ops:
1970             useless = OP_DESC(o);
1971             break;
1972
1973         case OP_GVSV:
1974         case OP_PADSV:
1975         case OP_PADAV:
1976         case OP_PADHV:
1977         case OP_PADANY:
1978         case OP_AELEM:
1979         case OP_AELEMFAST:
1980         case OP_AELEMFAST_LEX:
1981         case OP_ASLICE:
1982         case OP_HELEM:
1983         case OP_HSLICE:
1984             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1985                 /* Otherwise it's "Useless use of grep iterator" */
1986                 useless = OP_DESC(o);
1987             break;
1988
1989         case OP_SPLIT:
1990             kid = cLISTOPo->op_first;
1991             if (kid && kid->op_type == OP_PUSHRE
1992                 && !kid->op_targ
1993                 && !(o->op_flags & OPf_STACKED)
1994 #ifdef USE_ITHREADS
1995                 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
1996 #else
1997                 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
1998 #endif
1999                 )
2000                 useless = OP_DESC(o);
2001             break;
2002
2003         case OP_NOT:
2004             kid = cUNOPo->op_first;
2005             if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2006                 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2007                 goto func_ops;
2008             }
2009             useless = "negative pattern binding (!~)";
2010             break;
2011
2012         case OP_SUBST:
2013             if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2014                 useless = "non-destructive substitution (s///r)";
2015             break;
2016
2017         case OP_TRANSR:
2018             useless = "non-destructive transliteration (tr///r)";
2019             break;
2020
2021         case OP_RV2GV:
2022         case OP_RV2SV:
2023         case OP_RV2AV:
2024         case OP_RV2HV:
2025             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
2026                 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
2027                 useless = "a variable";
2028             break;
2029
2030         case OP_CONST:
2031             sv = cSVOPo_sv;
2032             if (cSVOPo->op_private & OPpCONST_STRICT)
2033                 no_bareword_allowed(o);
2034             else {
2035                 if (ckWARN(WARN_VOID)) {
2036                     NV nv;
2037                     /* don't warn on optimised away booleans, eg
2038                      * use constant Foo, 5; Foo || print; */
2039                     if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2040                         useless = NULL;
2041                     /* the constants 0 and 1 are permitted as they are
2042                        conventionally used as dummies in constructs like
2043                        1 while some_condition_with_side_effects;  */
2044                     else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2045                         useless = NULL;
2046                     else if (SvPOK(sv)) {
2047                         SV * const dsv = newSVpvs("");
2048                         useless_sv
2049                             = Perl_newSVpvf(aTHX_
2050                                             "a constant (%s)",
2051                                             pv_pretty(dsv, SvPVX_const(sv),
2052                                                       SvCUR(sv), 32, NULL, NULL,
2053                                                       PERL_PV_PRETTY_DUMP
2054                                                       | PERL_PV_ESCAPE_NOCLEAR
2055                                                       | PERL_PV_ESCAPE_UNI_DETECT));
2056                         SvREFCNT_dec_NN(dsv);
2057                     }
2058                     else if (SvOK(sv)) {
2059                         useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", SVfARG(sv));
2060                     }
2061                     else
2062                         useless = "a constant (undef)";
2063                 }
2064             }
2065             op_null(o);         /* don't execute or even remember it */
2066             break;
2067
2068         case OP_POSTINC:
2069             OpTYPE_set(o, OP_PREINC);  /* pre-increment is faster */
2070             break;
2071
2072         case OP_POSTDEC:
2073             OpTYPE_set(o, OP_PREDEC);  /* pre-decrement is faster */
2074             break;
2075
2076         case OP_I_POSTINC:
2077             OpTYPE_set(o, OP_I_PREINC);        /* pre-increment is faster */
2078             break;
2079
2080         case OP_I_POSTDEC:
2081             OpTYPE_set(o, OP_I_PREDEC);        /* pre-decrement is faster */
2082             break;
2083
2084         case OP_SASSIGN: {
2085             OP *rv2gv;
2086             UNOP *refgen, *rv2cv;
2087             LISTOP *exlist;
2088
2089             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2090                 break;
2091
2092             rv2gv = ((BINOP *)o)->op_last;
2093             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2094                 break;
2095
2096             refgen = (UNOP *)((BINOP *)o)->op_first;
2097
2098             if (!refgen || (refgen->op_type != OP_REFGEN
2099                             && refgen->op_type != OP_SREFGEN))
2100                 break;
2101
2102             exlist = (LISTOP *)refgen->op_first;
2103             if (!exlist || exlist->op_type != OP_NULL
2104                 || exlist->op_targ != OP_LIST)
2105                 break;
2106
2107             if (exlist->op_first->op_type != OP_PUSHMARK
2108                 && exlist->op_first != exlist->op_last)
2109                 break;
2110
2111             rv2cv = (UNOP*)exlist->op_last;
2112
2113             if (rv2cv->op_type != OP_RV2CV)
2114                 break;
2115
2116             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2117             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2118             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2119
2120             o->op_private |= OPpASSIGN_CV_TO_GV;
2121             rv2gv->op_private |= OPpDONT_INIT_GV;
2122             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2123
2124             break;
2125         }
2126
2127         case OP_AASSIGN: {
2128             inplace_aassign(o);
2129             break;
2130         }
2131
2132         case OP_OR:
2133         case OP_AND:
2134             kid = cLOGOPo->op_first;
2135             if (kid->op_type == OP_NOT
2136                 && (kid->op_flags & OPf_KIDS)) {
2137                 if (o->op_type == OP_AND) {
2138                     OpTYPE_set(o, OP_OR);
2139                 } else {
2140                     OpTYPE_set(o, OP_AND);
2141                 }
2142                 op_null(kid);
2143             }
2144             /* FALLTHROUGH */
2145
2146         case OP_DOR:
2147         case OP_COND_EXPR:
2148         case OP_ENTERGIVEN:
2149         case OP_ENTERWHEN:
2150             for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2151                 if (!(kid->op_flags & OPf_KIDS))
2152                     scalarvoid(kid);
2153                 else
2154                     DEFER_OP(kid);
2155         break;
2156
2157         case OP_NULL:
2158             if (o->op_flags & OPf_STACKED)
2159                 break;
2160             /* FALLTHROUGH */
2161         case OP_NEXTSTATE:
2162         case OP_DBSTATE:
2163         case OP_ENTERTRY:
2164         case OP_ENTER:
2165             if (!(o->op_flags & OPf_KIDS))
2166                 break;
2167             /* FALLTHROUGH */
2168         case OP_SCOPE:
2169         case OP_LEAVE:
2170         case OP_LEAVETRY:
2171         case OP_LEAVELOOP:
2172         case OP_LINESEQ:
2173         case OP_LEAVEGIVEN:
2174         case OP_LEAVEWHEN:
2175         kids:
2176             for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2177                 if (!(kid->op_flags & OPf_KIDS))
2178                     scalarvoid(kid);
2179                 else
2180                     DEFER_OP(kid);
2181             break;
2182         case OP_LIST:
2183             /* If the first kid after pushmark is something that the padrange
2184                optimisation would reject, then null the list and the pushmark.
2185             */
2186             if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2187                 && (  !(kid = OpSIBLING(kid))
2188                       || (  kid->op_type != OP_PADSV
2189                             && kid->op_type != OP_PADAV
2190                             && kid->op_type != OP_PADHV)
2191                       || kid->op_private & ~OPpLVAL_INTRO
2192                       || !(kid = OpSIBLING(kid))
2193                       || (  kid->op_type != OP_PADSV
2194                             && kid->op_type != OP_PADAV
2195                             && kid->op_type != OP_PADHV)
2196                       || kid->op_private & ~OPpLVAL_INTRO)
2197             ) {
2198                 op_null(cUNOPo->op_first); /* NULL the pushmark */
2199                 op_null(o); /* NULL the list */
2200             }
2201             goto kids;
2202         case OP_ENTEREVAL:
2203             scalarkids(o);
2204             break;
2205         case OP_SCALAR:
2206             scalar(o);
2207             break;
2208         }
2209
2210         if (useless_sv) {
2211             /* mortalise it, in case warnings are fatal.  */
2212             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2213                            "Useless use of %"SVf" in void context",
2214                            SVfARG(sv_2mortal(useless_sv)));
2215         }
2216         else if (useless) {
2217             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2218                            "Useless use of %s in void context",
2219                            useless);
2220         }
2221     } while ( (o = POP_DEFERRED_OP()) );
2222
2223     Safefree(defer_stack);
2224
2225     return arg;
2226 }
2227
2228 static OP *
2229 S_listkids(pTHX_ OP *o)
2230 {
2231     if (o && o->op_flags & OPf_KIDS) {
2232         OP *kid;
2233         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2234             list(kid);
2235     }
2236     return o;
2237 }
2238
2239 OP *
2240 Perl_list(pTHX_ OP *o)
2241 {
2242     OP *kid;
2243
2244     /* assumes no premature commitment */
2245     if (!o || (o->op_flags & OPf_WANT)
2246          || (PL_parser && PL_parser->error_count)
2247          || o->op_type == OP_RETURN)
2248     {
2249         return o;
2250     }
2251
2252     if ((o->op_private & OPpTARGET_MY)
2253         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2254     {
2255         return o;                               /* As if inside SASSIGN */
2256     }
2257
2258     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2259
2260     switch (o->op_type) {
2261     case OP_FLOP:
2262         list(cBINOPo->op_first);
2263         break;
2264     case OP_REPEAT:
2265         if (o->op_private & OPpREPEAT_DOLIST
2266          && !(o->op_flags & OPf_STACKED))
2267         {
2268             list(cBINOPo->op_first);
2269             kid = cBINOPo->op_last;
2270             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2271              && SvIVX(kSVOP_sv) == 1)
2272             {
2273                 op_null(o); /* repeat */
2274                 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2275                 /* const (rhs): */
2276                 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2277             }
2278         }
2279         break;
2280     case OP_OR:
2281     case OP_AND:
2282     case OP_COND_EXPR:
2283         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2284             list(kid);
2285         break;
2286     default:
2287     case OP_MATCH:
2288     case OP_QR:
2289     case OP_SUBST:
2290     case OP_NULL:
2291         if (!(o->op_flags & OPf_KIDS))
2292             break;
2293         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2294             list(cBINOPo->op_first);
2295             return gen_constant_list(o);
2296         }
2297         listkids(o);
2298         break;
2299     case OP_LIST:
2300         listkids(o);
2301         if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2302             op_null(cUNOPo->op_first); /* NULL the pushmark */
2303             op_null(o); /* NULL the list */
2304         }
2305         break;
2306     case OP_LEAVE:
2307     case OP_LEAVETRY:
2308         kid = cLISTOPo->op_first;
2309         list(kid);
2310         kid = OpSIBLING(kid);
2311     do_kids:
2312         while (kid) {
2313             OP *sib = OpSIBLING(kid);
2314             if (sib && kid->op_type != OP_LEAVEWHEN)
2315                 scalarvoid(kid);
2316             else
2317                 list(kid);
2318             kid = sib;
2319         }
2320         PL_curcop = &PL_compiling;
2321         break;
2322     case OP_SCOPE:
2323     case OP_LINESEQ:
2324         kid = cLISTOPo->op_first;
2325         goto do_kids;
2326     }
2327     return o;
2328 }
2329
2330 static OP *
2331 S_scalarseq(pTHX_ OP *o)
2332 {
2333     if (o) {
2334         const OPCODE type = o->op_type;
2335
2336         if (type == OP_LINESEQ || type == OP_SCOPE ||
2337             type == OP_LEAVE || type == OP_LEAVETRY)
2338         {
2339             OP *kid, *sib;
2340             for (kid = cLISTOPo->op_first; kid; kid = sib) {
2341                 if ((sib = OpSIBLING(kid))
2342                  && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2343                     || (  sib->op_targ != OP_NEXTSTATE
2344                        && sib->op_targ != OP_DBSTATE  )))
2345                 {
2346                     scalarvoid(kid);
2347                 }
2348             }
2349             PL_curcop = &PL_compiling;
2350         }
2351         o->op_flags &= ~OPf_PARENS;
2352         if (PL_hints & HINT_BLOCK_SCOPE)
2353             o->op_flags |= OPf_PARENS;
2354     }
2355     else
2356         o = newOP(OP_STUB, 0);
2357     return o;
2358 }
2359
2360 STATIC OP *
2361 S_modkids(pTHX_ OP *o, I32 type)
2362 {
2363     if (o && o->op_flags & OPf_KIDS) {
2364         OP *kid;
2365         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2366             op_lvalue(kid, type);
2367     }
2368     return o;
2369 }
2370
2371
2372 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2373  * const fields. Also, convert CONST keys to HEK-in-SVs.
2374  * rop is the op that retrieves the hash;
2375  * key_op is the first key
2376  */
2377
2378 STATIC void
2379 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op)
2380 {
2381     PADNAME *lexname;
2382     GV **fields;
2383     bool check_fields;
2384
2385     /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2386     if (rop) {
2387         if (rop->op_first->op_type == OP_PADSV)
2388             /* @$hash{qw(keys here)} */
2389             rop = (UNOP*)rop->op_first;
2390         else {
2391             /* @{$hash}{qw(keys here)} */
2392             if (rop->op_first->op_type == OP_SCOPE
2393                 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2394                 {
2395                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2396                 }
2397             else
2398                 rop = NULL;
2399         }
2400     }
2401
2402     lexname = NULL; /* just to silence compiler warnings */
2403     fields  = NULL; /* just to silence compiler warnings */
2404
2405     check_fields =
2406             rop
2407          && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2408              SvPAD_TYPED(lexname))
2409          && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2410          && isGV(*fields) && GvHV(*fields);
2411
2412     for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2413         SV **svp, *sv;
2414         if (key_op->op_type != OP_CONST)
2415             continue;
2416         svp = cSVOPx_svp(key_op);
2417
2418         /* make sure it's not a bareword under strict subs */
2419         if (key_op->op_private & OPpCONST_BARE &&
2420             key_op->op_private & OPpCONST_STRICT)
2421         {
2422             no_bareword_allowed((OP*)key_op);
2423         }
2424
2425         /* Make the CONST have a shared SV */
2426         if (   !SvIsCOW_shared_hash(sv = *svp)
2427             && SvTYPE(sv) < SVt_PVMG
2428             && SvOK(sv)
2429             && !SvROK(sv))
2430         {
2431             SSize_t keylen;
2432             const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2433             SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2434             SvREFCNT_dec_NN(sv);
2435             *svp = nsv;
2436         }
2437
2438         if (   check_fields
2439             && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2440         {
2441             Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
2442                         "in variable %"PNf" of type %"HEKf,
2443                         SVfARG(*svp), PNfARG(lexname),
2444                         HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2445         }
2446     }
2447 }
2448
2449
2450 /*
2451 =for apidoc finalize_optree
2452
2453 This function finalizes the optree.  Should be called directly after
2454 the complete optree is built.  It does some additional
2455 checking which can't be done in the normal C<ck_>xxx functions and makes
2456 the tree thread-safe.
2457
2458 =cut
2459 */
2460 void
2461 Perl_finalize_optree(pTHX_ OP* o)
2462 {
2463     PERL_ARGS_ASSERT_FINALIZE_OPTREE;
2464
2465     ENTER;
2466     SAVEVPTR(PL_curcop);
2467
2468     finalize_op(o);
2469
2470     LEAVE;
2471 }
2472
2473 #ifdef USE_ITHREADS
2474 /* Relocate sv to the pad for thread safety.
2475  * Despite being a "constant", the SV is written to,
2476  * for reference counts, sv_upgrade() etc. */
2477 PERL_STATIC_INLINE void
2478 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
2479 {
2480     PADOFFSET ix;
2481     PERL_ARGS_ASSERT_OP_RELOCATE_SV;
2482     if (!*svp) return;
2483     ix = pad_alloc(OP_CONST, SVf_READONLY);
2484     SvREFCNT_dec(PAD_SVl(ix));
2485     PAD_SETSV(ix, *svp);
2486     /* XXX I don't know how this isn't readonly already. */
2487     if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
2488     *svp = NULL;
2489     *targp = ix;
2490 }
2491 #endif
2492
2493
2494 STATIC void
2495 S_finalize_op(pTHX_ OP* o)
2496 {
2497     PERL_ARGS_ASSERT_FINALIZE_OP;
2498
2499
2500     switch (o->op_type) {
2501     case OP_NEXTSTATE:
2502     case OP_DBSTATE:
2503         PL_curcop = ((COP*)o);          /* for warnings */
2504         break;
2505     case OP_EXEC:
2506         if (OpHAS_SIBLING(o)) {
2507             OP *sib = OpSIBLING(o);
2508             if ((  sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
2509                 && ckWARN(WARN_EXEC)
2510                 && OpHAS_SIBLING(sib))
2511             {
2512                     const OPCODE type = OpSIBLING(sib)->op_type;
2513                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
2514                         const line_t oldline = CopLINE(PL_curcop);
2515                         CopLINE_set(PL_curcop, CopLINE((COP*)sib));
2516                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
2517                             "Statement unlikely to be reached");
2518                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
2519                             "\t(Maybe you meant system() when you said exec()?)\n");
2520                         CopLINE_set(PL_curcop, oldline);
2521                     }
2522             }
2523         }
2524         break;
2525
2526     case OP_GV:
2527         if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
2528             GV * const gv = cGVOPo_gv;
2529             if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
2530                 /* XXX could check prototype here instead of just carping */
2531                 SV * const sv = sv_newmortal();
2532                 gv_efullname3(sv, gv, NULL);
2533                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
2534                     "%"SVf"() called too early to check prototype",
2535                     SVfARG(sv));
2536             }
2537         }
2538         break;
2539
2540     case OP_CONST:
2541         if (cSVOPo->op_private & OPpCONST_STRICT)
2542             no_bareword_allowed(o);
2543         /* FALLTHROUGH */
2544 #ifdef USE_ITHREADS
2545     case OP_HINTSEVAL:
2546         op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
2547 #endif
2548         break;
2549
2550 #ifdef USE_ITHREADS
2551     /* Relocate all the METHOP's SVs to the pad for thread safety. */
2552     case OP_METHOD_NAMED:
2553     case OP_METHOD_SUPER:
2554     case OP_METHOD_REDIR:
2555     case OP_METHOD_REDIR_SUPER:
2556         op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
2557         break;
2558 #endif
2559
2560     case OP_HELEM: {
2561         UNOP *rop;
2562         SVOP *key_op;
2563         OP *kid;
2564
2565         if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
2566             break;
2567
2568         rop = (UNOP*)((BINOP*)o)->op_first;
2569
2570         goto check_keys;
2571
2572     case OP_HSLICE:
2573         S_scalar_slice_warning(aTHX_ o);
2574         /* FALLTHROUGH */
2575
2576     case OP_KVHSLICE:
2577         kid = OpSIBLING(cLISTOPo->op_first);
2578         if (/* I bet there's always a pushmark... */
2579             OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
2580             && OP_TYPE_ISNT_NN(kid, OP_CONST))
2581         {
2582             break;
2583         }
2584
2585         key_op = (SVOP*)(kid->op_type == OP_CONST
2586                                 ? kid
2587                                 : OpSIBLING(kLISTOP->op_first));
2588
2589         rop = (UNOP*)((LISTOP*)o)->op_last;
2590
2591       check_keys:
2592         if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
2593             rop = NULL;
2594         S_check_hash_fields_and_hekify(aTHX_ rop, key_op);
2595         break;
2596     }
2597     case OP_ASLICE:
2598         S_scalar_slice_warning(aTHX_ o);
2599         break;
2600
2601     case OP_SUBST: {
2602         if (cPMOPo->op_pmreplrootu.op_pmreplroot)
2603             finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
2604         break;
2605     }
2606     default:
2607         break;
2608     }
2609
2610     if (o->op_flags & OPf_KIDS) {
2611         OP *kid;
2612
2613 #ifdef DEBUGGING
2614         /* check that op_last points to the last sibling, and that
2615          * the last op_sibling/op_sibparent field points back to the
2616          * parent, and that the only ops with KIDS are those which are
2617          * entitled to them */
2618         U32 type = o->op_type;
2619         U32 family;
2620         bool has_last;
2621
2622         if (type == OP_NULL) {
2623             type = o->op_targ;
2624             /* ck_glob creates a null UNOP with ex-type GLOB
2625              * (which is a list op. So pretend it wasn't a listop */
2626             if (type == OP_GLOB)
2627                 type = OP_NULL;
2628         }
2629         family = PL_opargs[type] & OA_CLASS_MASK;
2630
2631         has_last = (   family == OA_BINOP
2632                     || family == OA_LISTOP
2633                     || family == OA_PMOP
2634                     || family == OA_LOOP
2635                    );
2636         assert(  has_last /* has op_first and op_last, or ...
2637               ... has (or may have) op_first: */
2638               || family == OA_UNOP
2639               || family == OA_UNOP_AUX
2640               || family == OA_LOGOP
2641               || family == OA_BASEOP_OR_UNOP
2642               || family == OA_FILESTATOP
2643               || family == OA_LOOPEXOP
2644               || family == OA_METHOP
2645               /* I don't know why SASSIGN is tagged as OA_BASEOP - DAPM */
2646               || type == OP_SASSIGN
2647               || type == OP_CUSTOM
2648               || type == OP_NULL /* new_logop does this */
2649               );
2650
2651         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2652 #  ifdef PERL_OP_PARENT
2653             if (!OpHAS_SIBLING(kid)) {
2654                 if (has_last)
2655                     assert(kid == cLISTOPo->op_last);
2656                 assert(kid->op_sibparent == o);
2657             }
2658 #  else
2659             if (has_last && !OpHAS_SIBLING(kid))
2660                 assert(kid == cLISTOPo->op_last);
2661 #  endif
2662         }
2663 #endif
2664
2665         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
2666             finalize_op(kid);
2667     }
2668 }
2669
2670 /*
2671 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
2672
2673 Propagate lvalue ("modifiable") context to an op and its children.
2674 C<type> represents the context type, roughly based on the type of op that
2675 would do the modifying, although C<local()> is represented by C<OP_NULL>,
2676 because it has no op type of its own (it is signalled by a flag on
2677 the lvalue op).
2678
2679 This function detects things that can't be modified, such as C<$x+1>, and
2680 generates errors for them.  For example, C<$x+1 = 2> would cause it to be
2681 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
2682
2683 It also flags things that need to behave specially in an lvalue context,
2684 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
2685
2686 =cut
2687 */
2688
2689 static void
2690 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
2691 {
2692     CV *cv = PL_compcv;
2693     PadnameLVALUE_on(pn);
2694     while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
2695         cv = CvOUTSIDE(cv);
2696         /* RT #127786: cv can be NULL due to an eval within the DB package
2697          * called from an anon sub - anon subs don't have CvOUTSIDE() set
2698          * unless they contain an eval, but calling eval within DB
2699          * pretends the eval was done in the caller's scope.
2700          */
2701         if (!cv)
2702             break;
2703         assert(CvPADLIST(cv));
2704         pn =
2705            PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
2706         assert(PadnameLEN(pn));
2707         PadnameLVALUE_on(pn);
2708     }
2709 }
2710
2711 static bool
2712 S_vivifies(const OPCODE type)
2713 {
2714     switch(type) {
2715     case OP_RV2AV:     case   OP_ASLICE:
2716     case OP_RV2HV:     case OP_KVASLICE:
2717     case OP_RV2SV:     case   OP_HSLICE:
2718     case OP_AELEMFAST: case OP_KVHSLICE:
2719     case OP_HELEM:
2720     case OP_AELEM:
2721         return 1;
2722     }
2723     return 0;
2724 }
2725
2726 static void
2727 S_lvref(pTHX_ OP *o, I32 type)
2728 {
2729     dVAR;
2730     OP *kid;
2731     switch (o->op_type) {
2732     case OP_COND_EXPR:
2733         for (kid = OpSIBLING(cUNOPo->op_first); kid;
2734              kid = OpSIBLING(kid))
2735             S_lvref(aTHX_ kid, type);
2736         /* FALLTHROUGH */
2737     case OP_PUSHMARK:
2738         return;
2739     case OP_RV2AV:
2740         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2741         o->op_flags |= OPf_STACKED;
2742         if (o->op_flags & OPf_PARENS) {
2743             if (o->op_private & OPpLVAL_INTRO) {
2744                  yyerror(Perl_form(aTHX_ "Can't modify reference to "
2745                       "localized parenthesized array in list assignment"));
2746                 return;
2747             }
2748           slurpy:
2749             OpTYPE_set(o, OP_LVAVREF);
2750             o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
2751             o->op_flags |= OPf_MOD|OPf_REF;
2752             return;
2753         }
2754         o->op_private |= OPpLVREF_AV;
2755         goto checkgv;
2756     case OP_RV2CV:
2757         kid = cUNOPo->op_first;
2758         if (kid->op_type == OP_NULL)
2759             kid = cUNOPx(OpSIBLING(kUNOP->op_first))
2760                 ->op_first;
2761         o->op_private = OPpLVREF_CV;
2762         if (kid->op_type == OP_GV)
2763             o->op_flags |= OPf_STACKED;
2764         else if (kid->op_type == OP_PADCV) {
2765             o->op_targ = kid->op_targ;
2766             kid->op_targ = 0;
2767             op_free(cUNOPo->op_first);
2768             cUNOPo->op_first = NULL;
2769             o->op_flags &=~ OPf_KIDS;
2770         }
2771         else goto badref;
2772         break;
2773     case OP_RV2HV:
2774         if (o->op_flags & OPf_PARENS) {
2775           parenhash:
2776             yyerror(Perl_form(aTHX_ "Can't modify reference to "
2777                                  "parenthesized hash in list assignment"));
2778                 return;
2779         }
2780         o->op_private |= OPpLVREF_HV;
2781         /* FALLTHROUGH */
2782     case OP_RV2SV:
2783       checkgv:
2784         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2785         o->op_flags |= OPf_STACKED;
2786         break;
2787     case OP_PADHV:
2788         if (o->op_flags & OPf_PARENS) goto parenhash;
2789         o->op_private |= OPpLVREF_HV;
2790         /* FALLTHROUGH */
2791     case OP_PADSV:
2792         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2793         break;
2794     case OP_PADAV:
2795         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2796         if (o->op_flags & OPf_PARENS) goto slurpy;
2797         o->op_private |= OPpLVREF_AV;
2798         break;
2799     case OP_AELEM:
2800     case OP_HELEM:
2801         o->op_private |= OPpLVREF_ELEM;
2802         o->op_flags   |= OPf_STACKED;
2803         break;
2804     case OP_ASLICE:
2805     case OP_HSLICE:
2806         OpTYPE_set(o, OP_LVREFSLICE);
2807         o->op_private &= OPpLVAL_INTRO;
2808         return;
2809     case OP_NULL:
2810         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
2811             goto badref;
2812         else if (!(o->op_flags & OPf_KIDS))
2813             return;
2814         if (o->op_targ != OP_LIST) {
2815             S_lvref(aTHX_ cBINOPo->op_first, type);
2816             return;
2817         }
2818         /* FALLTHROUGH */
2819     case OP_LIST:
2820         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
2821             assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
2822             S_lvref(aTHX_ kid, type);
2823         }
2824         return;
2825     case OP_STUB:
2826         if (o->op_flags & OPf_PARENS)
2827             return;
2828         /* FALLTHROUGH */
2829     default:
2830       badref:
2831         /* diag_listed_as: Can't modify reference to %s in %s assignment */
2832         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
2833                      o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
2834                       ? "do block"
2835                       : OP_DESC(o),
2836                      PL_op_desc[type]));
2837     }
2838     OpTYPE_set(o, OP_LVREF);
2839     o->op_private &=
2840         OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
2841     if (type == OP_ENTERLOOP)
2842         o->op_private |= OPpLVREF_ITER;
2843 }
2844
2845 PERL_STATIC_INLINE bool
2846 S_potential_mod_type(I32 type)
2847 {
2848     /* Types that only potentially result in modification.  */
2849     return type == OP_GREPSTART || type == OP_ENTERSUB
2850         || type == OP_REFGEN    || type == OP_LEAVESUBLV;
2851 }
2852
2853 OP *
2854 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
2855 {
2856     dVAR;
2857     OP *kid;
2858     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2859     int localize = -1;
2860
2861     if (!o || (PL_parser && PL_parser->error_count))
2862         return o;
2863
2864     if ((o->op_private & OPpTARGET_MY)
2865         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2866     {
2867         return o;
2868     }
2869
2870     assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2871
2872     if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2873
2874     switch (o->op_type) {
2875     case OP_UNDEF:
2876         PL_modcount++;
2877         return o;
2878     case OP_STUB:
2879         if ((o->op_flags & OPf_PARENS))
2880             break;
2881         goto nomod;
2882     case OP_ENTERSUB:
2883         if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
2884             !(o->op_flags & OPf_STACKED)) {
2885             OpTYPE_set(o, OP_RV2CV);            /* entersub => rv2cv */
2886             assert(cUNOPo->op_first->op_type == OP_NULL);
2887             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
2888             break;
2889         }
2890         else {                          /* lvalue subroutine call */
2891             o->op_private |= OPpLVAL_INTRO;
2892             PL_modcount = RETURN_UNLIMITED_NUMBER;
2893             if (S_potential_mod_type(type)) {
2894                 o->op_private |= OPpENTERSUB_INARGS;
2895                 break;
2896             }
2897             else {                      /* Compile-time error message: */
2898                 OP *kid = cUNOPo->op_first;
2899                 CV *cv;
2900                 GV *gv;
2901                 SV *namesv;
2902
2903                 if (kid->op_type != OP_PUSHMARK) {
2904                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2905                         Perl_croak(aTHX_
2906                                 "panic: unexpected lvalue entersub "
2907                                 "args: type/targ %ld:%"UVuf,
2908                                 (long)kid->op_type, (UV)kid->op_targ);
2909                     kid = kLISTOP->op_first;
2910                 }
2911                 while (OpHAS_SIBLING(kid))
2912                     kid = OpSIBLING(kid);
2913                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
2914                     break;      /* Postpone until runtime */
2915                 }
2916
2917                 kid = kUNOP->op_first;
2918                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2919                     kid = kUNOP->op_first;
2920                 if (kid->op_type == OP_NULL)
2921                     Perl_croak(aTHX_
2922                                "Unexpected constant lvalue entersub "
2923                                "entry via type/targ %ld:%"UVuf,
2924                                (long)kid->op_type, (UV)kid->op_targ);
2925                 if (kid->op_type != OP_GV) {
2926                     break;
2927                 }
2928
2929                 gv = kGVOP_gv;
2930                 cv = isGV(gv)
2931                     ? GvCV(gv)
2932                     : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
2933                         ? MUTABLE_CV(SvRV(gv))
2934                         : NULL;
2935                 if (!cv)
2936                     break;
2937                 if (CvLVALUE(cv))
2938                     break;
2939                 if (flags & OP_LVALUE_NO_CROAK)
2940                     return NULL;
2941
2942                 namesv = cv_name(cv, NULL, 0);
2943                 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
2944                                      "subroutine call of &%"SVf" in %s",
2945                                      SVfARG(namesv), PL_op_desc[type]),
2946                            SvUTF8(namesv));
2947                 return o;
2948             }
2949         }
2950         /* FALLTHROUGH */
2951     default:
2952       nomod:
2953         if (flags & OP_LVALUE_NO_CROAK) return NULL;
2954         /* grep, foreach, subcalls, refgen */
2955         if (S_potential_mod_type(type))
2956             break;
2957         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2958                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
2959                       ? "do block"
2960                       : OP_DESC(o)),
2961                      type ? PL_op_desc[type] : "local"));
2962         return o;
2963
2964     case OP_PREINC:
2965     case OP_PREDEC:
2966     case OP_POW:
2967     case OP_MULTIPLY:
2968     case OP_DIVIDE:
2969     case OP_MODULO:
2970     case OP_ADD:
2971     case OP_SUBTRACT:
2972     case OP_CONCAT:
2973     case OP_LEFT_SHIFT:
2974     case OP_RIGHT_SHIFT:
2975     case OP_BIT_AND:
2976     case OP_BIT_XOR:
2977     case OP_BIT_OR:
2978     case OP_I_MULTIPLY:
2979     case OP_I_DIVIDE:
2980     case OP_I_MODULO:
2981     case OP_I_ADD:
2982     case OP_I_SUBTRACT:
2983         if (!(o->op_flags & OPf_STACKED))
2984             goto nomod;
2985         PL_modcount++;
2986         break;
2987
2988     case OP_REPEAT:
2989         if (o->op_flags & OPf_STACKED) {
2990             PL_modcount++;
2991             break;
2992         }
2993         if (!(o->op_private & OPpREPEAT_DOLIST))
2994             goto nomod;
2995         else {
2996             const I32 mods = PL_modcount;
2997             modkids(cBINOPo->op_first, type);
2998             if (type != OP_AASSIGN)
2999                 goto nomod;
3000             kid = cBINOPo->op_last;
3001             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
3002                 const IV iv = SvIV(kSVOP_sv);
3003                 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
3004                     PL_modcount =
3005                         mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
3006             }
3007             else
3008                 PL_modcount = RETURN_UNLIMITED_NUMBER;
3009         }
3010         break;
3011
3012     case OP_COND_EXPR:
3013         localize = 1;
3014         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
3015             op_lvalue(kid, type);
3016         break;
3017
3018     case OP_RV2AV:
3019     case OP_RV2HV:
3020         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
3021            PL_modcount = RETURN_UNLIMITED_NUMBER;
3022             return o;           /* Treat \(@foo) like ordinary list. */
3023         }
3024         /* FALLTHROUGH */
3025     case OP_RV2GV:
3026         if (scalar_mod_type(o, type))
3027             goto nomod;
3028         ref(cUNOPo->op_first, o->op_type);
3029         /* FALLTHROUGH */
3030     case OP_ASLICE:
3031     case OP_HSLICE:
3032         localize = 1;
3033         /* FALLTHROUGH */
3034     case OP_AASSIGN:
3035         /* Do not apply the lvsub flag for rv2[ah]v in scalar context.  */
3036         if (type == OP_LEAVESUBLV && (
3037                 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
3038              || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
3039            ))
3040             o->op_private |= OPpMAYBE_LVSUB;
3041         /* FALLTHROUGH */
3042     case OP_NEXTSTATE:
3043     case OP_DBSTATE:
3044        PL_modcount = RETURN_UNLIMITED_NUMBER;
3045         break;
3046     case OP_KVHSLICE:
3047     case OP_KVASLICE:
3048     case OP_AKEYS:
3049         if (type == OP_LEAVESUBLV)
3050             o->op_private |= OPpMAYBE_LVSUB;
3051         goto nomod;
3052     case OP_AVHVSWITCH:
3053         if (type == OP_LEAVESUBLV
3054          && (o->op_private & 3) + OP_EACH == OP_KEYS)
3055             o->op_private |= OPpMAYBE_LVSUB;
3056         goto nomod;
3057     case OP_AV2ARYLEN:
3058         PL_hints |= HINT_BLOCK_SCOPE;
3059         if (type == OP_LEAVESUBLV)
3060             o->op_private |= OPpMAYBE_LVSUB;
3061         PL_modcount++;
3062         break;
3063     case OP_RV2SV:
3064         ref(cUNOPo->op_first, o->op_type);
3065         localize = 1;
3066         /* FALLTHROUGH */
3067     case OP_GV:
3068         PL_hints |= HINT_BLOCK_SCOPE;
3069         /* FALLTHROUGH */
3070     case OP_SASSIGN:
3071     case OP_ANDASSIGN:
3072     case OP_ORASSIGN:
3073     case OP_DORASSIGN:
3074         PL_modcount++;
3075         break;
3076
3077     case OP_AELEMFAST:
3078     case OP_AELEMFAST_LEX:
3079         localize = -1;
3080         PL_modcount++;
3081         break;
3082
3083     case OP_PADAV:
3084     case OP_PADHV:
3085        PL_modcount = RETURN_UNLIMITED_NUMBER;
3086         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
3087             return o;           /* Treat \(@foo) like ordinary list. */
3088         if (scalar_mod_type(o, type))
3089             goto nomod;
3090         if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
3091           && type == OP_LEAVESUBLV)
3092             o->op_private |= OPpMAYBE_LVSUB;
3093         /* FALLTHROUGH */
3094     case OP_PADSV:
3095         PL_modcount++;
3096         if (!type) /* local() */
3097             Perl_croak(aTHX_ "Can't localize lexical variable %"PNf,
3098                               PNfARG(PAD_COMPNAME(o->op_targ)));
3099         if (!(o->op_private & OPpLVAL_INTRO)
3100          || (  type != OP_SASSIGN && type != OP_AASSIGN
3101             && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ))  ))
3102             S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
3103         break;
3104
3105     case OP_PUSHMARK:
3106         localize = 0;
3107         break;
3108
3109     case OP_KEYS:
3110         if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
3111             goto nomod;
3112         goto lvalue_func;
3113     case OP_SUBSTR:
3114         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
3115             goto nomod;
3116         /* FALLTHROUGH */
3117     case OP_POS:
3118     case OP_VEC:
3119       lvalue_func:
3120         if (type == OP_LEAVESUBLV)
3121             o->op_private |= OPpMAYBE_LVSUB;
3122         if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
3123             /* substr and vec */
3124             /* If this op is in merely potential (non-fatal) modifiable
3125                context, then apply OP_ENTERSUB context to
3126                the kid op (to avoid croaking).  Other-
3127                wise pass this op’s own type so the correct op is mentioned
3128                in error messages.  */
3129             op_lvalue(OpSIBLING(cBINOPo->op_first),
3130                       S_potential_mod_type(type)
3131                         ? (I32)OP_ENTERSUB
3132                         : o->op_type);
3133         }
3134         break;
3135
3136     case OP_AELEM:
3137     case OP_HELEM:
3138         ref(cBINOPo->op_first, o->op_type);
3139         if (type == OP_ENTERSUB &&
3140              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
3141             o->op_private |= OPpLVAL_DEFER;
3142         if (type == OP_LEAVESUBLV)
3143             o->op_private |= OPpMAYBE_LVSUB;
3144         localize = 1;
3145         PL_modcount++;
3146         break;
3147
3148     case OP_LEAVE:
3149     case OP_LEAVELOOP:
3150         o->op_private |= OPpLVALUE;
3151         /* FALLTHROUGH */
3152     case OP_SCOPE:
3153     case OP_ENTER:
3154     case OP_LINESEQ:
3155         localize = 0;
3156         if (o->op_flags & OPf_KIDS)
3157             op_lvalue(cLISTOPo->op_last, type);
3158         break;
3159
3160     case OP_NULL:
3161         localize = 0;
3162         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
3163             goto nomod;
3164         else if (!(o->op_flags & OPf_KIDS))
3165             break;
3166         if (o->op_targ != OP_LIST) {
3167             op_lvalue(cBINOPo->op_first, type);
3168             break;
3169         }
3170         /* FALLTHROUGH */
3171     case OP_LIST:
3172         localize = 0;
3173         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3174             /* elements might be in void context because the list is
3175                in scalar context or because they are attribute sub calls */
3176             if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
3177                 op_lvalue(kid, type);
3178         break;
3179
3180     case OP_COREARGS:
3181         return o;
3182
3183     case OP_AND:
3184     case OP_OR:
3185         if (type == OP_LEAVESUBLV
3186          || !S_vivifies(cLOGOPo->op_first->op_type))
3187             op_lvalue(cLOGOPo->op_first, type);
3188         if (type == OP_LEAVESUBLV
3189          || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
3190             op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
3191         goto nomod;
3192
3193     case OP_SREFGEN:
3194         if (type == OP_NULL) { /* local */
3195           local_refgen:
3196             if (!FEATURE_MYREF_IS_ENABLED)
3197                 Perl_croak(aTHX_ "The experimental declared_refs "
3198                                  "feature is not enabled");
3199             Perl_ck_warner_d(aTHX_
3200                      packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
3201                     "Declaring references is experimental");
3202             op_lvalue(cUNOPo->op_first, OP_NULL);
3203             return o;
3204         }
3205         if (type != OP_AASSIGN && type != OP_SASSIGN
3206          && type != OP_ENTERLOOP)
3207             goto nomod;
3208         /* Don’t bother applying lvalue context to the ex-list.  */
3209         kid = cUNOPx(cUNOPo->op_first)->op_first;
3210         assert (!OpHAS_SIBLING(kid));
3211         goto kid_2lvref;
3212     case OP_REFGEN:
3213         if (type == OP_NULL) /* local */
3214             goto local_refgen;
3215         if (type != OP_AASSIGN) goto nomod;
3216         kid = cUNOPo->op_first;
3217       kid_2lvref:
3218         {
3219             const U8 ec = PL_parser ? PL_parser->error_count : 0;
3220             S_lvref(aTHX_ kid, type);
3221             if (!PL_parser || PL_parser->error_count == ec) {
3222                 if (!FEATURE_REFALIASING_IS_ENABLED)
3223                     Perl_croak(aTHX_
3224                        "Experimental aliasing via reference not enabled");
3225                 Perl_ck_warner_d(aTHX_
3226                                  packWARN(WARN_EXPERIMENTAL__REFALIASING),
3227                                 "Aliasing via reference is experimental");
3228             }
3229         }
3230         if (o->op_type == OP_REFGEN)
3231             op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
3232         op_null(o);
3233         return o;
3234
3235     case OP_SPLIT:
3236         kid = cLISTOPo->op_first;
3237         if (kid && kid->op_type == OP_PUSHRE &&
3238                 (  kid->op_targ
3239                 || o->op_flags & OPf_STACKED
3240 #ifdef USE_ITHREADS
3241                 || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
3242 #else
3243                 || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
3244 #endif
3245         )) {
3246             /* This is actually @array = split.  */
3247             PL_modcount = RETURN_UNLIMITED_NUMBER;
3248             break;
3249         }
3250         goto nomod;
3251
3252     case OP_SCALAR:
3253         op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
3254         goto nomod;
3255     }
3256
3257     /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
3258        their argument is a filehandle; thus \stat(".") should not set
3259        it. AMS 20011102 */
3260     if (type == OP_REFGEN &&
3261         PL_check[o->op_type] == Perl_ck_ftst)
3262         return o;
3263
3264     if (type != OP_LEAVESUBLV)
3265         o->op_flags |= OPf_MOD;
3266
3267     if (type == OP_AASSIGN || type == OP_SASSIGN)
3268         o->op_flags |= OPf_SPECIAL|OPf_REF;
3269     else if (!type) { /* local() */
3270         switch (localize) {
3271         case 1:
3272             o->op_private |= OPpLVAL_INTRO;
3273             o->op_flags &= ~OPf_SPECIAL;
3274             PL_hints |= HINT_BLOCK_SCOPE;
3275             break;
3276         case 0:
3277             break;
3278         case -1:
3279             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
3280                            "Useless localization of %s", OP_DESC(o));
3281         }
3282     }
3283     else if (type != OP_GREPSTART && type != OP_ENTERSUB
3284              && type != OP_LEAVESUBLV)
3285         o->op_flags |= OPf_REF;
3286     return o;
3287 }
3288
3289 STATIC bool
3290 S_scalar_mod_type(const OP *o, I32 type)
3291 {
3292     switch (type) {
3293     case OP_POS:
3294     case OP_SASSIGN:
3295         if (o && o->op_type == OP_RV2GV)
3296             return FALSE;
3297         /* FALLTHROUGH */
3298     case OP_PREINC:
3299     case OP_PREDEC:
3300     case OP_POSTINC:
3301     case OP_POSTDEC:
3302     case OP_I_PREINC:
3303     case OP_I_PREDEC:
3304     case OP_I_POSTINC:
3305     case OP_I_POSTDEC:
3306     case OP_POW:
3307     case OP_MULTIPLY:
3308     case OP_DIVIDE:
3309     case OP_MODULO:
3310     case OP_REPEAT:
3311     case OP_ADD:
3312     case OP_SUBTRACT:
3313     case OP_I_MULTIPLY:
3314     case OP_I_DIVIDE:
3315     case OP_I_MODULO:
3316     case OP_I_ADD:
3317     case OP_I_SUBTRACT:
3318     case OP_LEFT_SHIFT:
3319     case OP_RIGHT_SHIFT:
3320     case OP_BIT_AND:
3321     case OP_BIT_XOR:
3322     case OP_BIT_OR:
3323     case OP_NBIT_AND:
3324     case OP_NBIT_XOR:
3325     case OP_NBIT_OR:
3326     case OP_SBIT_AND:
3327     case OP_SBIT_XOR:
3328     case OP_SBIT_OR:
3329     case OP_CONCAT:
3330     case OP_SUBST:
3331     case OP_TRANS:
3332     case OP_TRANSR:
3333     case OP_READ:
3334     case OP_SYSREAD:
3335     case OP_RECV:
3336     case OP_ANDASSIGN:
3337     case OP_ORASSIGN:
3338     case OP_DORASSIGN:
3339     case OP_VEC:
3340     case OP_SUBSTR:
3341         return TRUE;
3342     default:
3343         return FALSE;
3344     }
3345 }
3346
3347 STATIC bool
3348 S_is_handle_constructor(const OP *o, I32 numargs)
3349 {
3350     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
3351
3352     switch (o->op_type) {
3353     case OP_PIPE_OP:
3354     case OP_SOCKPAIR:
3355         if (numargs == 2)
3356             return TRUE;
3357         /* FALLTHROUGH */
3358     case OP_SYSOPEN:
3359     case OP_OPEN:
3360     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
3361     case OP_SOCKET:
3362     case OP_OPEN_DIR:
3363     case OP_ACCEPT:
3364         if (numargs == 1)
3365             return TRUE;
3366         /* FALLTHROUGH */
3367     default:
3368         return FALSE;
3369     }
3370 }
3371
3372 static OP *
3373 S_refkids(pTHX_ OP *o, I32 type)
3374 {
3375     if (o && o->op_flags & OPf_KIDS) {
3376         OP *kid;
3377         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3378             ref(kid, type);
3379     }
3380     return o;
3381 }
3382
3383 OP *
3384 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
3385 {
3386     dVAR;
3387     OP *kid;
3388
3389     PERL_ARGS_ASSERT_DOREF;
3390
3391     if (PL_parser && PL_parser->error_count)
3392         return o;
3393
3394     switch (o->op_type) {
3395     case OP_ENTERSUB:
3396         if ((type == OP_EXISTS || type == OP_DEFINED) &&
3397             !(o->op_flags & OPf_STACKED)) {
3398             OpTYPE_set(o, OP_RV2CV);             /* entersub => rv2cv */
3399             assert(cUNOPo->op_first->op_type == OP_NULL);
3400             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
3401             o->op_flags |= OPf_SPECIAL;
3402         }
3403         else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
3404             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3405                               : type == OP_RV2HV ? OPpDEREF_HV
3406                               : OPpDEREF_SV);
3407             o->op_flags |= OPf_MOD;
3408         }
3409
3410         break;
3411
3412     case OP_COND_EXPR:
3413         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
3414             doref(kid, type, set_op_ref);
3415         break;
3416     case OP_RV2SV:
3417         if (type == OP_DEFINED)
3418             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
3419         doref(cUNOPo->op_first, o->op_type, set_op_ref);
3420         /* FALLTHROUGH */
3421     case OP_PADSV:
3422         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3423             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3424                               : type == OP_RV2HV ? OPpDEREF_HV
3425                               : OPpDEREF_SV);
3426             o->op_flags |= OPf_MOD;
3427         }
3428         break;
3429
3430     case OP_RV2AV:
3431     case OP_RV2HV:
3432         if (set_op_ref)
3433             o->op_flags |= OPf_REF;
3434         /* FALLTHROUGH */
3435     case OP_RV2GV:
3436         if (type == OP_DEFINED)
3437             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
3438         doref(cUNOPo->op_first, o->op_type, set_op_ref);
3439         break;
3440
3441     case OP_PADAV:
3442     case OP_PADHV:
3443         if (set_op_ref)
3444             o->op_flags |= OPf_REF;
3445         break;
3446
3447     case OP_SCALAR:
3448     case OP_NULL:
3449         if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
3450             break;
3451         doref(cBINOPo->op_first, type, set_op_ref);
3452         break;
3453     case OP_AELEM:
3454     case OP_HELEM:
3455         doref(cBINOPo->op_first, o->op_type, set_op_ref);
3456         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3457             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3458                               : type == OP_RV2HV ? OPpDEREF_HV
3459                               : OPpDEREF_SV);
3460             o->op_flags |= OPf_MOD;
3461         }
3462         break;
3463
3464     case OP_SCOPE:
3465     case OP_LEAVE:
3466         set_op_ref = FALSE;
3467         /* FALLTHROUGH */
3468     case OP_ENTER:
3469     case OP_LIST:
3470         if (!(o->op_flags & OPf_KIDS))
3471             break;
3472         doref(cLISTOPo->op_last, type, set_op_ref);
3473         break;
3474     default:
3475         break;
3476     }
3477     return scalar(o);
3478
3479 }
3480
3481 STATIC OP *
3482 S_dup_attrlist(pTHX_ OP *o)
3483 {
3484     OP *rop;
3485
3486     PERL_ARGS_ASSERT_DUP_ATTRLIST;
3487
3488     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
3489      * where the first kid is OP_PUSHMARK and the remaining ones
3490      * are OP_CONST.  We need to push the OP_CONST values.
3491      */
3492     if (o->op_type == OP_CONST)
3493         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
3494     else {
3495         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
3496         rop = NULL;
3497         for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
3498             if (o->op_type == OP_CONST)
3499                 rop = op_append_elem(OP_LIST, rop,
3500                                   newSVOP(OP_CONST, o->op_flags,
3501                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
3502         }
3503     }
3504     return rop;
3505 }
3506
3507 STATIC void
3508 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
3509 {
3510     PERL_ARGS_ASSERT_APPLY_ATTRS;
3511     {
3512         SV * const stashsv = newSVhek(HvNAME_HEK(stash));
3513
3514         /* fake up C<use attributes $pkg,$rv,@attrs> */
3515
3516 #define ATTRSMODULE "attributes"
3517 #define ATTRSMODULE_PM "attributes.pm"
3518
3519         Perl_load_module(
3520           aTHX_ PERL_LOADMOD_IMPORT_OPS,
3521           newSVpvs(ATTRSMODULE),
3522           NULL,
3523           op_prepend_elem(OP_LIST,
3524                           newSVOP(OP_CONST, 0, stashsv),
3525                           op_prepend_elem(OP_LIST,
3526                                           newSVOP(OP_CONST, 0,
3527                                                   newRV(target)),
3528                                           dup_attrlist(attrs))));
3529     }
3530 }
3531
3532 STATIC void
3533 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
3534 {
3535     OP *pack, *imop, *arg;
3536     SV *meth, *stashsv, **svp;
3537
3538     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
3539
3540     if (!attrs)
3541         return;
3542
3543     assert(target->op_type == OP_PADSV ||
3544            target->op_type == OP_PADHV ||
3545            target->op_type == OP_PADAV);
3546
3547     /* Ensure that attributes.pm is loaded. */
3548     /* Don't force the C<use> if we don't need it. */
3549     svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
3550     if (svp && *svp != &PL_sv_undef)
3551         NOOP;   /* already in %INC */
3552     else
3553         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
3554                                newSVpvs(ATTRSMODULE), NULL);
3555
3556     /* Need package name for method call. */
3557     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
3558
3559     /* Build up the real arg-list. */
3560     stashsv = newSVhek(HvNAME_HEK(stash));
3561
3562     arg = newOP(OP_PADSV, 0);
3563     arg->op_targ = target->op_targ;
3564     arg = op_prepend_elem(OP_LIST,
3565                        newSVOP(OP_CONST, 0, stashsv),
3566                        op_prepend_elem(OP_LIST,
3567                                     newUNOP(OP_REFGEN, 0,
3568                                             arg),
3569                                     dup_attrlist(attrs)));
3570
3571     /* Fake up a method call to import */
3572     meth = newSVpvs_share("import");
3573     imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
3574                    op_append_elem(OP_LIST,
3575                                op_prepend_elem(OP_LIST, pack, arg),
3576                                newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
3577
3578     /* Combine the ops. */
3579     *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
3580 }
3581
3582 /*
3583 =notfor apidoc apply_attrs_string
3584
3585 Attempts to apply a list of attributes specified by the C<attrstr> and
3586 C<len> arguments to the subroutine identified by the C<cv> argument which
3587 is expected to be associated with the package identified by the C<stashpv>
3588 argument (see L<attributes>).  It gets this wrong, though, in that it
3589 does not correctly identify the boundaries of the individual attribute
3590 specifications within C<attrstr>.  This is not really intended for the
3591 public API, but has to be listed here for systems such as AIX which
3592 need an explicit export list for symbols.  (It's called from XS code
3593 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
3594 to respect attribute syntax properly would be welcome.
3595
3596 =cut
3597 */
3598
3599 void
3600 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
3601                         const char *attrstr, STRLEN len)
3602 {
3603     OP *attrs = NULL;
3604
3605     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
3606
3607     if (!len) {
3608         len = strlen(attrstr);
3609     }
3610
3611     while (len) {
3612         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
3613         if (len) {
3614             const char * const sstr = attrstr;
3615             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
3616             attrs = op_append_elem(OP_LIST, attrs,
3617                                 newSVOP(OP_CONST, 0,
3618                                         newSVpvn(sstr, attrstr-sstr)));
3619         }
3620     }
3621
3622     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3623                      newSVpvs(ATTRSMODULE),
3624                      NULL, op_prepend_elem(OP_LIST,
3625                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
3626                                   op_prepend_elem(OP_LIST,
3627                                                newSVOP(OP_CONST, 0,
3628                                                        newRV(MUTABLE_SV(cv))),
3629                                                attrs)));
3630 }
3631
3632 STATIC void
3633 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
3634 {
3635     OP *new_proto = NULL;
3636     STRLEN pvlen;
3637     char *pv;
3638     OP *o;
3639
3640     PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
3641
3642     if (!*attrs)
3643         return;
3644
3645     o = *attrs;
3646     if (o->op_type == OP_CONST) {
3647         pv = SvPV(cSVOPo_sv, pvlen);
3648         if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3649             SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3650             SV ** const tmpo = cSVOPx_svp(o);
3651             SvREFCNT_dec(cSVOPo_sv);
3652             *tmpo = tmpsv;
3653             new_proto = o;
3654             *attrs = NULL;
3655         }
3656     } else if (o->op_type == OP_LIST) {
3657         OP * lasto;
3658         assert(o->op_flags & OPf_KIDS);
3659         lasto = cLISTOPo->op_first;
3660         assert(lasto->op_type == OP_PUSHMARK);
3661         for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
3662             if (o->op_type == OP_CONST) {
3663                 pv = SvPV(cSVOPo_sv, pvlen);
3664                 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3665                     SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3666                     SV ** const tmpo = cSVOPx_svp(o);
3667                     SvREFCNT_dec(cSVOPo_sv);
3668                     *tmpo = tmpsv;
3669                     if (new_proto && ckWARN(WARN_MISC)) {
3670                         STRLEN new_len;
3671                         const char * newp = SvPV(cSVOPo_sv, new_len);
3672                         Perl_warner(aTHX_ packWARN(WARN_MISC),
3673                             "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub",
3674                             UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
3675                         op_free(new_proto);
3676                     }
3677                     else if (new_proto)
3678                         op_free(new_proto);
3679                     new_proto = o;
3680                     /* excise new_proto from the list */
3681                     op_sibling_splice(*attrs, lasto, 1, NULL);
3682                     o = lasto;
3683                     continue;
3684                 }
3685             }
3686             lasto = o;
3687         }
3688         /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
3689            would get pulled in with no real need */
3690         if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
3691             op_free(*attrs);
3692             *attrs = NULL;
3693         }
3694     }
3695
3696     if (new_proto) {
3697         SV *svname;
3698         if (isGV(name)) {
3699             svname = sv_newmortal();
3700             gv_efullname3(svname, name, NULL);
3701         }
3702         else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
3703             svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
3704         else
3705             svname = (SV *)name;
3706         if (ckWARN(WARN_ILLEGALPROTO))
3707             (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
3708         if (*proto && ckWARN(WARN_PROTOTYPE)) {
3709             STRLEN old_len, new_len;
3710             const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
3711             const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
3712
3713             Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3714                 "Prototype '%"UTF8f"' overridden by attribute 'prototype(%"UTF8f")'"
3715                 " in %"SVf,
3716                 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
3717                 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
3718                 SVfARG(svname));
3719         }
3720         if (*proto)
3721             op_free(*proto);
3722         *proto = new_proto;
3723     }
3724 }
3725
3726 static void
3727 S_cant_declare(pTHX_ OP *o)
3728 {
3729     if (o->op_type == OP_NULL
3730      && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
3731         o = cUNOPo->op_first;
3732     yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
3733                              o->op_type == OP_NULL
3734                                && o->op_flags & OPf_SPECIAL
3735                                  ? "do block"
3736                                  : OP_DESC(o),
3737                              PL_parser->in_my == KEY_our   ? "our"   :
3738                              PL_parser->in_my == KEY_state ? "state" :
3739                                                              "my"));
3740 }
3741
3742 STATIC OP *
3743 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
3744 {
3745     I32 type;
3746     const bool stately = PL_parser && PL_parser->in_my == KEY_state;
3747
3748     PERL_ARGS_ASSERT_MY_KID;
3749
3750     if (!o || (PL_parser && PL_parser->error_count))
3751         return o;
3752
3753     type = o->op_type;
3754
3755     if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
3756         OP *kid;
3757         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3758             my_kid(kid, attrs, imopsp);
3759         return o;
3760     } else if (type == OP_UNDEF || type == OP_STUB) {
3761         return o;
3762     } else if (type == OP_RV2SV ||      /* "our" declaration */
3763                type == OP_RV2AV ||
3764                type == OP_RV2HV) {
3765         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
3766             S_cant_declare(aTHX_ o);
3767         } else if (attrs) {
3768             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
3769             assert(PL_parser);
3770             PL_parser->in_my = FALSE;
3771             PL_parser->in_my_stash = NULL;
3772             apply_attrs(GvSTASH(gv),
3773                         (type == OP_RV2SV ? GvSV(gv) :
3774                          type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
3775                          type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
3776                         attrs);
3777         }
3778         o->op_private |= OPpOUR_INTRO;
3779         return o;
3780     }
3781     else if (type == OP_REFGEN || type == OP_SREFGEN) {
3782         if (!FEATURE_MYREF_IS_ENABLED)
3783             Perl_croak(aTHX_ "The experimental declared_refs "
3784                              "feature is not enabled");
3785         Perl_ck_warner_d(aTHX_
3786              packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
3787             "Declaring references is experimental");
3788         /* Kid is a nulled OP_LIST, handled above.  */
3789         my_kid(cUNOPo->op_first, attrs, imopsp);
3790         return o;
3791     }
3792     else if (type != OP_PADSV &&
3793              type != OP_PADAV &&
3794              type != OP_PADHV &&
3795              type != OP_PUSHMARK)
3796     {
3797         S_cant_declare(aTHX_ o);
3798         return o;
3799     }
3800     else if (attrs && type != OP_PUSHMARK) {
3801         HV *stash;
3802
3803         assert(PL_parser);
3804         PL_parser->in_my = FALSE;
3805         PL_parser->in_my_stash = NULL;
3806
3807         /* check for C<my Dog $spot> when deciding package */
3808         stash = PAD_COMPNAME_TYPE(o->op_targ);
3809         if (!stash)
3810             stash = PL_curstash;
3811         apply_attrs_my(stash, o, attrs, imopsp);
3812     }
3813     o->op_flags |= OPf_MOD;
3814     o->op_private |= OPpLVAL_INTRO;
3815     if (stately)
3816         o->op_private |= OPpPAD_STATE;
3817     return o;
3818 }
3819
3820 OP *
3821 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
3822 {
3823     OP *rops;
3824     int maybe_scalar = 0;
3825
3826     PERL_ARGS_ASSERT_MY_ATTRS;
3827
3828 /* [perl #17376]: this appears to be premature, and results in code such as
3829    C< our(%x); > executing in list mode rather than void mode */
3830 #if 0
3831     if (o->op_flags & OPf_PARENS)
3832         list(o);
3833     else
3834         maybe_scalar = 1;
3835 #else
3836     maybe_scalar = 1;
3837 #endif
3838     if (attrs)
3839         SAVEFREEOP(attrs);
3840     rops = NULL;
3841     o = my_kid(o, attrs, &rops);
3842     if (rops) {
3843         if (maybe_scalar && o->op_type == OP_PADSV) {
3844             o = scalar(op_append_list(OP_LIST, rops, o));
3845             o->op_private |= OPpLVAL_INTRO;
3846         }
3847         else {
3848             /* The listop in rops might have a pushmark at the beginning,
3849                which will mess up list assignment. */
3850             LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
3851             if (rops->op_type == OP_LIST &&
3852                 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
3853             {
3854                 OP * const pushmark = lrops->op_first;
3855                 /* excise pushmark */
3856                 op_sibling_splice(rops, NULL, 1, NULL);
3857                 op_free(pushmark);
3858             }
3859             o = op_append_list(OP_LIST, o, rops);
3860         }
3861     }
3862     PL_parser->in_my = FALSE;
3863     PL_parser->in_my_stash = NULL;
3864     return o;
3865 }
3866
3867 OP *
3868 Perl_sawparens(pTHX_ OP *o)
3869 {
3870     PERL_UNUSED_CONTEXT;
3871     if (o)
3872         o->op_flags |= OPf_PARENS;
3873     return o;
3874 }
3875
3876 OP *
3877 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
3878 {
3879     OP *o;
3880     bool ismatchop = 0;
3881     const OPCODE ltype = left->op_type;
3882     const OPCODE rtype = right->op_type;
3883
3884     PERL_ARGS_ASSERT_BIND_MATCH;
3885
3886     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
3887           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
3888     {
3889       const char * const desc
3890           = PL_op_desc[(
3891                           rtype == OP_SUBST || rtype == OP_TRANS
3892                        || rtype == OP_TRANSR
3893                        )
3894                        ? (int)rtype : OP_MATCH];
3895       const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
3896       SV * const name =
3897         S_op_varname(aTHX_ left);
3898       if (name)
3899         Perl_warner(aTHX_ packWARN(WARN_MISC),
3900              "Applying %s to %"SVf" will act on scalar(%"SVf")",
3901              desc, SVfARG(name), SVfARG(name));
3902       else {
3903         const char * const sample = (isary
3904              ? "@array" : "%hash");
3905         Perl_warner(aTHX_ packWARN(WARN_MISC),
3906              "Applying %s to %s will act on scalar(%s)",
3907              desc, sample, sample);
3908       }
3909     }
3910
3911     if (rtype == OP_CONST &&
3912         cSVOPx(right)->op_private & OPpCONST_BARE &&
3913         cSVOPx(right)->op_private & OPpCONST_STRICT)
3914     {
3915         no_bareword_allowed(right);
3916     }
3917
3918     /* !~ doesn't make sense with /r, so error on it for now */
3919     if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
3920         type == OP_NOT)
3921         /* diag_listed_as: Using !~ with %s doesn't make sense */
3922         yyerror("Using !~ with s///r doesn't make sense");
3923     if (rtype == OP_TRANSR && type == OP_NOT)
3924         /* diag_listed_as: Using !~ with %s doesn't make sense */
3925         yyerror("Using !~ with tr///r doesn't make sense");
3926
3927     ismatchop = (rtype == OP_MATCH ||
3928                  rtype == OP_SUBST ||
3929                  rtype == OP_TRANS || rtype == OP_TRANSR)
3930              && !(right->op_flags & OPf_SPECIAL);
3931     if (ismatchop && right->op_private & OPpTARGET_MY) {
3932         right->op_targ = 0;
3933         right->op_private &= ~OPpTARGET_MY;
3934     }
3935     if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
3936         if (left->op_type == OP_PADSV
3937          && !(left->op_private & OPpLVAL_INTRO))
3938         {
3939             right->op_targ = left->op_targ;
3940             op_free(left);
3941             o = right;
3942         }
3943         else {
3944             right->op_flags |= OPf_STACKED;
3945             if (rtype != OP_MATCH && rtype != OP_TRANSR &&
3946             ! (rtype == OP_TRANS &&
3947                right->op_private & OPpTRANS_IDENTICAL) &&
3948             ! (rtype == OP_SUBST &&
3949                (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3950                 left = op_lvalue(left, rtype);
3951             if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
3952                 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
3953             else
3954                 o = op_prepend_elem(rtype, scalar(left), right);
3955         }
3956         if (type == OP_NOT)
3957             return newUNOP(OP_NOT, 0, scalar(o));
3958         return o;
3959     }
3960     else
3961         return bind_match(type, left,
3962                 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
3963 }
3964
3965 OP *
3966 Perl_invert(pTHX_ OP *o)
3967 {
3968     if (!o)
3969         return NULL;
3970     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
3971 }
3972
3973 /*
3974 =for apidoc Amx|OP *|op_scope|OP *o
3975
3976 Wraps up an op tree with some additional ops so that at runtime a dynamic
3977 scope will be created.  The original ops run in the new dynamic scope,
3978 and then, provided that they exit normally, the scope will be unwound.
3979 The additional ops used to create and unwind the dynamic scope will
3980 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
3981 instead if the ops are simple enough to not need the full dynamic scope
3982 structure.
3983
3984 =cut
3985 */
3986
3987 OP *
3988 Perl_op_scope(pTHX_ OP *o)
3989 {
3990     dVAR;
3991     if (o) {
3992         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
3993             o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
3994             OpTYPE_set(o, OP_LEAVE);
3995         }
3996         else if (o->op_type == OP_LINESEQ) {
3997             OP *kid;
3998             OpTYPE_set(o, OP_SCOPE);
3999             kid = ((LISTOP*)o)->op_first;
4000             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
4001                 op_null(kid);
4002
4003                 /* The following deals with things like 'do {1 for 1}' */
4004                 kid = OpSIBLING(kid);
4005                 if (kid &&
4006                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
4007                     op_null(kid);
4008             }
4009         }
4010         else
4011             o = newLISTOP(OP_SCOPE, 0, o, NULL);
4012     }
4013     return o;
4014 }
4015
4016 OP *
4017 Perl_op_unscope(pTHX_ OP *o)
4018 {
4019     if (o && o->op_type == OP_LINESEQ) {
4020         OP *kid = cLISTOPo->op_first;
4021         for(; kid; kid = OpSIBLING(kid))
4022             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
4023                 op_null(kid);
4024     }
4025     return o;
4026 }
4027
4028 /*
4029 =for apidoc Am|int|block_start|int full
4030
4031 Handles compile-time scope entry.
4032 Arranges for hints to be restored on block
4033 exit and also handles pad sequence numbers to make lexical variables scope
4034 right.  Returns a savestack index for use with C<block_end>.
4035
4036 =cut
4037 */
4038
4039 int
4040 Perl_block_start(pTHX_ int full)
4041 {
4042     const int retval = PL_savestack_ix;
4043
4044     PL_compiling.cop_seq = PL_cop_seqmax;
4045     COP_SEQMAX_INC;
4046     pad_block_start(full);
4047     SAVEHINTS();
4048     PL_hints &= ~HINT_BLOCK_SCOPE;
4049     SAVECOMPILEWARNINGS();
4050     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
4051     SAVEI32(PL_compiling.cop_seq);
4052     PL_compiling.cop_seq = 0;
4053
4054     CALL_BLOCK_HOOKS(bhk_start, full);
4055
4056     return retval;
4057 }
4058
4059 /*
4060 =for apidoc Am|OP *|block_end|I32 floor|OP *seq
4061
4062 Handles compile-time scope exit.  C<floor>
4063 is the savestack index returned by
4064 C<block_start>, and C<seq> is the body of the block.  Returns the block,
4065 possibly modified.
4066
4067 =cut
4068 */
4069
4070 OP*
4071 Perl_block_end(pTHX_ I32 floor, OP *seq)
4072 {
4073     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
4074     OP* retval = scalarseq(seq);
4075     OP *o;
4076
4077     /* XXX Is the null PL_parser check necessary here? */
4078     assert(PL_parser); /* Let’s find out under debugging builds.  */
4079     if (PL_parser && PL_parser->parsed_sub) {
4080         o = newSTATEOP(0, NULL, NULL);
4081         op_null(o);
4082         retval = op_append_elem(OP_LINESEQ, retval, o);
4083     }
4084
4085     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
4086
4087     LEAVE_SCOPE(floor);
4088     if (needblockscope)
4089         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
4090     o = pad_leavemy();
4091
4092     if (o) {
4093         /* pad_leavemy has created a sequence of introcv ops for all my
4094            subs declared in the block.  We have to replicate that list with
4095            clonecv ops, to deal with this situation:
4096
4097                sub {
4098                    my sub s1;
4099                    my sub s2;
4100                    sub s1 { state sub foo { \&s2 } }
4101                }->()
4102
4103            Originally, I was going to have introcv clone the CV and turn
4104            off the stale flag.  Since &s1 is declared before &s2, the
4105            introcv op for &s1 is executed (on sub entry) before the one for
4106            &s2.  But the &foo sub inside &s1 (which is cloned when &s1 is
4107            cloned, since it is a state sub) closes over &s2 and expects
4108            to see it in its outer CV’s pad.  If the introcv op clones &s1,
4109            then &s2 is still marked stale.  Since &s1 is not active, and
4110            &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
4111            ble will not stay shared’ warning.  Because it is the same stub
4112            that will be used when the introcv op for &s2 is executed, clos-
4113            ing over it is safe.  Hence, we have to turn off the stale flag
4114            on all lexical subs in the block before we clone any of them.
4115            Hence, having introcv clone the sub cannot work.  So we create a
4116            list of ops like this:
4117
4118                lineseq
4119                   |
4120                   +-- introcv
4121                   |
4122                   +-- introcv
4123                   |
4124                   +-- introcv
4125                   |
4126                   .
4127                   .
4128                   .
4129                   |
4130                   +-- clonecv
4131                   |
4132                   +-- clonecv
4133                   |
4134                   +-- clonecv
4135                   |
4136                   .
4137                   .
4138                   .
4139          */
4140         OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
4141         OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
4142         for (;; kid = OpSIBLING(kid)) {
4143             OP *newkid = newOP(OP_CLONECV, 0);
4144             newkid->op_targ = kid->op_targ;
4145             o = op_append_elem(OP_LINESEQ, o, newkid);
4146             if (kid == last) break;
4147         }
4148         retval = op_prepend_elem(OP_LINESEQ, o, retval);
4149     }
4150
4151     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
4152
4153     return retval;
4154 }
4155
4156 /*
4157 =head1 Compile-time scope hooks
4158
4159 =for apidoc Aox||blockhook_register
4160
4161 Register a set of hooks to be called when the Perl lexical scope changes
4162 at compile time.  See L<perlguts/"Compile-time scope hooks">.
4163
4164 =cut
4165 */
4166
4167 void
4168 Perl_blockhook_register(pTHX_ BHK *hk)
4169 {
4170     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
4171
4172     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
4173 }
4174
4175 void
4176 Perl_newPROG(pTHX_ OP *o)
4177 {
4178     PERL_ARGS_ASSERT_NEWPROG;
4179
4180     if (PL_in_eval) {
4181         PERL_CONTEXT *cx;
4182         I32 i;
4183         if (PL_eval_root)
4184                 return;
4185         PL_eval_root = newUNOP(OP_LEAVEEVAL,
4186                                ((PL_in_eval & EVAL_KEEPERR)
4187                                 ? OPf_SPECIAL : 0), o);
4188
4189         cx = CX_CUR();
4190         assert(CxTYPE(cx) == CXt_EVAL);
4191
4192         if ((cx->blk_gimme & G_WANT) == G_VOID)
4193             scalarvoid(PL_eval_root);
4194         else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
4195             list(PL_eval_root);
4196         else
4197             scalar(PL_eval_root);
4198
4199         PL_eval_start = op_linklist(PL_eval_root);
4200         PL_eval_root->op_private |= OPpREFCOUNTED;
4201         OpREFCNT_set(PL_eval_root, 1);
4202         PL_eval_root->op_next = 0;
4203         i = PL_savestack_ix;
4204         SAVEFREEOP(o);
4205         ENTER;
4206         CALL_PEEP(PL_eval_start);
4207         finalize_optree(PL_eval_root);
4208         S_prune_chain_head(&PL_eval_start);
4209         LEAVE;
4210         PL_savestack_ix = i;
4211     }
4212     else {
4213         if (o->op_type == OP_STUB) {
4214             /* This block is entered if nothing is compiled for the main
4215                program. This will be the case for an genuinely empty main
4216                program, or one which only has BEGIN blocks etc, so already
4217                run and freed.
4218
4219                Historically (5.000) the guard above was !o. However, commit
4220                f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
4221                c71fccf11fde0068, changed perly.y so that newPROG() is now
4222                called with the output of block_end(), which returns a new
4223                OP_STUB for the case of an empty optree. ByteLoader (and
4224                maybe other things) also take this path, because they set up
4225                PL_main_start and PL_main_root directly, without generating an
4226                optree.
4227
4228                If the parsing the main program aborts (due to parse errors,
4229                or due to BEGIN or similar calling exit), then newPROG()
4230                isn't even called, and hence this code path and its cleanups
4231                are skipped. This shouldn't make a make a difference:
4232                * a non-zero return from perl_parse is a failure, and
4233                  perl_destruct() should be called immediately.
4234                * however, if exit(0) is called during the parse, then
4235                  perl_parse() returns 0, and perl_run() is called. As
4236                  PL_main_start will be NULL, perl_run() will return
4237                  promptly, and the exit code will remain 0.
4238             */
4239
4240             PL_comppad_name = 0;
4241             PL_compcv = 0;
4242             S_op_destroy(aTHX_ o);
4243             return;
4244         }
4245         PL_main_root = op_scope(sawparens(scalarvoid(o)));
4246         PL_curcop = &PL_compiling;
4247         PL_main_start = LINKLIST(PL_main_root);
4248         PL_main_root->op_private |= OPpREFCOUNTED;
4249         OpREFCNT_set(PL_main_root, 1);
4250         PL_main_root->op_next = 0;
4251         CALL_PEEP(PL_main_start);
4252         finalize_optree(PL_main_root);
4253         S_prune_chain_head(&PL_main_start);
4254         cv_forget_slab(PL_compcv);
4255         PL_compcv = 0;
4256
4257         /* Register with debugger */
4258         if (PERLDB_INTER) {
4259             CV * const cv = get_cvs("DB::postponed", 0);
4260             if (cv) {
4261                 dSP;
4262                 PUSHMARK(SP);
4263                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
4264                 PUTBACK;
4265                 call_sv(MUTABLE_SV(cv), G_DISCARD);
4266             }
4267         }
4268     }
4269 }
4270
4271 OP *
4272 Perl_localize(pTHX_ OP *o, I32 lex)
4273 {
4274     PERL_ARGS_ASSERT_LOCALIZE;
4275
4276     if (o->op_flags & OPf_PARENS)
4277 /* [perl #17376]: this appears to be premature, and results in code such as
4278    C< our(%x); > executing in list mode rather than void mode */
4279 #if 0
4280         list(o);
4281 #else
4282         NOOP;
4283 #endif
4284     else {
4285         if ( PL_parser->bufptr > PL_parser->oldbufptr
4286             && PL_parser->bufptr[-1] == ','
4287             && ckWARN(WARN_PARENTHESIS))
4288         {
4289             char *s = PL_parser->bufptr;
4290             bool sigil = FALSE;
4291
4292             /* some heuristics to detect a potential error */
4293             while (*s && (strchr(", \t\n", *s)))
4294                 s++;
4295
4296             while (1) {
4297                 if (*s && (strchr("@$%", *s) || (!lex && *s == '*'))
4298                        && *++s
4299                        && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
4300                     s++;
4301                     sigil = TRUE;
4302                     while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
4303                         s++;
4304                     while (*s && (strchr(", \t\n", *s)))
4305                         s++;
4306                 }
4307                 else
4308                     break;
4309             }
4310             if (sigil && (*s == ';' || *s == '=')) {
4311                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
4312                                 "Parentheses missing around \"%s\" list",
4313                                 lex
4314                                     ? (PL_parser->in_my == KEY_our
4315                                         ? "our"
4316                                         : PL_parser->in_my == KEY_state
4317                                             ? "state"
4318                                             : "my")
4319                                     : "local");
4320             }
4321         }
4322     }
4323     if (lex)
4324         o = my(o);
4325     else
4326         o = op_lvalue(o, OP_NULL);              /* a bit kludgey */
4327     PL_parser->in_my = FALSE;
4328     PL_parser->in_my_stash = NULL;
4329     return o;
4330 }
4331
4332 OP *
4333 Perl_jmaybe(pTHX_ OP *o)
4334 {
4335     PERL_ARGS_ASSERT_JMAYBE;
4336
4337     if (o->op_type == OP_LIST) {
4338         OP * const o2
4339             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
4340         o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
4341     }
4342     return o;
4343 }
4344
4345 PERL_STATIC_INLINE OP *
4346 S_op_std_init(pTHX_ OP *o)
4347 {
4348     I32 type = o->op_type;
4349
4350     PERL_ARGS_ASSERT_OP_STD_INIT;
4351
4352     if (PL_opargs[type] & OA_RETSCALAR)
4353         scalar(o);
4354     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
4355         o->op_targ = pad_alloc(type, SVs_PADTMP);
4356
4357     return o;
4358 }
4359
4360 PERL_STATIC_INLINE OP *
4361 S_op_integerize(pTHX_ OP *o)
4362 {
4363     I32 type = o->op_type;
4364
4365     PERL_ARGS_ASSERT_OP_INTEGERIZE;
4366
4367     /* integerize op. */
4368     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
4369     {
4370         dVAR;
4371         o->op_ppaddr = PL_ppaddr[++(o->op_type)];
4372     }
4373
4374     if (type == OP_NEGATE)
4375         /* XXX might want a ck_negate() for this */
4376         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
4377
4378     return o;
4379 }
4380
4381 static OP *
4382 S_fold_constants(pTHX_ OP *o)
4383 {
4384     dVAR;
4385     OP * VOL curop;
4386     OP *newop;
4387     VOL I32 type = o->op_type;
4388     bool is_stringify;
4389     SV * VOL sv = NULL;
4390     int ret = 0;
4391     OP *old_next;
4392     SV * const oldwarnhook = PL_warnhook;
4393     SV * const olddiehook  = PL_diehook;
4394     COP not_compiling;
4395     U8 oldwarn = PL_dowarn;
4396     I32 old_cxix;
4397     dJMPENV;
4398
4399     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
4400
4401     if (!(PL_opargs[type] & OA_FOLDCONST))
4402         goto nope;
4403
4404     switch (type) {
4405     case OP_UCFIRST:
4406     case OP_LCFIRST:
4407     case OP_UC:
4408     case OP_LC:
4409     case OP_FC:
4410 #ifdef USE_LOCALE_CTYPE
4411         if (IN_LC_COMPILETIME(LC_CTYPE))
4412             goto nope;
4413 #endif
4414         break;
4415     case OP_SLT:
4416     case OP_SGT:
4417     case OP_SLE:
4418     case OP_SGE:
4419     case OP_SCMP:
4420 #ifdef USE_LOCALE_COLLATE
4421         if (IN_LC_COMPILETIME(LC_COLLATE))
4422             goto nope;
4423 #endif
4424         break;
4425     case OP_SPRINTF:
4426         /* XXX what about the numeric ops? */
4427 #ifdef USE_LOCALE_NUMERIC
4428         if (IN_LC_COMPILETIME(LC_NUMERIC))
4429             goto nope;
4430 #endif
4431         break;
4432     case OP_PACK:
4433         if (!OpHAS_SIBLING(cLISTOPo->op_first)
4434           || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
4435             goto nope;
4436         {
4437             SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
4438             if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
4439             {
4440                 const char *s = SvPVX_const(sv);
4441                 while (s < SvEND(sv)) {
4442                     if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
4443                     s++;
4444                 }
4445             }
4446         }
4447         break;
4448     case OP_REPEAT:
4449         if (o->op_private & OPpREPEAT_DOLIST) goto nope;
4450         break;
4451     case OP_SREFGEN:
4452         if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
4453          || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
4454             goto nope;
4455     }
4456
4457     if (PL_parser && PL_parser->error_count)
4458         goto nope;              /* Don't try to run w/ errors */
4459
4460     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4461         switch (curop->op_type) {
4462         case OP_CONST:
4463             if (   (curop->op_private & OPpCONST_BARE)
4464                 && (curop->op_private & OPpCONST_STRICT)) {
4465                 no_bareword_allowed(curop);
4466                 goto nope;
4467             }
4468             /* FALLTHROUGH */
4469         case OP_LIST:
4470         case OP_SCALAR:
4471         case OP_NULL:
4472         case OP_PUSHMARK:
4473             /* Foldable; move to next op in list */
4474             break;
4475
4476         default:
4477             /* No other op types are considered foldable */
4478             goto nope;
4479         }
4480     }
4481
4482     curop = LINKLIST(o);
4483     old_next = o->op_next;
4484     o->op_next = 0;
4485     PL_op = curop;
4486
4487     old_cxix = cxstack_ix;
4488     create_eval_scope(NULL, G_FAKINGEVAL);
4489
4490     /* Verify that we don't need to save it:  */
4491     assert(PL_curcop == &PL_compiling);
4492     StructCopy(&PL_compiling, &not_compiling, COP);
4493     PL_curcop = &not_compiling;
4494     /* The above ensures that we run with all the correct hints of the
4495        currently compiling COP, but that IN_PERL_RUNTIME is true. */
4496     assert(IN_PERL_RUNTIME);
4497     PL_warnhook = PERL_WARNHOOK_FATAL;
4498     PL_diehook  = NULL;
4499     JMPENV_PUSH(ret);
4500
4501     /* Effective $^W=1.  */
4502     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
4503         PL_dowarn |= G_WARN_ON;
4504
4505     switch (ret) {
4506     case 0:
4507         CALLRUNOPS(aTHX);
4508         sv = *(PL_stack_sp--);
4509         if (o->op_targ && sv == PAD_SV(o->op_targ)) {   /* grab pad temp? */
4510             pad_swipe(o->op_targ,  FALSE);
4511         }
4512         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
4513             SvREFCNT_inc_simple_void(sv);
4514             SvTEMP_off(sv);
4515         }
4516         else { assert(SvIMMORTAL(sv)); }
4517         break;
4518     case 3:
4519         /* Something tried to die.  Abandon constant folding.  */
4520         /* Pretend the error never happened.  */
4521         CLEAR_ERRSV();
4522         o->op_next = old_next;
4523         break;
4524     default:
4525         JMPENV_POP;
4526         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
4527         PL_warnhook = oldwarnhook;
4528         PL_diehook  = olddiehook;
4529         /* XXX note that this croak may fail as we've already blown away
4530          * the stack - eg any nested evals */
4531         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
4532     }
4533     JMPENV_POP;
4534     PL_dowarn   = oldwarn;
4535     PL_warnhook = oldwarnhook;
4536     PL_diehook  = olddiehook;
4537     PL_curcop = &PL_compiling;
4538
4539     /* if we croaked, depending on how we croaked the eval scope
4540      * may or may not have already been popped */
4541     if (cxstack_ix > old_cxix) {
4542         assert(cxstack_ix == old_cxix + 1);
4543         assert(CxTYPE(CX_CUR()) == CXt_EVAL);
4544         delete_eval_scope();
4545     }
4546     if (ret)
4547         goto nope;
4548
4549     /* OP_STRINGIFY and constant folding are used to implement qq.
4550        Here the constant folding is an implementation detail that we
4551        want to hide.  If the stringify op is itself already marked
4552        folded, however, then it is actually a folded join.  */
4553     is_stringify = type == OP_STRINGIFY && !o->op_folded;
4554     op_free(o);
4555     assert(sv);
4556     if (is_stringify)
4557         SvPADTMP_off(sv);
4558     else if (!SvIMMORTAL(sv)) {
4559         SvPADTMP_on(sv);
4560         SvREADONLY_on(sv);
4561     }
4562     newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
4563     if (!is_stringify) newop->op_folded = 1;
4564     return newop;
4565
4566  nope:
4567     return o;
4568 }
4569
4570 static OP *
4571 S_gen_constant_list(pTHX_ OP *o)
4572 {
4573     dVAR;
4574     OP *curop;
4575     const SSize_t oldtmps_floor = PL_tmps_floor;
4576     SV **svp;
4577     AV *av;
4578
4579     list(o);
4580     if (PL_parser && PL_parser->error_count)
4581         return o;               /* Don't attempt to run with errors */
4582
4583     curop = LINKLIST(o);
4584     o->op_next = 0;
4585     CALL_PEEP(curop);
4586     S_prune_chain_head(&curop);
4587     PL_op = curop;
4588     Perl_pp_pushmark(aTHX);
4589     CALLRUNOPS(aTHX);
4590     PL_op = curop;
4591     assert (!(curop->op_flags & OPf_SPECIAL));
4592     assert(curop->op_type == OP_RANGE);
4593     Perl_pp_anonlist(aTHX);
4594     PL_tmps_floor = oldtmps_floor;
4595
4596     OpTYPE_set(o, OP_RV2AV);
4597     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
4598     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
4599     o->op_opt = 0;              /* needs to be revisited in rpeep() */
4600     av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
4601
4602     /* replace subtree with an OP_CONST */
4603     curop = ((UNOP*)o)->op_first;
4604     op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
4605     op_free(curop);
4606
4607     if (AvFILLp(av) != -1)
4608         for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
4609         {
4610             SvPADTMP_on(*svp);
4611             SvREADONLY_on(*svp);
4612         }
4613     LINKLIST(o);
4614     return list(o);
4615 }
4616
4617 /*
4618 =head1 Optree Manipulation Functions
4619 */
4620
4621 /* List constructors */
4622
4623 /*
4624 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
4625
4626 Append an item to the list of ops contained directly within a list-type
4627 op, returning the lengthened list.  C<first> is the list-type op,
4628 and C<last> is the op to append to the list.  C<optype> specifies the
4629 intended opcode for the list.  If C<first> is not already a list of the
4630 right type, it will be upgraded into one.  If either C<first> or C<last>
4631 is null, the other is returned unchanged.
4632
4633 =cut
4634 */
4635
4636 OP *
4637 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
4638 {
4639     if (!first)
4640         return last;
4641
4642     if (!last)
4643         return first;
4644
4645     if (first->op_type != (unsigned)type
4646         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
4647     {
4648         return newLISTOP(type, 0, first, last);
4649     }
4650
4651     op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
4652     first->op_flags |= OPf_KIDS;
4653     return first;
4654 }
4655
4656 /*
4657 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
4658
4659 Concatenate the lists of ops contained directly within two list-type ops,
4660 returning the combined list.  C<first> and C<last> are the list-type ops
4661 to concatenate.  C<optype> specifies the intended opcode for the list.
4662 If either C<first> or C<last> is not already a list of the right type,
4663 it will be upgraded into one.  If either C<first> or C<last> is null,
4664 the other is returned unchanged.
4665
4666 =cut
4667 */
4668
4669 OP *
4670 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
4671 {
4672     if (!first)
4673         return last;
4674
4675     if (!last)
4676         return first;
4677
4678     if (first->op_type != (unsigned)type)
4679         return op_prepend_elem(type, first, last);
4680
4681     if (last->op_type != (unsigned)type)
4682         return op_append_elem(type, first, last);
4683
4684     OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
4685     ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
4686     OpLASTSIB_set(((LISTOP*)first)->op_last, first);
4687     first->op_flags |= (last->op_flags & OPf_KIDS);
4688
4689     S_op_destroy(aTHX_ last);
4690
4691     return first;
4692 }
4693
4694 /*
4695 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
4696
4697 Prepend an item to the list of ops contained directly within a list-type
4698 op, returning the lengthened list.  C<first> is the op to prepend to the
4699 list, and C<last> is the list-type op.  C<optype> specifies the intended
4700 opcode for the list.  If C<last> is not already a list of the right type,
4701 it will be upgraded into one.  If either C<first> or C<last> is null,
4702 the other is returned unchanged.
4703
4704 =cut
4705 */
4706
4707 OP *
4708 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
4709 {
4710     if (!first)
4711         return last;
4712
4713     if (!last)
4714         return first;
4715
4716     if (last->op_type == (unsigned)type) {
4717         if (type == OP_LIST) {  /* already a PUSHMARK there */
4718             /* insert 'first' after pushmark */
4719             op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
4720             if (!(first->op_flags & OPf_PARENS))
4721                 last->op_flags &= ~OPf_PARENS;
4722         }
4723         else
4724             op_sibling_splice(last, NULL, 0, first);
4725         last->op_flags |= OPf_KIDS;
4726         return last;
4727     }
4728
4729     return newLISTOP(type, 0, first, last);
4730 }
4731
4732 /*
4733 =for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
4734
4735 Converts C<o> into a list op if it is not one already, and then converts it
4736 into the specified C<type>, calling its check function, allocating a target if
4737 it needs one, and folding constants.
4738
4739 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
4740 C<op_prepend_elem> and C<op_append_elem>.  Then finally it is passed to
4741 C<op_convert_list> to make it the right type.
4742
4743 =cut
4744 */
4745
4746 OP *
4747 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
4748 {
4749     dVAR;
4750     if (type < 0) type = -type, flags |= OPf_SPECIAL;
4751     if (!o || o->op_type != OP_LIST)
4752         o = force_list(o, 0);
4753     else
4754     {
4755         o->op_flags &= ~OPf_WANT;
4756         o->op_private &= ~OPpLVAL_INTRO;
4757     }
4758
4759     if (!(PL_opargs[type] & OA_MARK))
4760         op_null(cLISTOPo->op_first);
4761     else {
4762         OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
4763         if (kid2 && kid2->op_type == OP_COREARGS) {
4764             op_null(cLISTOPo->op_first);
4765             kid2->op_private |= OPpCOREARGS_PUSHMARK;
4766         }
4767     }
4768
4769     OpTYPE_set(o, type);
4770     o->op_flags |= flags;
4771     if (flags & OPf_FOLDED)
4772         o->op_folded = 1;
4773
4774     o = CHECKOP(type, o);
4775     if (o->op_type != (unsigned)type)
4776         return o;
4777
4778     return fold_constants(op_integerize(op_std_init(o)));
4779 }
4780
4781 /* Constructors */
4782
4783
4784 /*
4785 =head1 Optree construction
4786
4787 =for apidoc Am|OP *|newNULLLIST
4788
4789 Constructs, checks, and returns a new C<stub> op, which represents an
4790 empty list expression.
4791
4792 =cut
4793 */
4794
4795 OP *
4796 Perl_newNULLLIST(pTHX)
4797 {
4798     return newOP(OP_STUB, 0);
4799 }
4800
4801 /* promote o and any siblings to be a list if its not already; i.e.
4802  *
4803  *  o - A - B
4804  *
4805  * becomes
4806  *
4807  *  list
4808  *    |
4809  *  pushmark - o - A - B
4810  *
4811  * If nullit it true, the list op is nulled.
4812  */
4813
4814 static OP *
4815 S_force_list(pTHX_ OP *o, bool nullit)
4816 {
4817     if (!o || o->op_type != OP_LIST) {
4818         OP *rest = NULL;
4819         if (o) {
4820             /* manually detach any siblings then add them back later */
4821             rest = OpSIBLING(o);
4822             OpLASTSIB_set(o, NULL);
4823         }
4824         o = newLISTOP(OP_LIST, 0, o, NULL);
4825         if (rest)
4826             op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
4827     }
4828     if (nullit)
4829         op_null(o);
4830     return o;
4831 }
4832
4833 /*
4834 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
4835
4836 Constructs, checks, and returns an op of any list type.  C<type> is
4837 the opcode.  C<flags> gives the eight bits of C<op_flags>, except that
4838 C<OPf_KIDS> will be set automatically if required.  C<first> and C<last>
4839 supply up to two ops to be direct children of the list op; they are
4840 consumed by this function and become part of the constructed op tree.
4841
4842 For most list operators, the check function expects all the kid ops to be
4843 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
4844 appropriate.  What you want to do in that case is create an op of type
4845 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
4846 See L</op_convert_list> for more information.
4847
4848
4849 =cut
4850 */
4851
4852 OP *
4853 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4854 {
4855     dVAR;
4856     LISTOP *listop;
4857
4858     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
4859         || type == OP_CUSTOM);
4860
4861     NewOp(1101, listop, 1, LISTOP);
4862
4863     OpTYPE_set(listop, type);
4864     if (first || last)
4865         flags |= OPf_KIDS;
4866     listop->op_flags = (U8)flags;
4867
4868     if (!last && first)
4869         last = first;
4870     else if (!first && last)
4871         first = last;
4872     else if (first)
4873         OpMORESIB_set(first, last);
4874     listop->op_first = first;
4875     listop->op_last = last;
4876     if (type == OP_LIST) {
4877         OP* const pushop = newOP(OP_PUSHMARK, 0);
4878         OpMORESIB_set(pushop, first);
4879         listop->op_first = pushop;
4880         listop->op_flags |= OPf_KIDS;
4881         if (!last)
4882             listop->op_last = pushop;
4883     }
4884     if (listop->op_last)
4885         OpLASTSIB_set(listop->op_last, (OP*)listop);
4886
4887     return CHECKOP(type, listop);
4888 }
4889
4890 /*
4891 =for apidoc Am|OP *|newOP|I32 type|I32 flags
4892
4893 Constructs, checks, and returns an op of any base type (any type that
4894 has no extra fields).  C<type> is the opcode.  C<flags> gives the
4895 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
4896 of C<op_private>.
4897
4898 =cut
4899 */
4900
4901 OP *
4902 Perl_newOP(pTHX_ I32 type, I32 flags)
4903 {
4904     dVAR;
4905     OP *o;
4906
4907     if (type == -OP_ENTEREVAL) {
4908         type = OP_ENTEREVAL;
4909         flags |= OPpEVAL_BYTES<<8;
4910     }
4911
4912     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
4913         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4914         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4915         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4916
4917     NewOp(1101, o, 1, OP);
4918     OpTYPE_set(o, type);
4919     o->op_flags = (U8)flags;
4920
4921     o->op_next = o;
4922     o->op_private = (U8)(0 | (flags >> 8));
4923     if (PL_opargs[type] & OA_RETSCALAR)
4924         scalar(o);
4925     if (PL_opargs[type] & OA_TARGET)
4926         o->op_targ = pad_alloc(type, SVs_PADTMP);
4927     return CHECKOP(type, o);
4928 }
4929
4930 /*
4931 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
4932
4933 Constructs, checks, and returns an op of any unary type.  C<type> is
4934 the opcode.  C<flags> gives the eight bits of C<op_flags>, except that
4935 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
4936 bits, the eight bits of C<op_private>, except that the bit with value 1
4937 is automatically set.  C<first> supplies an optional op to be the direct
4938 child of the unary op; it is consumed by this function and become part
4939 of the constructed op tree.
4940
4941 =cut
4942 */
4943
4944 OP *
4945 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
4946 {
4947     dVAR;
4948     UNOP *unop;
4949
4950     if (type == -OP_ENTEREVAL) {
4951         type = OP_ENTEREVAL;
4952         flags |= OPpEVAL_BYTES<<8;
4953     }
4954
4955     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
4956         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4957         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4958         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
4959         || type == OP_SASSIGN
4960         || type == OP_ENTERTRY
4961         || type == OP_CUSTOM
4962         || type == OP_NULL );
4963
4964     if (!first)
4965         first = newOP(OP_STUB, 0);
4966     if (PL_opargs[type] & OA_MARK)
4967         first = force_list(first, 1);
4968
4969     NewOp(1101, unop, 1, UNOP);
4970     OpTYPE_set(unop, type);
4971     unop->op_first = first;
4972     unop->op_flags = (U8)(flags | OPf_KIDS);
4973     unop->op_private = (U8)(1 | (flags >> 8));
4974
4975     if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
4976         OpLASTSIB_set(first, (OP*)unop);
4977
4978     unop = (UNOP*) CHECKOP(type, unop);
4979     if (unop->op_next)
4980         return (OP*)unop;
4981
4982     return fold_constants(op_integerize(op_std_init((OP *) unop)));
4983 }
4984
4985 /*
4986 =for apidoc newUNOP_AUX
4987
4988 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
4989 initialised to C<aux>
4990
4991 =cut
4992 */
4993
4994 OP *
4995 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
4996 {
4997     dVAR;
4998     UNOP_AUX *unop;
4999
5000     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
5001         || type == OP_CUSTOM);
5002
5003     NewOp(1101, unop, 1, UNOP_AUX);
5004     unop->op_type = (OPCODE)type;
5005     unop->op_ppaddr = PL_ppaddr[type];
5006     unop->op_first = first;
5007     unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
5008     unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
5009     unop->op_aux = aux;
5010
5011     if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
5012         OpLASTSIB_set(first, (OP*)unop);
5013
5014     unop = (UNOP_AUX*) CHECKOP(type, unop);
5015
5016     return op_std_init((OP *) unop);
5017 }
5018
5019 /*
5020 =for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
5021
5022 Constructs, checks, and returns an op of method type with a method name
5023 evaluated at runtime.  C<type> is the opcode.  C<flags> gives the eight
5024 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
5025 and, shifted up eight bits, the eight bits of C<op_private>, except that
5026 the bit with value 1 is automatically set.  C<dynamic_meth> supplies an
5027 op which evaluates method name; it is consumed by this function and
5028 become part of the constructed op tree.
5029 Supported optypes: C<OP_METHOD>.
5030
5031 =cut
5032 */
5033
5034 static OP*
5035 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
5036     dVAR;
5037     METHOP *methop;
5038
5039     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
5040         || type == OP_CUSTOM);
5041
5042     NewOp(1101, methop, 1, METHOP);
5043     if (dynamic_meth) {
5044         if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
5045         methop->op_flags = (U8)(flags | OPf_KIDS);
5046         methop->op_u.op_first = dynamic_meth;
5047         methop->op_private = (U8)(1 | (flags >> 8));
5048
5049         if (!OpHAS_SIBLING(dynamic_meth))
5050             OpLASTSIB_set(dynamic_meth, (OP*)methop);
5051     }
5052     else {
5053         assert(const_meth);
5054         methop->op_flags = (U8)(flags & ~OPf_KIDS);
5055         methop->op_u.op_meth_sv = const_meth;
5056         methop->op_private = (U8)(0 | (flags >> 8));
5057         methop->op_next = (OP*)methop;
5058     }
5059
5060 #ifdef USE_ITHREADS
5061     methop->op_rclass_targ = 0;
5062 #else
5063     methop->op_rclass_sv = NULL;
5064 #endif
5065
5066     OpTYPE_set(methop, type);
5067     return CHECKOP(type, methop);
5068 }
5069
5070 OP *
5071 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
5072     PERL_ARGS_ASSERT_NEWMETHOP;
5073     return newMETHOP_internal(type, flags, dynamic_meth, NULL);
5074 }
5075
5076 /*
5077 =for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
5078
5079 Constructs, checks, and returns an op of method type with a constant
5080 method name.  C<type> is the opcode.  C<flags> gives the eight bits of
5081 C<op_flags>, and, shifted up eight bits, the eight bits of
5082 C<op_private>.  C<const_meth> supplies a constant method name;
5083 it must be a shared COW string.
5084 Supported optypes: C<OP_METHOD_NAMED>.
5085
5086 =cut
5087 */
5088
5089 OP *
5090 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
5091     PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
5092     return newMETHOP_internal(type, flags, NULL, const_meth);
5093 }
5094
5095 /*
5096 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
5097
5098 Constructs, checks, and returns an op of any binary type.  C<type>
5099 is the opcode.  C<flags> gives the eight bits of C<op_flags>, except
5100 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
5101 the eight bits of C<op_private>, except that the bit with value 1 or
5102 2 is automatically set as required.  C<first> and C<last> supply up to
5103 two ops to be the direct children of the binary op; they are consumed
5104 by this function and become part of the constructed op tree.
5105
5106 =cut
5107 */
5108
5109 OP *
5110 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
5111 {
5112     dVAR;
5113     BINOP *binop;
5114
5115     ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
5116         || type == OP_SASSIGN || type == OP_NULL || type == OP_CUSTOM);
5117
5118     NewOp(1101, binop, 1, BINOP);
5119
5120     if (!first)
5121         first = newOP(OP_NULL, 0);
5122
5123     OpTYPE_set(binop, type);
5124     binop->op_first = first;
5125     binop->op_flags = (U8)(flags | OPf_KIDS);
5126     if (!last) {
5127         last = first;
5128         binop->op_private = (U8)(1 | (flags >> 8));
5129     }
5130     else {
5131         binop->op_private = (U8)(2 | (flags >> 8));
5132         OpMORESIB_set(first, last);
5133     }
5134
5135     if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
5136         OpLASTSIB_set(last, (OP*)binop);
5137
5138     binop->op_last = OpSIBLING(binop->op_first);
5139     if (binop->op_last)
5140         OpLASTSIB_set(binop->op_last, (OP*)binop);
5141
5142     binop = (BINOP*)CHECKOP(type, binop);
5143     if (binop->op_next || binop->op_type != (OPCODE)type)
5144         return (OP*)binop;
5145
5146     return fold_constants(op_integerize(op_std_init((OP *)binop)));
5147 }
5148
5149 static int uvcompare(const void *a, const void *b)
5150     __attribute__nonnull__(1)
5151     __attribute__nonnull__(2)
5152     __attribute__pure__;
5153 static int uvcompare(const void *a, const void *b)
5154 {
5155     if (*((const UV *)a) < (*(const UV *)b))
5156         return -1;
5157     if (*((const UV *)a) > (*(const UV *)b))
5158         return 1;
5159     if (*((const UV *)a+1) < (*(const UV *)b+1))
5160         return -1;
5161     if (*((const UV *)a+1) > (*(const UV *)b+1))
5162         return 1;
5163     return 0;
5164 }
5165
5166 static OP *
5167 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
5168 {
5169     SV * const tstr = ((SVOP*)expr)->op_sv;
5170     SV * const rstr =
5171                               ((SVOP*)repl)->op_sv;
5172     STRLEN tlen;
5173     STRLEN rlen;
5174     const U8 *t = (U8*)SvPV_const(tstr, tlen);
5175     const U8 *r = (U8*)SvPV_const(rstr, rlen);
5176     I32 i;
5177     I32 j;
5178     I32 grows = 0;
5179     short *tbl;
5180
5181     const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
5182     const I32 squash     = o->op_private & OPpTRANS_SQUASH;
5183     I32 del              = o->op_private & OPpTRANS_DELETE;
5184     SV* swash;
5185
5186     PERL_ARGS_ASSERT_PMTRANS;
5187
5188     PL_hints |= HINT_BLOCK_SCOPE;
5189
5190     if (SvUTF8(tstr))
5191         o->op_private |= OPpTRANS_FROM_UTF;
5192
5193     if (SvUTF8(rstr))
5194         o->op_private |= OPpTRANS_TO_UTF;
5195
5196     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
5197         SV* const listsv = newSVpvs("# comment\n");
5198         SV* transv = NULL;
5199         const U8* tend = t + tlen;
5200         const U8* rend = r + rlen;
5201         STRLEN ulen;
5202         UV tfirst = 1;
5203         UV tlast = 0;
5204         IV tdiff;
5205         STRLEN tcount = 0;
5206         UV rfirst = 1;
5207         UV rlast = 0;
5208         IV rdiff;
5209         STRLEN rcount = 0;
5210         IV diff;
5211         I32 none = 0;
5212         U32 max = 0;
5213         I32 bits;
5214         I32 havefinal = 0;
5215         U32 final = 0;
5216         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
5217         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
5218         U8* tsave = NULL;
5219         U8* rsave = NULL;
5220         const U32 flags = UTF8_ALLOW_DEFAULT;
5221
5222         if (!from_utf) {
5223             STRLEN len = tlen;
5224             t = tsave = bytes_to_utf8(t, &len);
5225             tend = t + len;
5226         }
5227         if (!to_utf && rlen) {
5228             STRLEN len = rlen;
5229             r = rsave = bytes_to_utf8(r, &len);
5230             rend = r + len;
5231         }
5232
5233 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
5234  * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
5235  * odd.  */
5236
5237         if (complement) {
5238             U8 tmpbuf[UTF8_MAXBYTES+1];
5239             UV *cp;
5240             UV nextmin = 0;
5241             Newx(cp, 2*tlen, UV);
5242             i = 0;
5243             transv = newSVpvs("");
5244             while (t < tend) {
5245                 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
5246                 t += ulen;
5247                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
5248                     t++;
5249                     cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
5250                     t += ulen;
5251                 }
5252                 else {
5253                  cp[2*i+1] = cp[2*i];
5254                 }
5255                 i++;
5256             }
5257             qsort(cp, i, 2*sizeof(UV), uvcompare);
5258             for (j = 0; j < i; j++) {
5259                 UV  val = cp[2*j];
5260                 diff = val - nextmin;
5261                 if (diff > 0) {
5262                     t = uvchr_to_utf8(tmpbuf,nextmin);
5263                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5264                     if (diff > 1) {
5265                         U8  range_mark = ILLEGAL_UTF8_BYTE;
5266                         t = uvchr_to_utf8(tmpbuf, val - 1);
5267                         sv_catpvn(transv, (char *)&range_mark, 1);
5268                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5269                     }
5270                 }
5271                 val = cp[2*j+1];
5272                 if (val >= nextmin)
5273                     nextmin = val + 1;
5274             }
5275             t = uvchr_to_utf8(tmpbuf,nextmin);
5276             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5277             {
5278                 U8 range_mark = ILLEGAL_UTF8_BYTE;
5279                 sv_catpvn(transv, (char *)&range_mark, 1);
5280             }
5281             t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
5282             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5283             t = (const U8*)SvPVX_const(transv);
5284             tlen = SvCUR(transv);
5285             tend = t + tlen;
5286             Safefree(cp);
5287         }
5288         else if (!rlen && !del) {
5289             r = t; rlen = tlen; rend = tend;
5290         }
5291         if (!squash) {
5292                 if ((!rlen && !del) || t == r ||
5293                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
5294                 {
5295                     o->op_private |= OPpTRANS_IDENTICAL;
5296                 }
5297         }
5298
5299         while (t < tend || tfirst <= tlast) {
5300             /* see if we need more "t" chars */
5301             if (tfirst > tlast) {
5302                 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
5303                 t += ulen;
5304                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {      /* illegal utf8 val indicates range */
5305                     t++;
5306                     tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
5307                     t += ulen;
5308                 }
5309                 else
5310                     tlast = tfirst;
5311             }
5312
5313             /* now see if we need more "r" chars */
5314             if (rfirst > rlast) {
5315                 if (r < rend) {
5316                     rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
5317                     r += ulen;
5318                     if (r < rend && *r == ILLEGAL_UTF8_BYTE) {  /* illegal utf8 val indicates range */
5319                         r++;
5320                         rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
5321                         r += ulen;
5322                     }
5323                     else
5324                         rlast = rfirst;
5325                 }
5326                 else {
5327                     if (!havefinal++)
5328                         final = rlast;
5329                     rfirst = rlast = 0xffffffff;
5330                 }
5331             }
5332
5333             /* now see which range will peter out first, if either. */
5334             tdiff = tlast - tfirst;
5335             rdiff = rlast - rfirst;
5336             tcount += tdiff + 1;
5337             rcount += rdiff + 1;
5338
5339             if (tdiff <= rdiff)
5340                 diff = tdiff;
5341             else
5342                 diff = rdiff;
5343
5344             if (rfirst == 0xffffffff) {
5345                 diff = tdiff;   /* oops, pretend rdiff is infinite */
5346                 if (diff > 0)
5347                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
5348                                    (long)tfirst, (long)tlast);
5349                 else
5350                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
5351             }
5352             else {
5353                 if (diff > 0)
5354                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
5355                                    (long)tfirst, (long)(tfirst + diff),
5356                                    (long)rfirst);
5357                 else
5358                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
5359                                    (long)tfirst, (long)rfirst);
5360
5361                 if (rfirst + diff > max)
5362                     max = rfirst + diff;
5363                 if (!grows)
5364                     grows = (tfirst < rfirst &&
5365                              UVCHR_SKIP(tfirst) < UVCHR_SKIP(rfirst + diff));
5366                 rfirst += diff + 1;
5367             }
5368             tfirst += diff + 1;
5369         }
5370
5371         none = ++max;
5372         if (del)
5373             del = ++max;
5374
5375         if (max > 0xffff)
5376             bits = 32;
5377         else if (max > 0xff)
5378             bits = 16;
5379         else
5380             bits = 8;
5381
5382         swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
5383 #ifdef USE_ITHREADS
5384         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
5385         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
5386         PAD_SETSV(cPADOPo->op_padix, swash);
5387         SvPADTMP_on(swash);
5388         SvREADONLY_on(swash);
5389 #else
5390         cSVOPo->op_sv = swash;
5391 #endif
5392         SvREFCNT_dec(listsv);
5393         SvREFCNT_dec(transv);
5394
5395         if (!del && havefinal && rlen)
5396             (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
5397                            newSVuv((UV)final), 0);
5398
5399         Safefree(tsave);
5400         Safefree(rsave);
5401
5402         tlen = tcount;
5403         rlen = rcount;
5404         if (r < rend)
5405             rlen++;
5406         else if (rlast == 0xffffffff)
5407             rlen = 0;
5408
5409         goto warnins;
5410     }
5411
5412     tbl = (short*)PerlMemShared_calloc(
5413         (o->op_private & OPpTRANS_COMPLEMENT) &&
5414             !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
5415         sizeof(short));
5416     cPVOPo->op_pv = (char*)tbl;
5417     if (complement) {
5418         for (i = 0; i < (I32)tlen; i++)
5419             tbl[t[i]] = -1;
5420         for (i = 0, j = 0; i < 256; i++) {
5421             if (!tbl[i]) {
5422                 if (j >= (I32)rlen) {
5423                     if (del)
5424                         tbl[i] = -2;
5425                     else if (rlen)
5426                         tbl[i] = r[j-1];
5427                     else
5428                         tbl[i] = (short)i;
5429                 }
5430                 else {
5431                     if (i < 128 && r[j] >= 128)
5432                         grows = 1;
5433                     tbl[i] = r[j++];
5434                 }
5435             }
5436         }
5437         if (!del) {
5438             if (!rlen) {
5439                 j = rlen;
5440                 if (!squash)
5441                     o->op_private |= OPpTRANS_IDENTICAL;
5442             }
5443             else if (j >= (I32)rlen)
5444                 j = rlen - 1;
5445             else {
5446                 tbl =
5447                     (short *)
5448                     PerlMemShared_realloc(tbl,
5449                                           (0x101+rlen-j) * sizeof(short));
5450                 cPVOPo->op_pv = (char*)tbl;
5451             }
5452             tbl[0x100] = (short)(rlen - j);
5453             for (i=0; i < (I32)rlen - j; i++)
5454                 tbl[0x101+i] = r[j+i];
5455         }
5456     }
5457     else {
5458         if (!rlen && !del) {
5459             r = t; rlen = tlen;
5460             if (!squash)
5461                 o->op_private |= OPpTRANS_IDENTICAL;
5462         }
5463         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
5464             o->op_private |= OPpTRANS_IDENTICAL;
5465         }
5466         for (i = 0; i < 256; i++)
5467             tbl[i] = -1;
5468         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
5469             if (j >= (I32)rlen) {
5470                 if (del) {
5471                     if (tbl[t[i]] == -1)
5472                         tbl[t[i]] = -2;
5473                     continue;
5474                 }
5475                 --j;
5476             }
5477             if (tbl[t[i]] == -1) {
5478                 if (t[i] < 128 && r[j] >= 128)
5479                     grows = 1;
5480                 tbl[t[i]] = r[j];
5481             }
5482         }
5483     }
5484
5485   warnins:
5486     if(del && rlen == tlen) {
5487         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
5488     } else if(rlen > tlen && !complement) {
5489         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
5490     }
5491
5492     if (grows)
5493         o->op_private |= OPpTRANS_GROWS;
5494     op_free(expr);
5495     op_free(repl);
5496
5497     return o;
5498 }
5499
5500 /*
5501 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
5502
5503 Constructs, checks, and returns an op of any pattern matching type.
5504 C<type> is the opcode.  C<flags> gives the eight bits of C<op_flags>
5505 and, shifted up eight bits, the eight bits of C<op_private>.
5506
5507 =cut
5508 */
5509
5510 OP *
5511 Perl_newPMOP(pTHX_ I32 type, I32 flags)
5512 {
5513     dVAR;
5514     PMOP *pmop;
5515
5516     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
5517         || type == OP_CUSTOM);
5518
5519     NewOp(1101, pmop, 1, PMOP);
5520     OpTYPE_set(pmop, type);
5521     pmop->op_flags = (U8)flags;
5522     pmop->op_private = (U8)(0 | (flags >> 8));
5523     if (PL_opargs[type] & OA_RETSCALAR)
5524         scalar((OP *)pmop);
5525
5526     if (PL_hints & HINT_RE_TAINT)
5527         pmop->op_pmflags |= PMf_RETAINT;
5528 #ifdef USE_LOCALE_CTYPE
5529     if (IN_LC_COMPILETIME(LC_CTYPE)) {
5530         set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
5531     }
5532     else
5533 #endif
5534          if (IN_UNI_8_BIT) {
5535         set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
5536     }
5537     if (PL_hints & HINT_RE_FLAGS) {
5538         SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5539          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
5540         );
5541         if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
5542         reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5543          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
5544         );
5545         if (reflags && SvOK(reflags)) {
5546             set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
5547         }
5548     }
5549
5550
5551 #ifdef USE_ITHREADS
5552     assert(SvPOK(PL_regex_pad[0]));
5553     if (SvCUR(PL_regex_pad[0])) {
5554         /* Pop off the "packed" IV from the end.  */
5555         SV *const repointer_list = PL_regex_pad[0];
5556         const char *p = SvEND(repointer_list) - sizeof(IV);
5557         const IV offset = *((IV*)p);
5558
5559         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
5560
5561         SvEND_set(repointer_list, p);
5562
5563         pmop->op_pmoffset = offset;
5564         /* This slot should be free, so assert this:  */
5565         assert(PL_regex_pad[offset] == &PL_sv_undef);
5566     } else {
5567         SV * const repointer = &PL_sv_undef;
5568         av_push(PL_regex_padav, repointer);
5569         pmop->op_pmoffset = av_tindex(PL_regex_padav);
5570         PL_regex_pad = AvARRAY(PL_regex_padav);
5571     }
5572 #endif
5573
5574     return CHECKOP(type, pmop);
5575 }
5576
5577 static void
5578 S_set_haseval(pTHX)
5579 {
5580     PADOFFSET i = 1;
5581     PL_cv_has_eval = 1;
5582     /* Any pad names in scope are potentially lvalues.  */
5583     for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
5584         PADNAME *pn = PAD_COMPNAME_SV(i);
5585         if (!pn || !PadnameLEN(pn))
5586             continue;
5587         if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
5588             S_mark_padname_lvalue(aTHX_ pn);
5589     }
5590 }
5591
5592 /* Given some sort of match op o, and an expression expr containing a
5593  * pattern, either compile expr into a regex and attach it to o (if it's
5594  * constant), or convert expr into a runtime regcomp op sequence (if it's
5595  * not)
5596  *
5597  * isreg indicates that the pattern is part of a regex construct, eg
5598  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
5599  * split "pattern", which aren't. In the former case, expr will be a list
5600  * if the pattern contains more than one term (eg /a$b/).
5601  *
5602  * When the pattern has been compiled within a new anon CV (for
5603  * qr/(?{...})/ ), then floor indicates the savestack level just before
5604  * the new sub was created
5605  */
5606
5607 OP *
5608 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, bool isreg, I32 floor)
5609 {
5610     PMOP *pm;
5611     LOGOP *rcop;
5612     I32 repl_has_vars = 0;
5613     bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
5614     bool is_compiletime;
5615     bool has_code;
5616
5617     PERL_ARGS_ASSERT_PMRUNTIME;
5618
5619     if (is_trans) {
5620         return pmtrans(o, expr, repl);
5621     }
5622
5623     /* find whether we have any runtime or code elements;
5624      * at the same time, temporarily set the op_next of each DO block;
5625      * then when we LINKLIST, this will cause the DO blocks to be excluded
5626      * from the op_next chain (and from having LINKLIST recursively
5627      * applied to them). We fix up the DOs specially later */
5628
5629     is_compiletime = 1;
5630     has_code = 0;
5631     if (expr->op_type == OP_LIST) {
5632         OP *o;
5633         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
5634             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
5635                 has_code = 1;
5636                 assert(!o->op_next);
5637                 if (UNLIKELY(!OpHAS_SIBLING(o))) {
5638                     assert(PL_parser && PL_parser->error_count);
5639                     /* This can happen with qr/ (?{(^{})/.  Just fake up
5640                        the op we were expecting to see, to avoid crashing
5641                        elsewhere.  */
5642                     op_sibling_splice(expr, o, 0,
5643                                       newSVOP(OP_CONST, 0, &PL_sv_no));
5644                 }
5645                 o->op_next = OpSIBLING(o);
5646             }
5647             else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
5648                 is_compiletime = 0;
5649         }
5650     }
5651     else if (expr->op_type != OP_CONST)
5652         is_compiletime = 0;
5653
5654     LINKLIST(expr);
5655
5656     /* fix up DO blocks; treat each one as a separate little sub;
5657      * also, mark any arrays as LIST/REF */
5658
5659     if (expr->op_type == OP_LIST) {
5660         OP *o;
5661         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
5662
5663             if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
5664                 assert( !(o->op_flags  & OPf_WANT));
5665                 /* push the array rather than its contents. The regex
5666                  * engine will retrieve and join the elements later */
5667                 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
5668                 continue;
5669             }
5670
5671             if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
5672                 continue;
5673             o->op_next = NULL; /* undo temporary hack from above */
5674             scalar(o);
5675             LINKLIST(o);
5676             if (cLISTOPo->op_first->op_type == OP_LEAVE) {
5677                 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
5678                 /* skip ENTER */
5679                 assert(leaveop->op_first->op_type == OP_ENTER);
5680                 assert(OpHAS_SIBLING(leaveop->op_first));
5681                 o->op_next = OpSIBLING(leaveop->op_first);
5682                 /* skip leave */
5683                 assert(leaveop->op_flags & OPf_KIDS);
5684                 assert(leaveop->op_last->op_next == (OP*)leaveop);
5685                 leaveop->op_next = NULL; /* stop on last op */
5686                 op_null((OP*)leaveop);
5687             }
5688             else {
5689                 /* skip SCOPE */
5690                 OP *scope = cLISTOPo->op_first;
5691                 assert(scope->op_type == OP_SCOPE);
5692                 assert(scope->op_flags & OPf_KIDS);
5693                 scope->op_next = NULL; /* stop on last op */
5694                 op_null(scope);
5695             }
5696             /* have to peep the DOs individually as we've removed it from
5697              * the op_next chain */
5698             CALL_PEEP(o);
5699             S_prune_chain_head(&(o->op_next));
5700             if (is_compiletime)
5701                 /* runtime finalizes as part of finalizing whole tree */
5702                 finalize_optree(o);
5703         }
5704     }
5705     else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
5706         assert( !(expr->op_flags  & OPf_WANT));
5707         /* push the array rather than its contents. The regex
5708          * engine will retrieve and join the elements later */
5709         expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
5710     }
5711
5712     PL_hints |= HINT_BLOCK_SCOPE;
5713     pm = (PMOP*)o;
5714     assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
5715
5716     if (is_compiletime) {
5717         U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
5718         regexp_engine const *eng = current_re_engine();
5719
5720         if (o->op_flags & OPf_SPECIAL)
5721             rx_flags |= RXf_SPLIT;
5722
5723         if (!has_code || !eng->op_comp) {
5724             /* compile-time simple constant pattern */
5725
5726             if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
5727                 /* whoops! we guessed that a qr// had a code block, but we
5728                  * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
5729                  * that isn't required now. Note that we have to be pretty
5730                  * confident that nothing used that CV's pad while the
5731                  * regex was parsed, except maybe op targets for \Q etc.
5732                  * If there were any op targets, though, they should have
5733                  * been stolen by constant folding.
5734                  */
5735 #ifdef DEBUGGING
5736                 SSize_t i = 0;
5737                 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
5738                 while (++i <= AvFILLp(PL_comppad)) {
5739                     assert(!PL_curpad[i]);
5740                 }
5741 #endif
5742                 /* But we know that one op is using this CV's slab. */
5743                 cv_forget_slab(PL_compcv);
5744                 LEAVE_SCOPE(floor);
5745                 pm->op_pmflags &= ~PMf_HAS_CV;
5746             }
5747
5748             PM_SETRE(pm,
5749                 eng->op_comp
5750                     ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5751                                         rx_flags, pm->op_pmflags)
5752                     : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5753                                         rx_flags, pm->op_pmflags)
5754             );
5755             op_free(expr);
5756         }
5757         else {
5758             /* compile-time pattern that includes literal code blocks */
5759             REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5760                         rx_flags,
5761                         (pm->op_pmflags |
5762                             ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
5763                     );
5764             PM_SETRE(pm, re);
5765             if (pm->op_pmflags & PMf_HAS_CV) {
5766                 CV *cv;
5767                 /* this QR op (and the anon sub we embed it in) is never
5768                  * actually executed. It's just a placeholder where we can
5769                  * squirrel away expr in op_code_list without the peephole
5770                  * optimiser etc processing it for a second time */
5771                 OP *qr = newPMOP(OP_QR, 0);
5772                 ((PMOP*)qr)->op_code_list = expr;
5773
5774                 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
5775                 SvREFCNT_inc_simple_void(PL_compcv);
5776                 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
5777                 ReANY(re)->qr_anoncv = cv;
5778
5779                 /* attach the anon CV to the pad so that
5780                  * pad_fixup_inner_anons() can find it */
5781                 (void)pad_add_anon(cv, o->op_type);
5782                 SvREFCNT_inc_simple_void(cv);
5783             }
5784             else {
5785                 pm->op_code_list = expr;
5786             }
5787         }
5788     }
5789     else {
5790         /* runtime pattern: build chain of regcomp etc ops */
5791         bool reglist;
5792         PADOFFSET cv_targ = 0;
5793
5794         reglist = isreg && expr->op_type == OP_LIST;
5795         if (reglist)
5796             op_null(expr);
5797
5798         if (has_code) {
5799             pm->op_code_list = expr;
5800             /* don't free op_code_list; its ops are embedded elsewhere too */
5801             pm->op_pmflags |= PMf_CODELIST_PRIVATE;
5802         }
5803
5804         if (o->op_flags & OPf_SPECIAL)
5805             pm->op_pmflags |= PMf_SPLIT;
5806
5807         /* the OP_REGCMAYBE is a placeholder in the non-threaded case
5808          * to allow its op_next to be pointed past the regcomp and
5809          * preceding stacking ops;
5810          * OP_REGCRESET is there to reset taint before executing the
5811          * stacking ops */
5812         if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
5813             expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
5814
5815         if (pm->op_pmflags & PMf_HAS_CV) {
5816             /* we have a runtime qr with literal code. This means
5817              * that the qr// has been wrapped in a new CV, which
5818              * means that runtime consts, vars etc will have been compiled
5819              * against a new pad. So... we need to execute those ops
5820              * within the environment of the new CV. So wrap them in a call
5821              * to a new anon sub. i.e. for
5822              *
5823              *     qr/a$b(?{...})/,
5824              *
5825              * we build an anon sub that looks like
5826              *
5827              *     sub { "a", $b, '(?{...})' }
5828              *
5829              * and call it, passing the returned list to regcomp.
5830              * Or to put it another way, the list of ops that get executed
5831              * are:
5832              *
5833              *     normal              PMf_HAS_CV
5834              *     ------              -------------------
5835              *                         pushmark (for regcomp)
5836              *                         pushmark (for entersub)
5837              *                         anoncode
5838              *                         srefgen
5839              *                         entersub
5840              *     regcreset                  regcreset
5841              *     pushmark                   pushmark
5842              *     const("a")                 const("a")
5843              *     gvsv(b)                    gvsv(b)
5844              *     const("(?{...})")          const("(?{...})")
5845              *                                leavesub
5846              *     regcomp             regcomp
5847              */
5848
5849             SvREFCNT_inc_simple_void(PL_compcv);
5850             CvLVALUE_on(PL_compcv);
5851             /* these lines are just an unrolled newANONATTRSUB */
5852             expr = newSVOP(OP_ANONCODE, 0,
5853                     MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
5854             cv_targ = expr->op_targ;
5855             expr = newUNOP(OP_REFGEN, 0, expr);
5856
5857             expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
5858         }
5859
5860         rcop = S_alloc_LOGOP(aTHX_ OP_REGCOMP, scalar(expr), o);
5861         rcop->op_flags |=  ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
5862                            | (reglist ? OPf_STACKED : 0);
5863         rcop->op_targ = cv_targ;
5864
5865         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
5866         if (PL_hints & HINT_RE_EVAL)
5867             S_set_haseval(aTHX);
5868
5869         /* establish postfix order */
5870         if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
5871             LINKLIST(expr);
5872             rcop->op_next = expr;
5873             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
5874         }
5875         else {
5876             rcop->op_next = LINKLIST(expr);
5877             expr->op_next = (OP*)rcop;
5878         }
5879
5880         op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
5881     }
5882
5883     if (repl) {
5884         OP *curop = repl;
5885         bool konst;
5886         /* If we are looking at s//.../e with a single statement, get past
5887            the implicit do{}. */
5888         if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
5889              && cUNOPx(curop)->op_first->op_type == OP_SCOPE
5890              && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
5891          {
5892             OP *sib;
5893             OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
5894             if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
5895              && !OpHAS_SIBLING(sib))
5896                 curop = sib;
5897         }
5898         if (curop->op_type == OP_CONST)
5899             konst = TRUE;
5900         else if (( (curop->op_type == OP_RV2SV ||
5901                     curop->op_type == OP_RV2AV ||
5902                     curop->op_type == OP_RV2HV ||
5903                     curop->op_type == OP_RV2GV)
5904                    && cUNOPx(curop)->op_first
5905                    && cUNOPx(curop)->op_first->op_type == OP_GV )
5906                 || curop->op_type == OP_PADSV
5907                 || curop->op_type == OP_PADAV
5908                 || curop->op_type == OP_PADHV
5909                 || curop->op_type == OP_PADANY) {
5910             repl_has_vars = 1;
5911             konst = TRUE;
5912         }
5913         else konst = FALSE;
5914         if (konst
5915             && !(repl_has_vars
5916                  && (!PM_GETRE(pm)
5917                      || !RX_PRELEN(PM_GETRE(pm))
5918                      || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
5919         {
5920             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
5921             op_prepend_elem(o->op_type, scalar(repl), o);
5922         }
5923         else {
5924             rcop = S_alloc_LOGOP(aTHX_ OP_SUBSTCONT, scalar(repl), o);
5925             rcop->op_private = 1;
5926
5927             /* establish postfix order */
5928             rcop->op_next = LINKLIST(repl);
5929             repl->op_next = (OP*)rcop;
5930
5931             pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
5932             assert(!(pm->op_pmflags & PMf_ONCE));
5933             pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
5934             rcop->op_next = 0;
5935         }
5936     }
5937
5938     return (OP*)pm;
5939 }
5940
5941 /*
5942 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
5943
5944 Constructs, checks, and returns an op of any type that involves an
5945 embedded SV.  C<type> is the opcode.  C<flags> gives the eight bits
5946 of C<op_flags>.  C<sv> gives the SV to embed in the op; this function
5947 takes ownership of one reference to it.
5948
5949 =cut
5950 */
5951
5952 OP *
5953 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
5954 {
5955     dVAR;
5956     SVOP *svop;
5957
5958     PERL_ARGS_ASSERT_NEWSVOP;
5959
5960     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5961         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5962         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5963         || type == OP_CUSTOM);
5964
5965     NewOp(1101, svop, 1, SVOP);
5966     OpTYPE_set(svop, type);
5967     svop->op_sv = sv;
5968     svop->op_next = (OP*)svop;
5969     svop->op_flags = (U8)flags;
5970     svop->op_private = (U8)(0 | (flags >> 8));
5971     if (PL_opargs[type] & OA_RETSCALAR)
5972         scalar((OP*)svop);
5973     if (PL_opargs[type] & OA_TARGET)
5974         svop->op_targ = pad_alloc(type, SVs_PADTMP);
5975     return CHECKOP(type, svop);
5976 }
5977
5978 /*
5979 =for apidoc Am|OP *|newDEFSVOP|
5980
5981 Constructs and returns an op to access C<$_>.
5982
5983 =cut
5984 */
5985
5986 OP *
5987 Perl_newDEFSVOP(pTHX)
5988 {
5989         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
5990 }
5991
5992 #ifdef USE_ITHREADS
5993
5994 /*
5995 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
5996
5997 Constructs, checks, and returns an op of any type that involves a
5998 reference to a pad element.  C<type> is the opcode.  C<flags> gives the
5999 eight bits of C<op_flags>.  A pad slot is automatically allocated, and
6000 is populated with C<sv>; this function takes ownership of one reference
6001 to it.
6002
6003 This function only exists if Perl has been compiled to use ithreads.
6004
6005 =cut
6006 */
6007
6008 OP *
6009 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
6010 {
6011     dVAR;
6012     PADOP *padop;
6013
6014     PERL_ARGS_ASSERT_NEWPADOP;
6015
6016     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
6017         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
6018         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6019         || type == OP_CUSTOM);
6020
6021     NewOp(1101, padop, 1, PADOP);
6022     OpTYPE_set(padop, type);
6023     padop->op_padix =
6024         pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
6025     SvREFCNT_dec(PAD_SVl(padop->op_padix));
6026     PAD_SETSV(padop->op_padix, sv);
6027     assert(sv);
6028     padop->op_next = (OP*)padop;
6029     padop->op_flags = (U8)flags;
6030     if (PL_opargs[type] & OA_RETSCALAR)
6031         scalar((OP*)padop);
6032     if (PL_opargs[type] & OA_TARGET)
6033         padop->op_targ = pad_alloc(type, SVs_PADTMP);
6034     return CHECKOP(type, padop);
6035 }
6036
6037 #endif /* USE_ITHREADS */
6038
6039 /*
6040 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
6041
6042 Constructs, checks, and returns an op of any type that involves an
6043 embedded reference to a GV.  C<type> is the opcode.  C<flags> gives the
6044 eight bits of C<op_flags>.  C<gv> identifies the GV that the op should
6045 reference; calling this function does not transfer ownership of any
6046 reference to it.
6047
6048 =cut
6049 */
6050
6051 OP *
6052 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
6053 {
6054     PERL_ARGS_ASSERT_NEWGVOP;
6055
6056 #ifdef USE_ITHREADS
6057     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
6058 #else
6059     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
6060 #endif
6061 }
6062
6063 /*
6064 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
6065
6066 Constructs, checks, and returns an op of any type that involves an
6067 embedded C-level pointer (PV).  C<type> is the opcode.  C<flags> gives
6068 the eight bits of C<op_flags>.  C<pv> supplies the C-level pointer, which
6069 must have been allocated using C<PerlMemShared_malloc>; the memory will
6070 be freed when the op is destroyed.
6071
6072 =cut
6073 */
6074
6075 OP *
6076 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
6077 {
6078     dVAR;
6079     const bool utf8 = cBOOL(flags & SVf_UTF8);
6080     PVOP *pvop;
6081
6082     flags &= ~SVf_UTF8;
6083
6084     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
6085         || type == OP_RUNCV || type == OP_CUSTOM
6086         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6087
6088     NewOp(1101, pvop, 1, PVOP);
6089     OpTYPE_set(pvop, type);
6090     pvop->op_pv = pv;
6091     pvop->op_next = (OP*)pvop;
6092     pvop->op_flags = (U8)flags;
6093     pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
6094     if (PL_opargs[type] & OA_RETSCALAR)
6095         scalar((OP*)pvop);
6096     if (PL_opargs[type] & OA_TARGET)
6097         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
6098     return CHECKOP(type, pvop);
6099 }
6100
6101 void
6102 Perl_package(pTHX_ OP *o)
6103 {
6104     SV *const sv = cSVOPo->op_sv;
6105
6106     PERL_ARGS_ASSERT_PACKAGE;
6107
6108     SAVEGENERICSV(PL_curstash);
6109     save_item(PL_curstname);
6110
6111     PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
6112
6113     sv_setsv(PL_curstname, sv);
6114
6115     PL_hints |= HINT_BLOCK_SCOPE;
6116     PL_parser->copline = NOLINE;
6117
6118     op_free(o);
6119 }
6120
6121 void
6122 Perl_package_version( pTHX_ OP *v )
6123 {
6124     U32 savehints = PL_hints;
6125     PERL_ARGS_ASSERT_PACKAGE_VERSION;
6126     PL_hints &= ~HINT_STRICT_VARS;
6127     sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
6128     PL_hints = savehints;
6129     op_free(v);
6130 }
6131
6132 void
6133 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
6134 {
6135     OP *pack;
6136     OP *imop;
6137     OP *veop;
6138     SV *use_version = NULL;
6139
6140     PERL_ARGS_ASSERT_UTILIZE;
6141
6142     if (idop->op_type != OP_CONST)
6143         Perl_croak(aTHX_ "Module name must be constant");
6144
6145     veop = NULL;
6146
6147     if (version) {
6148         SV * const vesv = ((SVOP*)version)->op_sv;
6149
6150         if (!arg && !SvNIOKp(vesv)) {
6151             arg = version;
6152         }
6153         else {
6154             OP *pack;
6155             SV *meth;
6156
6157             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
6158                 Perl_croak(aTHX_ "Version number must be a constant number");
6159
6160             /* Make copy of idop so we don't free it twice */
6161             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
6162
6163             /* Fake up a method call to VERSION */
6164             meth = newSVpvs_share("VERSION");
6165             veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
6166                             op_append_elem(OP_LIST,
6167                                         op_prepend_elem(OP_LIST, pack, version),
6168                                         newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
6169         }
6170     }
6171
6172     /* Fake up an import/unimport */
6173     if (arg && arg->op_type == OP_STUB) {
6174         imop = arg;             /* no import on explicit () */
6175     }
6176     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
6177         imop = NULL;            /* use 5.0; */
6178         if (aver)
6179             use_version = ((SVOP*)idop)->op_sv;
6180         else
6181             idop->op_private |= OPpCONST_NOVER;
6182     }
6183     else {
6184         SV *meth;
6185
6186         /* Make copy of idop so we don't free it twice */
6187         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
6188
6189         /* Fake up a method call to import/unimport */
6190         meth = aver
6191             ? newSVpvs_share("import") : newSVpvs_share("unimport");
6192         imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
6193                        op_append_elem(OP_LIST,
6194                                    op_prepend_elem(OP_LIST, pack, arg),
6195                                    newMETHOP_named(OP_METHOD_NAMED, 0, meth)
6196                        ));
6197     }
6198
6199     /* Fake up the BEGIN {}, which does its thing immediately. */
6200     newATTRSUB(floor,
6201         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
6202         NULL,
6203         NULL,
6204         op_append_elem(OP_LINESEQ,
6205             op_append_elem(OP_LINESEQ,
6206                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
6207                 newSTATEOP(0, NULL, veop)),
6208             newSTATEOP(0, NULL, imop) ));
6209
6210     if (use_version) {
6211         /* Enable the
6212          * feature bundle that corresponds to the required version. */
6213         use_version = sv_2mortal(new_version(use_version));
6214         S_enable_feature_bundle(aTHX_ use_version);
6215
6216         /* If a version >= 5.11.0 is requested, strictures are on by default! */
6217         if (vcmp(use_version,
6218                  sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
6219             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
6220                 PL_hints |= HINT_STRICT_REFS;
6221             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
6222                 PL_hints |= HINT_STRICT_SUBS;
6223             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
6224                 PL_hints |= HINT_STRICT_VARS;
6225         }
6226         /* otherwise they are off */
6227         else {
6228             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
6229                 PL_hints &= ~HINT_STRICT_REFS;
6230             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
6231                 PL_hints &= ~HINT_STRICT_SUBS;
6232             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
6233                 PL_hints &= ~HINT_STRICT_VARS;
6234         }
6235     }
6236
6237     /* The "did you use incorrect case?" warning used to be here.
6238      * The problem is that on case-insensitive filesystems one
6239      * might get false positives for "use" (and "require"):
6240      * "use Strict" or "require CARP" will work.  This causes
6241      * portability problems for the script: in case-strict
6242      * filesystems the script will stop working.
6243      *
6244      * The "incorrect case" warning checked whether "use Foo"
6245      * imported "Foo" to your namespace, but that is wrong, too:
6246      * there is no requirement nor promise in the language that
6247      * a Foo.pm should or would contain anything in package "Foo".
6248      *
6249      * There is very little Configure-wise that can be done, either:
6250      * the case-sensitivity of the build filesystem of Perl does not
6251      * help in guessing the case-sensitivity of the runtime environment.
6252      */
6253
6254     PL_hints |= HINT_BLOCK_SCOPE;
6255     PL_parser->copline = NOLINE;
6256     COP_SEQMAX_INC; /* Purely for B::*'s benefit */
6257 }
6258
6259 /*
6260 =head1 Embedding Functions
6261
6262 =for apidoc load_module
6263
6264 Loads the module whose name is pointed to by the string part of name.
6265 Note that the actual module name, not its filename, should be given.
6266 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
6267 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
6268 (or 0 for no flags).  ver, if specified
6269 and not NULL, provides version semantics
6270 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
6271 arguments can be used to specify arguments to the module's C<import()>
6272 method, similar to C<use Foo::Bar VERSION LIST>.  They must be
6273 terminated with a final C<NULL> pointer.  Note that this list can only
6274 be omitted when the C<PERL_LOADMOD_NOIMPORT> flag has been used.
6275 Otherwise at least a single C<NULL> pointer to designate the default
6276 import list is required.
6277
6278 The reference count for each specified C<SV*> parameter is decremented.
6279
6280 =cut */
6281
6282 void
6283 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
6284 {
6285     va_list args;
6286
6287     PERL_ARGS_ASSERT_LOAD_MODULE;
6288
6289     va_start(args, ver);
6290     vload_module(flags, name, ver, &args);
6291     va_end(args);
6292 }
6293
6294 #ifdef PERL_IMPLICIT_CONTEXT
6295 void
6296 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
6297 {
6298     dTHX;
6299     va_list args;
6300     PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
6301     va_start(args, ver);
6302     vload_module(flags, name, ver, &args);
6303     va_end(args);
6304 }
6305 #endif
6306
6307 void
6308 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
6309 {
6310     OP *veop, *imop;
6311     OP * const modname = newSVOP(OP_CONST, 0, name);
6312
6313     PERL_ARGS_ASSERT_VLOAD_MODULE;
6314
6315     modname->op_private |= OPpCONST_BARE;
6316     if (ver) {
6317         veop = newSVOP(OP_CONST, 0, ver);
6318     }
6319     else
6320         veop = NULL;
6321     if (flags & PERL_LOADMOD_NOIMPORT) {
6322         imop = sawparens(newNULLLIST());
6323     }
6324     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
6325         imop = va_arg(*args, OP*);
6326     }
6327     else {
6328         SV *sv;
6329         imop = NULL;
6330         sv = va_arg(*args, SV*);
6331         while (sv) {
6332             imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
6333             sv = va_arg(*args, SV*);
6334         }
6335     }
6336
6337     /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
6338      * that it has a PL_parser to play with while doing that, and also
6339      * that it doesn't mess with any existing parser, by creating a tmp
6340      * new parser with lex_start(). This won't actually be used for much,
6341      * since pp_require() will create another parser for the real work.
6342      * The ENTER/LEAVE pair protect callers from any side effects of use.  */
6343
6344     ENTER;
6345     SAVEVPTR(PL_curcop);
6346     lex_start(NULL, NULL, LEX_START_SAME_FILTER);
6347     utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
6348             veop, modname, imop);
6349     LEAVE;
6350 }
6351
6352 PERL_STATIC_INLINE OP *
6353 S_new_entersubop(pTHX_ GV *gv, OP *arg)
6354 {
6355     return newUNOP(OP_ENTERSUB, OPf_STACKED,
6356                    newLISTOP(OP_LIST, 0, arg,
6357                              newUNOP(OP_RV2CV, 0,
6358                                      newGVOP(OP_GV, 0, gv))));
6359 }
6360
6361 OP *
6362 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
6363 {
6364     OP *doop;
6365     GV *gv;
6366
6367     PERL_ARGS_ASSERT_DOFILE;
6368
6369     if (!force_builtin && (gv = gv_override("do", 2))) {
6370         doop = S_new_entersubop(aTHX_ gv, term);
6371     }
6372     else {
6373         doop = newUNOP(OP_DOFILE, 0, scalar(term));
6374     }
6375     return doop;
6376 }
6377
6378 /*
6379 =head1 Optree construction
6380
6381 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
6382
6383 Constructs, checks, and returns an C<lslice> (list slice) op.  C<flags>
6384 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
6385 be set automatically, and, shifted up eight bits, the eight bits of
6386 C<op_private>, except that the bit with value 1 or 2 is automatically
6387 set as required.  C<listval> and C<subscript> supply the parameters of
6388 the slice; they are consumed by this function and become part of the
6389 constructed op tree.
6390
6391 =cut
6392 */
6393
6394 OP *
6395 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
6396 {
6397     return newBINOP(OP_LSLICE, flags,
6398             list(force_list(subscript, 1)),
6399             list(force_list(listval,   1)) );
6400 }
6401
6402 #define ASSIGN_LIST   1
6403 #define ASSIGN_REF    2
6404
6405 STATIC I32
6406 S_assignment_type(pTHX_ const OP *o)
6407 {
6408     unsigned type;
6409     U8 flags;
6410     U8 ret;
6411
6412     if (!o)
6413         return TRUE;
6414
6415     if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
6416         o = cUNOPo->op_first;
6417
6418     flags = o->op_flags;
6419     type = o->op_type;
6420     if (type == OP_COND_EXPR) {
6421         OP * const sib = OpSIBLING(cLOGOPo->op_first);
6422         const I32 t = assignment_type(sib);
6423         const I32 f = assignment_type(OpSIBLING(sib));
6424
6425         if (t == ASSIGN_LIST && f == ASSIGN_LIST)
6426             return ASSIGN_LIST;
6427         if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
6428             yyerror("Assignment to both a list and a scalar");
6429         return FALSE;
6430     }
6431
6432     if (type == OP_SREFGEN)
6433     {
6434         OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
6435         type = kid->op_type;
6436         flags |= kid->op_flags;
6437         if (!(flags & OPf_PARENS)
6438           && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
6439               kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
6440             return ASSIGN_REF;
6441         ret = ASSIGN_REF;
6442     }
6443     else ret = 0;
6444
6445     if (type == OP_LIST &&
6446         (flags & OPf_WANT) == OPf_WANT_SCALAR &&
6447         o->op_private & OPpLVAL_INTRO)
6448         return ret;
6449
6450     if (type == OP_LIST || flags & OPf_PARENS ||
6451         type == OP_RV2AV || type == OP_RV2HV ||
6452         type == OP_ASLICE || type == OP_HSLICE ||
6453         type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
6454         return TRUE;
6455
6456     if (type == OP_PADAV || type == OP_PADHV)
6457         return TRUE;
6458
6459     if (type == OP_RV2SV)
6460         return ret;
6461
6462     return ret;
6463 }
6464
6465
6466 /*
6467 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
6468
6469 Constructs, checks, and returns an assignment op.  C<left> and C<right>
6470 supply the parameters of the assignment; they are consumed by this
6471 function and become part of the constructed op tree.
6472
6473 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
6474 a suitable conditional optree is constructed.  If C<optype> is the opcode
6475 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
6476 performs the binary operation and assigns the result to the left argument.
6477 Either way, if C<optype> is non-zero then C<flags> has no effect.
6478
6479 If C<optype> is zero, then a plain scalar or list assignment is
6480 constructed.  Which type of assignment it is is automatically determined.
6481 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6482 will be set automatically, and, shifted up eight bits, the eight bits
6483 of C<op_private>, except that the bit with value 1 or 2 is automatically
6484 set as required.
6485
6486 =cut
6487 */
6488
6489 OP *
6490 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
6491 {
6492     OP *o;
6493     I32 assign_type;
6494
6495     if (optype) {
6496         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
6497             return newLOGOP(optype, 0,
6498                 op_lvalue(scalar(left), optype),
6499                 newUNOP(OP_SASSIGN, 0, scalar(right)));
6500         }
6501         else {
6502             return newBINOP(optype, OPf_STACKED,
6503                 op_lvalue(scalar(left), optype), scalar(right));
6504         }
6505     }
6506
6507     if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
6508         static const char no_list_state[] = "Initialization of state variables"
6509             " in list context currently forbidden";
6510         OP *curop;
6511
6512         if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
6513             left->op_private &= ~ OPpSLICEWARNING;
6514
6515         PL_modcount = 0;
6516         left = op_lvalue(left, OP_AASSIGN);
6517         curop = list(force_list(left, 1));
6518         o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
6519         o->op_private = (U8)(0 | (flags >> 8));
6520
6521         if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
6522         {
6523             OP* lop = ((LISTOP*)left)->op_first;
6524             while (lop) {
6525                 if ((lop->op_type == OP_PADSV ||
6526                      lop->op_type == OP_PADAV ||
6527                      lop->op_type == OP_PADHV ||
6528                      lop->op_type == OP_PADANY)
6529                   && (lop->op_private & OPpPAD_STATE)
6530                 )
6531                     yyerror(no_list_state);
6532                 lop = OpSIBLING(lop);
6533             }
6534         }
6535         else if (  (left->op_private & OPpLVAL_INTRO)
6536                 && (left->op_private & OPpPAD_STATE)
6537                 && (   left->op_type == OP_PADSV
6538                     || left->op_type == OP_PADAV
6539                     || left->op_type == OP_PADHV
6540                     || left->op_type == OP_PADANY)
6541         ) {
6542                 /* All single variable list context state assignments, hence
6543                    state ($a) = ...
6544                    (state $a) = ...
6545                    state @a = ...
6546                    state (@a) = ...
6547                    (state @a) = ...
6548                    state %a = ...
6549                    state (%a) = ...
6550                    (state %a) = ...
6551                 */
6552                 yyerror(no_list_state);
6553         }
6554
6555         if (right && right->op_type == OP_SPLIT
6556          && !(right->op_flags & OPf_STACKED)) {
6557             OP* tmpop = ((LISTOP*)right)->op_first;
6558             PMOP * const pm = (PMOP*)tmpop;
6559             assert (tmpop && (tmpop->op_type == OP_PUSHRE));
6560             if (
6561 #ifdef USE_ITHREADS
6562                     !pm->op_pmreplrootu.op_pmtargetoff
6563 #else
6564                     !pm->op_pmreplrootu.op_pmtargetgv
6565 #endif
6566                  && !pm->op_targ
6567                 ) {
6568                     if (!(left->op_private & OPpLVAL_INTRO) &&
6569                         ( (left->op_type == OP_RV2AV &&
6570                           (tmpop=((UNOP*)left)->op_first)->op_type==OP_GV)
6571                         || left->op_type == OP_PADAV )
6572                         ) {
6573                         if (tmpop != (OP *)pm) {
6574 #ifdef USE_ITHREADS
6575                           pm->op_pmreplrootu.op_pmtargetoff
6576                             = cPADOPx(tmpop)->op_padix;
6577                           cPADOPx(tmpop)->op_padix = 0; /* steal it */
6578 #else
6579                           pm->op_pmreplrootu.op_pmtargetgv
6580                             = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
6581                           cSVOPx(tmpop)->op_sv = NULL;  /* steal it */
6582 #endif
6583                           right->op_private |=
6584                             left->op_private & OPpOUR_INTRO;
6585                         }
6586                         else {
6587                             pm->op_targ = left->op_targ;
6588                             left->op_targ = 0; /* filch it */
6589                         }
6590                       detach_split:
6591                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
6592                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
6593                         /* detach rest of siblings from o subtree,
6594                          * and free subtree */
6595                         op_sibling_splice(cUNOPo->op_first, tmpop, -1, NULL);
6596                         op_free(o);                     /* blow off assign */
6597                         right->op_flags &= ~OPf_WANT;
6598                                 /* "I don't know and I don't care." */
6599                         return right;
6600                     }
6601                     else if (left->op_type == OP_RV2AV
6602                           || left->op_type == OP_PADAV)
6603                     {
6604                         /* Detach the array.  */
6605 #ifdef DEBUGGING
6606                         OP * const ary =
6607 #endif
6608                         op_sibling_splice(cBINOPo->op_last,
6609                                           cUNOPx(cBINOPo->op_last)
6610                                                 ->op_first, 1, NULL);
6611                         assert(ary == left);
6612                         /* Attach it to the split.  */
6613                         op_sibling_splice(right, cLISTOPx(right)->op_last,
6614                                           0, left);
6615                         right->op_flags |= OPf_STACKED;
6616                         /* Detach split and expunge aassign as above.  */
6617                         goto detach_split;
6618                     }
6619                     else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
6620                             ((LISTOP*)right)->op_last->op_type == OP_CONST)
6621                     {
6622                         SV ** const svp =
6623                             &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
6624                         SV * const sv = *svp;
6625                         if (SvIOK(sv) && SvIVX(sv) == 0)
6626                         {
6627                           if (right->op_private & OPpSPLIT_IMPLIM) {
6628                             /* our own SV, created in ck_split */
6629                             SvREADONLY_off(sv);
6630                             sv_setiv(sv, PL_modcount+1);
6631                           }
6632                           else {
6633                             /* SV may belong to someone else */
6634                             SvREFCNT_dec(sv);
6635                             *svp = newSViv(PL_modcount+1);
6636                           }
6637                         }
6638                     }
6639             }
6640         }
6641         return o;
6642     }
6643     if (assign_type == ASSIGN_REF)
6644         return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
6645     if (!right)
6646         right = newOP(OP_UNDEF, 0);
6647     if (right->op_type == OP_READLINE) {
6648         right->op_flags |= OPf_STACKED;
6649         return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
6650                 scalar(right));
6651     }
6652     else {
6653         o = newBINOP(OP_SASSIGN, flags,
6654             scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
6655     }
6656     return o;
6657 }
6658
6659 /*
6660 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
6661
6662 Constructs a state op (COP).  The state op is normally a C<nextstate> op,
6663 but will be a C<dbstate> op if debugging is enabled for currently-compiled
6664 code.  The state op is populated from C<PL_curcop> (or C<PL_compiling>).
6665 If C<label> is non-null, it supplies the name of a label to attach to
6666 the state op; this function takes ownership of the memory pointed at by
6667 C<label>, and will free it.  C<flags> gives the eight bits of C<op_flags>
6668 for the state op.
6669
6670 If C<o> is null, the state op is returned.  Otherwise the state op is
6671 combined with C<o> into a C<lineseq> list op, which is returned.  C<o>
6672 is consumed by this function and becomes part of the returned op tree.
6673
6674 =cut
6675 */
6676
6677 OP *
6678 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
6679 {
6680     dVAR;
6681     const U32 seq = intro_my();
6682     const U32 utf8 = flags & SVf_UTF8;
6683     COP *cop;
6684
6685     PL_parser->parsed_sub = 0;
6686
6687     flags &= ~SVf_UTF8;
6688
6689     NewOp(1101, cop, 1, COP);
6690     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
6691         OpTYPE_set(cop, OP_DBSTATE);
6692     }
6693     else {
6694         OpTYPE_set(cop, OP_NEXTSTATE);
6695     }
6696     cop->op_flags = (U8)flags;
6697     CopHINTS_set(cop, PL_hints);
6698 #ifdef VMS
6699     if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
6700 #endif
6701     cop->op_next = (OP*)cop;
6702
6703     cop->cop_seq = seq;
6704     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
6705     CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
6706     if (label) {
6707         Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
6708
6709         PL_hints |= HINT_BLOCK_SCOPE;
6710         /* It seems that we need to defer freeing this pointer, as other parts
6711            of the grammar end up wanting to copy it after this op has been
6712            created. */
6713         SAVEFREEPV(label);
6714     }
6715
6716     if (PL_parser->preambling != NOLINE) {
6717         CopLINE_set(cop, PL_parser->preambling);
6718         PL_parser->copline = NOLINE;
6719     }
6720     else if (PL_parser->copline == NOLINE)
6721         CopLINE_set(cop, CopLINE(PL_curcop));
6722     else {
6723         CopLINE_set(cop, PL_parser->copline);
6724         PL_parser->copline = NOLINE;
6725     }
6726 #ifdef USE_ITHREADS
6727     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
6728 #else
6729     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
6730 #endif
6731     CopSTASH_set(cop, PL_curstash);
6732
6733     if (cop->op_type == OP_DBSTATE) {
6734         /* this line can have a breakpoint - store the cop in IV */
6735         AV *av = CopFILEAVx(PL_curcop);
6736         if (av) {
6737             SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
6738             if (svp && *svp != &PL_sv_undef ) {
6739                 (void)SvIOK_on(*svp);
6740                 SvIV_set(*svp, PTR2IV(cop));
6741             }
6742         }
6743     }
6744
6745     if (flags & OPf_SPECIAL)
6746         op_null((OP*)cop);
6747     return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
6748 }
6749
6750 /*
6751 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
6752
6753 Constructs, checks, and returns a logical (flow control) op.  C<type>
6754 is the opcode.  C<flags> gives the eight bits of C<op_flags>, except
6755 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6756 the eight bits of C<op_private>, except that the bit with value 1 is
6757 automatically set.  C<first> supplies the expression controlling the
6758 flow, and C<other> supplies the side (alternate) chain of ops; they are
6759 consumed by this function and become part of the constructed op tree.
6760
6761 =cut
6762 */
6763
6764 OP *
6765 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
6766 {
6767     PERL_ARGS_ASSERT_NEWLOGOP;
6768
6769     return new_logop(type, flags, &first, &other);
6770 }
6771
6772 STATIC OP *
6773 S_search_const(pTHX_ OP *o)
6774 {
6775     PERL_ARGS_ASSERT_SEARCH_CONST;
6776
6777     switch (o->op_type) {
6778         case OP_CONST:
6779             return o;
6780         case OP_NULL:
6781             if (o->op_flags & OPf_KIDS)
6782                 return search_const(cUNOPo->op_first);
6783             break;
6784         case OP_LEAVE:
6785         case OP_SCOPE:
6786         case OP_LINESEQ:
6787         {
6788             OP *kid;
6789             if (!(o->op_flags & OPf_KIDS))
6790                 return NULL;
6791             kid = cLISTOPo->op_first;
6792             do {
6793                 switch (kid->op_type) {
6794                     case OP_ENTER:
6795                     case OP_NULL:
6796                     case OP_NEXTSTATE:
6797                         kid = OpSIBLING(kid);
6798                         break;
6799                     default:
6800                         if (kid != cLISTOPo->op_last)
6801                             return NULL;
6802                         goto last;
6803                 }
6804             } while (kid);
6805             if (!kid)
6806                 kid = cLISTOPo->op_last;
6807           last:
6808             return search_const(kid);
6809         }
6810     }
6811
6812     return NULL;
6813 }
6814
6815 STATIC OP *
6816 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
6817 {
6818     dVAR;
6819     LOGOP *logop;
6820     OP *o;
6821     OP *first;
6822     OP *other;
6823     OP *cstop = NULL;
6824     int prepend_not = 0;
6825
6826     PERL_ARGS_ASSERT_NEW_LOGOP;
6827
6828     first = *firstp;
6829     other = *otherp;
6830
6831     /* [perl #59802]: Warn about things like "return $a or $b", which
6832        is parsed as "(return $a) or $b" rather than "return ($a or
6833        $b)".  NB: This also applies to xor, which is why we do it
6834        here.
6835      */
6836     switch (first->op_type) {
6837     case OP_NEXT:
6838     case OP_LAST:
6839     case OP_REDO:
6840         /* XXX: Perhaps we should emit a stronger warning for these.
6841            Even with the high-precedence operator they don't seem to do
6842            anything sensible.
6843
6844            But until we do, fall through here.
6845          */
6846     case OP_RETURN:
6847     case OP_EXIT:
6848     case OP_DIE:
6849     case OP_GOTO:
6850         /* XXX: Currently we allow people to "shoot themselves in the
6851            foot" by explicitly writing "(return $a) or $b".
6852
6853            Warn unless we are looking at the result from folding or if
6854            the programmer explicitly grouped the operators like this.
6855            The former can occur with e.g.
6856
6857                 use constant FEATURE => ( $] >= ... );
6858                 sub { not FEATURE and return or do_stuff(); }
6859          */
6860         if (!first->op_folded && !(first->op_flags & OPf_PARENS))
6861             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6862                            "Possible precedence issue with control flow operator");
6863         /* XXX: Should we optimze this to "return $a;" (i.e. remove
6864            the "or $b" part)?
6865         */
6866         break;
6867     }
6868
6869     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
6870         return newBINOP(type, flags, scalar(first), scalar(other));
6871
6872     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
6873         || type == OP_CUSTOM);
6874
6875     scalarboolean(first);
6876
6877     /* search for a constant op that could let us fold the test */
6878     if ((cstop = search_const(first))) {
6879         if (cstop->op_private & OPpCONST_STRICT)
6880             no_bareword_allowed(cstop);
6881         else if ((cstop->op_private & OPpCONST_BARE))
6882                 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
6883         if ((type == OP_AND &&  SvTRUE(((SVOP*)cstop)->op_sv)) ||
6884             (type == OP_OR  && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
6885             (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
6886             /* Elide the (constant) lhs, since it can't affect the outcome */
6887             *firstp = NULL;
6888             if (other->op_type == OP_CONST)
6889                 other->op_private |= OPpCONST_SHORTCIRCUIT;
6890             op_free(first);
6891             if (other->op_type == OP_LEAVE)
6892                 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
6893             else if (other->op_type == OP_MATCH
6894                   || other->op_type == OP_SUBST
6895                   || other->op_type == OP_TRANSR
6896                   || other->op_type == OP_TRANS)
6897                 /* Mark the op as being unbindable with =~ */
6898                 other->op_flags |= OPf_SPECIAL;
6899
6900             other->op_folded = 1;
6901             return other;
6902         }
6903         else {
6904             /* Elide the rhs, since the outcome is entirely determined by
6905              * the (constant) lhs */
6906
6907             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
6908             const OP *o2 = other;
6909             if ( ! (o2->op_type == OP_LIST
6910                     && (( o2 = cUNOPx(o2)->op_first))
6911                     && o2->op_type == OP_PUSHMARK
6912                     && (( o2 = OpSIBLING(o2))) )
6913             )
6914                 o2 = other;
6915             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
6916                         || o2->op_type == OP_PADHV)
6917                 && o2->op_private & OPpLVAL_INTRO
6918                 && !(o2->op_private & OPpPAD_STATE))
6919             {
6920                 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6921                                  "Deprecated use of my() in false conditional");
6922             }
6923
6924             *otherp = NULL;
6925             if (cstop->op_type == OP_CONST)
6926                 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
6927             op_free(other);
6928             return first;
6929         }
6930     }
6931     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
6932         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
6933     {
6934         const OP * const k1 = ((UNOP*)first)->op_first;
6935         const OP * const k2 = OpSIBLING(k1);
6936         OPCODE warnop = 0;
6937         switch (first->op_type)
6938         {
6939         case OP_NULL:
6940             if (k2 && k2->op_type == OP_READLINE
6941                   && (k2->op_flags & OPf_STACKED)
6942                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6943             {
6944                 warnop = k2->op_type;
6945             }
6946             break;
6947
6948         case OP_SASSIGN:
6949             if (k1->op_type == OP_READDIR
6950                   || k1->op_type == OP_GLOB
6951                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6952                  || k1->op_type == OP_EACH
6953                  || k1->op_type == OP_AEACH)
6954             {
6955                 warnop = ((k1->op_type == OP_NULL)
6956                           ? (OPCODE)k1->op_targ : k1->op_type);
6957             }
6958             break;
6959         }
6960         if (warnop) {
6961             const line_t oldline = CopLINE(PL_curcop);
6962             /* This ensures that warnings are reported at the first line
6963                of the construction, not the last.  */
6964             CopLINE_set(PL_curcop, PL_parser->copline);
6965             Perl_warner(aTHX_ packWARN(WARN_MISC),
6966                  "Value of %s%s can be \"0\"; test with defined()",
6967                  PL_op_desc[warnop],
6968                  ((warnop == OP_READLINE || warnop == OP_GLOB)
6969                   ? " construct" : "() operator"));
6970             CopLINE_set(PL_curcop, oldline);
6971         }
6972     }
6973
6974     if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
6975         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
6976
6977     /* optimize AND and OR ops that have NOTs as children */
6978     if (first->op_type == OP_NOT
6979         && (first->op_flags & OPf_KIDS)
6980         && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
6981             || (other->op_type == OP_NOT))  /* if (!$x && !$y) { } */
6982         ) {
6983         if (type == OP_AND || type == OP_OR) {
6984             if (type == OP_AND)
6985                 type = OP_OR;
6986             else
6987                 type = OP_AND;
6988             op_null(first);
6989             if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
6990                 op_null(other);
6991                 prepend_not = 1; /* prepend a NOT op later */
6992             }
6993         }
6994     }
6995
6996     logop = S_alloc_LOGOP(aTHX_ type, first, LINKLIST(other));
6997     logop->op_flags |= (U8)flags;
6998     logop->op_private = (U8)(1 | (flags >> 8));
6999
7000     /* establish postfix order */
7001     logop->op_next = LINKLIST(first);
7002     first->op_next = (OP*)logop;
7003     assert(!OpHAS_SIBLING(first));
7004     op_sibling_splice((OP*)logop, first, 0, other);
7005
7006     CHECKOP(type,logop);
7007
7008     o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
7009                 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
7010                 (OP*)logop);
7011     other->op_next = o;
7012
7013     return o;
7014 }
7015
7016 /*
7017 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
7018
7019 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
7020 op.  C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
7021 will be set automatically, and, shifted up eight bits, the eight bits of
7022 C<op_private>, except that the bit with value 1 is automatically set.
7023 C<first> supplies the expression selecting between the two branches,
7024 and C<trueop> and C<falseop> supply the branches; they are consumed by
7025 this function and become part of the constructed op tree.
7026
7027 =cut
7028 */
7029
7030 OP *
7031 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
7032 {
7033     dVAR;
7034     LOGOP *logop;
7035     OP *start;
7036     OP *o;
7037     OP *cstop;
7038
7039     PERL_ARGS_ASSERT_NEWCONDOP;
7040
7041     if (!falseop)
7042         return newLOGOP(OP_AND, 0, first, trueop);
7043     if (!trueop)
7044         return newLOGOP(OP_OR, 0, first, falseop);
7045
7046     scalarboolean(first);
7047     if ((cstop = search_const(first))) {
7048         /* Left or right arm of the conditional?  */
7049         const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
7050         OP *live = left ? trueop : falseop;
7051         OP *const dead = left ? falseop : trueop;
7052         if (cstop->op_private & OPpCONST_BARE &&
7053             cstop->op_private & OPpCONST_STRICT) {
7054             no_bareword_allowed(cstop);
7055         }
7056         op_free(first);
7057         op_free(dead);
7058         if (live->op_type == OP_LEAVE)
7059             live = newUNOP(OP_NULL, OPf_SPECIAL, live);
7060         else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
7061               || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
7062             /* Mark the op as being unbindable with =~ */
7063             live->op_flags |= OPf_SPECIAL;
7064         live->op_folded = 1;
7065         return live;
7066     }
7067     logop = S_alloc_LOGOP(aTHX_ OP_COND_EXPR, first, LINKLIST(trueop));
7068     logop->op_flags |= (U8)flags;
7069     logop->op_private = (U8)(1 | (flags >> 8));
7070     logop->op_next = LINKLIST(falseop);
7071
7072     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
7073             logop);
7074
7075     /* establish postfix order */
7076     start = LINKLIST(first);
7077     first->op_next = (OP*)logop;
7078
7079     /* make first, trueop, falseop siblings */
7080     op_sibling_splice((OP*)logop, first,  0, trueop);
7081     op_sibling_splice((OP*)logop, trueop, 0, falseop);
7082
7083     o = newUNOP(OP_NULL, 0, (OP*)logop);
7084
7085     trueop->op_next = falseop->op_next = o;
7086
7087     o->op_next = start;
7088     return o;
7089 }
7090
7091 /*
7092 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
7093
7094 Constructs and returns a C<range> op, with subordinate C<flip> and
7095 C<flop> ops.  C<flags> gives the eight bits of C<op_flags> for the
7096 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
7097 for both the C<flip> and C<range> ops, except that the bit with value
7098 1 is automatically set.  C<left> and C<right> supply the expressions
7099 controlling the endpoints of the range; they are consumed by this function
7100 and become part of the constructed op tree.
7101
7102 =cut
7103 */
7104
7105 OP *
7106 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
7107 {
7108     LOGOP *range;
7109     OP *flip;
7110     OP *flop;
7111     OP *leftstart;
7112     OP *o;
7113
7114     PERL_ARGS_ASSERT_NEWRANGE;
7115
7116     range = S_alloc_LOGOP(aTHX_ OP_RANGE, left, LINKLIST(right));
7117     range->op_flags = OPf_KIDS;
7118     leftstart = LINKLIST(left);
7119     range->op_private = (U8)(1 | (flags >> 8));
7120
7121     /* make left and right siblings */
7122     op_sibling_splice((OP*)range, left, 0, right);
7123
7124     range->op_next = (OP*)range;
7125     flip = newUNOP(OP_FLIP, flags, (OP*)range);
7126     flop = newUNOP(OP_FLOP, 0, flip);
7127     o = newUNOP(OP_NULL, 0, flop);
7128     LINKLIST(flop);
7129     range->op_next = leftstart;
7130
7131     left->op_next = flip;
7132     right->op_next = flop;
7133
7134     range->op_targ =
7135         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
7136     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
7137     flip->op_targ =
7138         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
7139     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
7140     SvPADTMP_on(PAD_SV(flip->op_targ));
7141
7142     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
7143     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
7144
7145     /* check barewords before they might be optimized aways */
7146     if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
7147         no_bareword_allowed(left);
7148     if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
7149         no_bareword_allowed(right);
7150
7151     flip->op_next = o;
7152     if (!flip->op_private || !flop->op_private)
7153         LINKLIST(o);            /* blow off optimizer unless constant */
7154
7155     return o;
7156 }
7157
7158 /*
7159 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
7160
7161 Constructs, checks, and returns an op tree expressing a loop.  This is
7162 only a loop in the control flow through the op tree; it does not have
7163 the heavyweight loop structure that allows exiting the loop by C<last>
7164 and suchlike.  C<flags> gives the eight bits of C<op_flags> for the
7165 top-level op, except that some bits will be set automatically as required.
7166 C<expr> supplies the expression controlling loop iteration, and C<block>
7167 supplies the body of the loop; they are consumed by this function and
7168 become part of the constructed op tree.  C<debuggable> is currently
7169 unused and should always be 1.
7170
7171 =cut
7172 */
7173
7174 OP *
7175 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
7176 {
7177     OP* listop;
7178     OP* o;
7179     const bool once = block && block->op_flags & OPf_SPECIAL &&
7180                       block->op_type == OP_NULL;
7181
7182     PERL_UNUSED_ARG(debuggable);
7183
7184     if (expr) {
7185         if (once && (
7186               (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
7187            || (  expr->op_type == OP_NOT
7188               && cUNOPx(expr)->op_first->op_type == OP_CONST
7189               && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
7190               )
7191            ))
7192             /* Return the block now, so that S_new_logop does not try to
7193                fold it away. */
7194             return block;       /* do {} while 0 does once */
7195         if (expr->op_type == OP_READLINE
7196             || expr->op_type == OP_READDIR
7197             || expr->op_type == OP_GLOB
7198             || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
7199             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
7200             expr = newUNOP(OP_DEFINED, 0,
7201                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
7202         } else if (expr->op_flags & OPf_KIDS) {
7203             const OP * const k1 = ((UNOP*)expr)->op_first;
7204             const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
7205             switch (expr->op_type) {
7206               case OP_NULL:
7207                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
7208                       && (k2->op_flags & OPf_STACKED)
7209                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7210                     expr = newUNOP(OP_DEFINED, 0, expr);
7211                 break;
7212
7213               case OP_SASSIGN:
7214                 if (k1 && (k1->op_type == OP_READDIR
7215                       || k1->op_type == OP_GLOB
7216                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7217                      || k1->op_type == OP_EACH
7218                      || k1->op_type == OP_AEACH))
7219                     expr = newUNOP(OP_DEFINED, 0, expr);
7220                 break;
7221             }
7222         }
7223     }
7224
7225     /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
7226      * op, in listop. This is wrong. [perl #27024] */
7227     if (!block)
7228         block = newOP(OP_NULL, 0);
7229     listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
7230     o = new_logop(OP_AND, 0, &expr, &listop);
7231
7232     if (once) {
7233         ASSUME(listop);
7234     }
7235
7236     if (listop)
7237         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
7238
7239     if (once && o != listop)
7240     {
7241         assert(cUNOPo->op_first->op_type == OP_AND
7242             || cUNOPo->op_first->op_type == OP_OR);
7243         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
7244     }
7245
7246     if (o == listop)
7247         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
7248
7249     o->op_flags |= flags;
7250     o = op_scope(o);
7251     o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
7252     return o;
7253 }
7254
7255 /*
7256 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
7257
7258 Constructs, checks, and returns an op tree expressing a C<while> loop.
7259 This is a heavyweight loop, with structure that allows exiting the loop
7260 by C<last> and suchlike.
7261
7262 C<loop> is an optional preconstructed C<enterloop> op to use in the
7263 loop; if it is null then a suitable op will be constructed automatically.
7264 C<expr> supplies the loop's controlling expression.  C<block> supplies the
7265 main body of the loop, and C<cont> optionally supplies a C<continue> block
7266 that operates as a second half of the body.  All of these optree inputs
7267 are consumed by this function and become part of the constructed op tree.
7268
7269 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7270 op and, shifted up eight bits, the eight bits of C<op_private> for
7271 the C<leaveloop> op, except that (in both cases) some bits will be set
7272 automatically.  C<debuggable> is currently unused and should always be 1.
7273 C<has_my> can be supplied as true to force the
7274 loop body to be enclosed in its own scope.
7275
7276 =cut
7277 */
7278
7279 OP *
7280 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
7281         OP *expr, OP *block, OP *cont, I32 has_my)
7282 {
7283     dVAR;
7284     OP *redo;
7285     OP *next = NULL;
7286     OP *listop;
7287     OP *o;
7288     U8 loopflags = 0;
7289
7290     PERL_UNUSED_ARG(debuggable);
7291
7292     if (expr) {
7293         if (expr->op_type == OP_READLINE
7294          || expr->op_type == OP_READDIR
7295          || expr->op_type == OP_GLOB
7296          || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
7297                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
7298             expr = newUNOP(OP_DEFINED, 0,
7299                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
7300         } else if (expr->op_flags & OPf_KIDS) {
7301             const OP * const k1 = ((UNOP*)expr)->op_first;
7302             const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
7303             switch (expr->op_type) {
7304               case OP_NULL:
7305                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
7306                       && (k2->op_flags & OPf_STACKED)
7307                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7308                     expr = newUNOP(OP_DEFINED, 0, expr);
7309                 break;
7310
7311               case OP_SASSIGN:
7312                 if (k1 && (k1->op_type == OP_READDIR
7313                       || k1->op_type == OP_GLOB
7314                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7315                      || k1->op_type == OP_EACH
7316                      || k1->op_type == OP_AEACH))
7317                     expr = newUNOP(OP_DEFINED, 0, expr);
7318                 break;
7319             }
7320         }
7321     }
7322
7323     if (!block)
7324         block = newOP(OP_NULL, 0);
7325     else if (cont || has_my) {
7326         block = op_scope(block);
7327     }
7328
7329     if (cont) {
7330         next = LINKLIST(cont);
7331     }
7332     if (expr) {
7333         OP * const unstack = newOP(OP_UNSTACK, 0);
7334         if (!next)
7335             next = unstack;
7336         cont = op_append_elem(OP_LINESEQ, cont, unstack);
7337     }
7338
7339     assert(block);
7340     listop = op_append_list(OP_LINESEQ, block, cont);
7341     assert(listop);
7342     redo = LINKLIST(listop);
7343
7344     if (expr) {
7345         scalar(listop);
7346         o = new_logop(OP_AND, 0, &expr, &listop);
7347         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
7348             op_free((OP*)loop);
7349             return expr;                /* listop already freed by new_logop */
7350         }
7351         if (listop)
7352             ((LISTOP*)listop)->op_last->op_next =
7353                 (o == listop ? redo : LINKLIST(o));
7354     }
7355     else
7356         o = listop;
7357
7358     if (!loop) {
7359         NewOp(1101,loop,1,LOOP);
7360         OpTYPE_set(loop, OP_ENTERLOOP);
7361         loop->op_private = 0;
7362         loop->op_next = (OP*)loop;
7363     }
7364
7365     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
7366
7367     loop->op_redoop = redo;
7368     loop->op_lastop = o;
7369     o->op_private |= loopflags;
7370
7371     if (next)
7372         loop->op_nextop = next;
7373     else
7374         loop->op_nextop = o;
7375
7376     o->op_flags |= flags;
7377     o->op_private |= (flags >> 8);
7378     return o;
7379 }
7380
7381 /*
7382 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
7383
7384 Constructs, checks, and returns an op tree expressing a C<foreach>
7385 loop (iteration through a list of values).  This is a heavyweight loop,
7386 with structure that allows exiting the loop by C<last> and suchlike.
7387
7388 C<sv> optionally supplies the variable that will be aliased to each
7389 item in turn; if null, it defaults to C<$_>.
7390 C<expr> supplies the list of values to iterate over.  C<block> supplies
7391 the main body of the loop, and C<cont> optionally supplies a C<continue>
7392 block that operates as a second half of the body.  All of these optree
7393 inputs are consumed by this function and become part of the constructed
7394 op tree.
7395
7396 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7397 op and, shifted up eight bits, the eight bits of C<op_private> for
7398 the C<leaveloop> op, except that (in both cases) some bits will be set
7399 automatically.
7400
7401 =cut
7402 */
7403
7404 OP *
7405 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
7406 {
7407     dVAR;
7408     LOOP *loop;
7409     OP *wop;
7410     PADOFFSET padoff = 0;
7411     I32 iterflags = 0;
7412     I32 iterpflags = 0;
7413
7414     PERL_ARGS_ASSERT_NEWFOROP;
7415
7416     if (sv) {
7417         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
7418             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
7419             OpTYPE_set(sv, OP_RV2GV);
7420
7421             /* The op_type check is needed to prevent a possible segfault
7422              * if the loop variable is undeclared and 'strict vars' is in
7423              * effect. This is illegal but is nonetheless parsed, so we
7424              * may reach this point with an OP_CONST where we're expecting
7425              * an OP_GV.
7426              */
7427             if (cUNOPx(sv)->op_first->op_type == OP_GV
7428              && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
7429                 iterpflags |= OPpITER_DEF;
7430         }
7431         else if (sv->op_type == OP_PADSV) { /* private variable */
7432             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
7433             padoff = sv->op_targ;
7434             sv->op_targ = 0;
7435             op_free(sv);
7436             sv = NULL;
7437             PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
7438         }
7439         else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
7440             NOOP;
7441         else
7442             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
7443         if (padoff) {
7444             PADNAME * const pn = PAD_COMPNAME(padoff);
7445             const char * const name = PadnamePV(pn);
7446
7447             if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
7448                 iterpflags |= OPpITER_DEF;
7449         }
7450     }
7451     else {
7452         sv = newGVOP(OP_GV, 0, PL_defgv);
7453         iterpflags |= OPpITER_DEF;
7454     }
7455
7456     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
7457         expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
7458         iterflags |= OPf_STACKED;
7459     }
7460     else if (expr->op_type == OP_NULL &&
7461              (expr->op_flags & OPf_KIDS) &&
7462              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
7463     {
7464         /* Basically turn for($x..$y) into the same as for($x,$y), but we
7465          * set the STACKED flag to indicate that these values are to be
7466          * treated as min/max values by 'pp_enteriter'.
7467          */
7468         const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
7469         LOGOP* const range = (LOGOP*) flip->op_first;
7470         OP* const left  = range->op_first;
7471         OP* const right = OpSIBLING(left);
7472         LISTOP* listop;
7473
7474         range->op_flags &= ~OPf_KIDS;
7475         /* detach range's children */
7476         op_sibling_splice((OP*)range, NULL, -1, NULL);
7477
7478         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
7479         listop->op_first->op_next = range->op_next;
7480         left->op_next = range->op_other;
7481         right->op_next = (OP*)listop;
7482         listop->op_next = listop->op_first;
7483
7484         op_free(expr);
7485         expr = (OP*)(listop);
7486         op_null(expr);
7487         iterflags |= OPf_STACKED;
7488     }
7489     else {
7490         expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
7491     }
7492
7493     loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
7494                                   op_append_elem(OP_LIST, list(expr),
7495                                                  scalar(sv)));
7496     assert(!loop->op_next);
7497     /* for my  $x () sets OPpLVAL_INTRO;
7498      * for our $x () sets OPpOUR_INTRO */
7499     loop->op_private = (U8)iterpflags;
7500     if (loop->op_slabbed
7501      && DIFF(loop, OpSLOT(loop)->opslot_next)
7502          < SIZE_TO_PSIZE(sizeof(LOOP)))
7503     {
7504         LOOP *tmp;
7505         NewOp(1234,tmp,1,LOOP);
7506         Copy(loop,tmp,1,LISTOP);
7507 #ifdef PERL_OP_PARENT
7508         assert(loop->op_last->op_sibparent == (OP*)loop);
7509         OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
7510 #endif
7511         S_op_destroy(aTHX_ (OP*)loop);
7512         loop = tmp;
7513     }
7514     else if (!loop->op_slabbed)
7515     {
7516         loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
7517 #ifdef PERL_OP_PARENT
7518         OpLASTSIB_set(loop->op_last, (OP*)loop);
7519 #endif
7520     }
7521     loop->op_targ = padoff;
7522     wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
7523     return wop;
7524 }
7525
7526 /*
7527 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
7528
7529 Constructs, checks, and returns a loop-exiting op (such as C<goto>
7530 or C<last>).  C<type> is the opcode.  C<label> supplies the parameter
7531 determining the target of the op; it is consumed by this function and
7532 becomes part of the constructed op tree.
7533
7534 =cut
7535 */
7536
7537 OP*
7538 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
7539 {
7540     OP *o = NULL;
7541
7542     PERL_ARGS_ASSERT_NEWLOOPEX;
7543
7544     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
7545         || type == OP_CUSTOM);
7546
7547     if (type != OP_GOTO) {
7548         /* "last()" means "last" */
7549         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
7550             o = newOP(type, OPf_SPECIAL);
7551         }
7552     }
7553     else {
7554         /* Check whether it's going to be a goto &function */
7555         if (label->op_type == OP_ENTERSUB
7556                 && !(label->op_flags & OPf_STACKED))
7557             label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
7558     }
7559
7560     /* Check for a constant argument */
7561     if (label->op_type == OP_CONST) {
7562             SV * const sv = ((SVOP *)label)->op_sv;
7563             STRLEN l;
7564             const char *s = SvPV_const(sv,l);
7565             if (l == strlen(s)) {
7566                 o = newPVOP(type,
7567                             SvUTF8(((SVOP*)label)->op_sv),
7568                             savesharedpv(
7569                                 SvPV_nolen_const(((SVOP*)label)->op_sv)));
7570             }
7571     }
7572
7573     /* If we have already created an op, we do not need the label. */
7574     if (o)
7575                 op_free(label);
7576     else o = newUNOP(type, OPf_STACKED, label);
7577
7578     PL_hints |= HINT_BLOCK_SCOPE;
7579     return o;
7580 }
7581
7582 /* if the condition is a literal array or hash
7583    (or @{ ... } etc), make a reference to it.
7584  */
7585 STATIC OP *
7586 S_ref_array_or_hash(pTHX_ OP *cond)
7587 {
7588     if (cond
7589     && (cond->op_type == OP_RV2AV
7590     ||  cond->op_type == OP_PADAV
7591     ||  cond->op_type == OP_RV2HV
7592     ||  cond->op_type == OP_PADHV))
7593
7594         return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
7595
7596     else if(cond
7597     && (cond->op_type == OP_ASLICE
7598     ||  cond->op_type == OP_KVASLICE
7599     ||  cond->op_type == OP_HSLICE
7600     ||  cond->op_type == OP_KVHSLICE)) {
7601
7602         /* anonlist now needs a list from this op, was previously used in
7603          * scalar context */
7604         cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
7605         cond->op_flags |= OPf_WANT_LIST;
7606
7607         return newANONLIST(op_lvalue(cond, OP_ANONLIST));
7608     }
7609
7610     else
7611         return cond;
7612 }
7613
7614 /* These construct the optree fragments representing given()
7615    and when() blocks.
7616
7617    entergiven and enterwhen are LOGOPs; the op_other pointer
7618    points up to the associated leave op. We need this so we
7619    can put it in the context and make break/continue work.
7620    (Also, of course, pp_enterwhen will jump straight to
7621    op_other if the match fails.)
7622  */
7623
7624 STATIC OP *
7625 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
7626                    I32 enter_opcode, I32 leave_opcode,
7627                    PADOFFSET entertarg)
7628 {
7629     dVAR;
7630     LOGOP *enterop;
7631     OP *o;
7632
7633     PERL_ARGS_ASSERT_NEWGIVWHENOP;
7634     PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
7635
7636     enterop = S_alloc_LOGOP(aTHX_ enter_opcode, block, NULL);
7637     enterop->op_targ = 0;
7638     enterop->op_private = 0;
7639
7640     o = newUNOP(leave_opcode, 0, (OP *) enterop);
7641
7642     if (cond) {
7643         /* prepend cond if we have one */
7644         op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
7645
7646         o->op_next = LINKLIST(cond);
7647         cond->op_next = (OP *) enterop;
7648     }
7649     else {
7650         /* This is a default {} block */
7651         enterop->op_flags |= OPf_SPECIAL;
7652         o      ->op_flags |= OPf_SPECIAL;
7653
7654         o->op_next = (OP *) enterop;
7655     }
7656
7657     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
7658                                        entergiven and enterwhen both
7659                                        use ck_null() */
7660
7661     enterop->op_next = LINKLIST(block);
7662     block->op_next = enterop->op_other = o;
7663
7664     return o;
7665 }
7666
7667 /* Does this look like a boolean operation? For these purposes
7668    a boolean operation is:
7669      - a subroutine call [*]
7670      - a logical connective
7671      - a comparison operator
7672      - a filetest operator, with the exception of -s -M -A -C
7673      - defined(), exists() or eof()
7674      - /$re/ or $foo =~ /$re/
7675
7676    [*] possibly surprising
7677  */
7678 STATIC bool
7679 S_looks_like_bool(pTHX_ const OP *o)
7680 {
7681     PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
7682
7683     switch(o->op_type) {
7684         case OP_OR:
7685         case OP_DOR:
7686             return looks_like_bool(cLOGOPo->op_first);
7687
7688         case OP_AND:
7689         {
7690             OP* sibl = OpSIBLING(cLOGOPo->op_first);
7691             ASSUME(sibl);
7692             return (
7693                 looks_like_bool(cLOGOPo->op_first)
7694              && looks_like_bool(sibl));
7695         }
7696
7697         case OP_NULL:
7698         case OP_SCALAR:
7699             return (
7700                 o->op_flags & OPf_KIDS
7701             && looks_like_bool(cUNOPo->op_first));
7702
7703         case OP_ENTERSUB:
7704
7705         case OP_NOT:    case OP_XOR:
7706
7707         case OP_EQ:     case OP_NE:     case OP_LT:
7708         case OP_GT:     case OP_LE:     case OP_GE:
7709
7710         case OP_I_EQ:   case OP_I_NE:   case OP_I_LT:
7711         case OP_I_GT:   case OP_I_LE:   case OP_I_GE:
7712
7713         case OP_SEQ:    case OP_SNE:    case OP_SLT:
7714         case OP_SGT:    case OP_SLE:    case OP_SGE:
7715
7716         case OP_SMARTMATCH:
7717
7718         case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
7719         case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
7720         case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
7721         case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
7722         case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
7723         case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
7724         case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
7725         case OP_FTTEXT:   case OP_FTBINARY:
7726
7727         case OP_DEFINED: case OP_EXISTS:
7728         case OP_MATCH:   case OP_EOF:
7729
7730         case OP_FLOP:
7731
7732             return TRUE;
7733
7734         case OP_CONST:
7735             /* Detect comparisons that have been optimized away */
7736             if (cSVOPo->op_sv == &PL_sv_yes
7737             ||  cSVOPo->op_sv == &PL_sv_no)
7738
7739                 return TRUE;
7740             else
7741                 return FALSE;
7742
7743         /* FALLTHROUGH */
7744         default:
7745             return FALSE;
7746     }
7747 }
7748
7749 /*
7750 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
7751
7752 Constructs, checks, and returns an op tree expressing a C<given> block.
7753 C<cond> supplies the expression that will be locally assigned to a lexical
7754 variable, and C<block> supplies the body of the C<given> construct; they
7755 are consumed by this function and become part of the constructed op tree.
7756 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
7757
7758 =cut
7759 */
7760
7761 OP *
7762 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
7763 {
7764     PERL_ARGS_ASSERT_NEWGIVENOP;
7765     PERL_UNUSED_ARG(defsv_off);
7766
7767     assert(!defsv_off);
7768     return newGIVWHENOP(
7769         ref_array_or_hash(cond),
7770         block,
7771         OP_ENTERGIVEN, OP_LEAVEGIVEN,
7772         0);
7773 }
7774
7775 /*
7776 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
7777
7778 Constructs, checks, and returns an op tree expressing a C<when> block.
7779 C<cond> supplies the test expression, and C<block> supplies the block
7780 that will be executed if the test evaluates to true; they are consumed
7781 by this function and become part of the constructed op tree.  C<cond>
7782 will be interpreted DWIMically, often as a comparison against C<$_>,
7783 and may be null to generate a C<default> block.
7784
7785 =cut
7786 */
7787
7788 OP *
7789 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
7790 {
7791     const bool cond_llb = (!cond || looks_like_bool(cond));
7792     OP *cond_op;
7793
7794     PERL_ARGS_ASSERT_NEWWHENOP;
7795
7796     if (cond_llb)
7797         cond_op = cond;
7798     else {
7799         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
7800                 newDEFSVOP(),
7801                 scalar(ref_array_or_hash(cond)));
7802     }
7803
7804     return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
7805 }
7806
7807 /* must not conflict with SVf_UTF8 */
7808 #define CV_CKPROTO_CURSTASH     0x1
7809
7810 void
7811 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
7812                     const STRLEN len, const U32 flags)
7813 {
7814     SV *name = NULL, *msg;
7815     const char * cvp = SvROK(cv)
7816                         ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
7817                            ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
7818                            : ""
7819                         : CvPROTO(cv);
7820     STRLEN clen = CvPROTOLEN(cv), plen = len;
7821
7822     PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
7823
7824     if (p == NULL && cvp == NULL)
7825         return;
7826
7827     if (!ckWARN_d(WARN_PROTOTYPE))
7828         return;
7829
7830     if (p && cvp) {
7831         p = S_strip_spaces(aTHX_ p, &plen);
7832         cvp = S_strip_spaces(aTHX_ cvp, &clen);
7833         if ((flags & SVf_UTF8) == SvUTF8(cv)) {
7834             if (plen == clen && memEQ(cvp, p, plen))
7835                 return;
7836         } else {
7837             if (flags & SVf_UTF8) {
7838                 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
7839                     return;
7840             }
7841             else {
7842                 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
7843                     return;
7844             }
7845         }
7846     }
7847
7848     msg = sv_newmortal();
7849
7850     if (gv)
7851     {
7852         if (isGV(gv))
7853             gv_efullname3(name = sv_newmortal(), gv, NULL);
7854         else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
7855             name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
7856         else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
7857             name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
7858             sv_catpvs(name, "::");
7859             if (SvROK(gv)) {
7860                 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
7861                 assert (CvNAMED(SvRV_const(gv)));
7862                 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
7863             }
7864             else sv_catsv(name, (SV *)gv);
7865         }
7866         else name = (SV *)gv;
7867     }
7868     sv_setpvs(msg, "Prototype mismatch:");
7869     if (name)
7870         Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
7871     if (cvp)
7872         Perl_sv_catpvf(aTHX_ msg, " (%"UTF8f")",
7873             UTF8fARG(SvUTF8(cv),clen,cvp)
7874         );
7875     else
7876         sv_catpvs(msg, ": none");
7877     sv_catpvs(msg, " vs ");
7878     if (p)
7879         Perl_sv_catpvf(aTHX_ msg, "(%"UTF8f")", UTF8fARG(flags & SVf_UTF8,len,p));
7880     else
7881         sv_catpvs(msg, "none");
7882     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
7883 }
7884
7885 static void const_sv_xsub(pTHX_ CV* cv);
7886 static void const_av_xsub(pTHX_ CV* cv);
7887
7888 /*
7889
7890 =head1 Optree Manipulation Functions
7891
7892 =for apidoc cv_const_sv
7893
7894 If C<cv> is a constant sub eligible for inlining, returns the constant
7895 value returned by the sub.  Otherwise, returns C<NULL>.
7896
7897 Constant subs can be created with C<newCONSTSUB> or as described in
7898 L<perlsub/"Constant Functions">.
7899
7900 =cut
7901 */
7902 SV *
7903 Perl_cv_const_sv(const CV *const cv)
7904 {
7905     SV *sv;
7906     if (!cv)
7907         return NULL;
7908     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
7909         return NULL;
7910     sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7911     if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
7912     return sv;
7913 }
7914
7915 SV *
7916 Perl_cv_const_sv_or_av(const CV * const cv)
7917 {
7918     if (!cv)
7919         return NULL;
7920     if (SvROK(cv)) return SvRV((SV *)cv);
7921     assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
7922     return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7923 }
7924
7925 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
7926  * Can be called in 2 ways:
7927  *
7928  * !allow_lex
7929  *      look for a single OP_CONST with attached value: return the value
7930  *
7931  * allow_lex && !CvCONST(cv);
7932  *
7933  *      examine the clone prototype, and if contains only a single
7934  *      OP_CONST, return the value; or if it contains a single PADSV ref-
7935  *      erencing an outer lexical, turn on CvCONST to indicate the CV is
7936  *      a candidate for "constizing" at clone time, and return NULL.
7937  */
7938
7939 static SV *
7940 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
7941 {
7942     SV *sv = NULL;
7943     bool padsv = FALSE;
7944
7945     assert(o);
7946     assert(cv);
7947
7948     for (; o; o = o->op_next) {
7949         const OPCODE type = o->op_type;
7950
7951         if (type == OP_NEXTSTATE || type == OP_LINESEQ
7952              || type == OP_NULL
7953              || type == OP_PUSHMARK)
7954                 continue;
7955         if (type == OP_DBSTATE)
7956                 continue;
7957         if (type == OP_LEAVESUB)
7958             break;
7959         if (sv)
7960             return NULL;
7961         if (type == OP_CONST && cSVOPo->op_sv)
7962             sv = cSVOPo->op_sv;
7963         else if (type == OP_UNDEF && !o->op_private) {
7964             sv = newSV(0);
7965             SAVEFREESV(sv);
7966         }
7967         else if (allow_lex && type == OP_PADSV) {
7968                 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
7969                 {
7970                     sv = &PL_sv_undef; /* an arbitrary non-null value */
7971                     padsv = TRUE;
7972                 }
7973                 else
7974                     return NULL;
7975         }
7976         else {
7977             return NULL;
7978         }
7979     }
7980     if (padsv) {
7981         CvCONST_on(cv);
7982         return NULL;
7983     }
7984     return sv;
7985 }
7986
7987 static bool
7988 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
7989                         PADNAME * const name, SV ** const const_svp)
7990 {
7991     assert (cv);
7992     assert (o || name);
7993     assert (const_svp);
7994     if ((!block
7995          )) {
7996         if (CvFLAGS(PL_compcv)) {
7997             /* might have had built-in attrs applied */
7998             const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
7999             if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
8000              && ckWARN(WARN_MISC))
8001             {
8002                 /* protect against fatal warnings leaking compcv */
8003                 SAVEFREESV(PL_compcv);
8004                 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
8005                 SvREFCNT_inc_simple_void_NN(PL_compcv);
8006             }
8007             CvFLAGS(cv) |=
8008                 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
8009                   & ~(CVf_LVALUE * pureperl));
8010         }
8011         return FALSE;
8012     }
8013
8014     /* redundant check for speed: */
8015     if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
8016         const line_t oldline = CopLINE(PL_curcop);
8017         SV *namesv = o
8018             ? cSVOPo->op_sv
8019             : sv_2mortal(newSVpvn_utf8(
8020                 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
8021               ));
8022         if (PL_parser && PL_parser->copline != NOLINE)
8023             /* This ensures that warnings are reported at the first
8024                line of a redefinition, not the last.  */
8025             CopLINE_set(PL_curcop, PL_parser->copline);
8026         /* protect against fatal warnings leaking compcv */
8027         SAVEFREESV(PL_compcv);
8028         report_redefined_cv(namesv, cv, const_svp);
8029         SvREFCNT_inc_simple_void_NN(PL_compcv);
8030         CopLINE_set(PL_curcop, oldline);
8031     }
8032     SAVEFREESV(cv);
8033     return TRUE;
8034 }
8035
8036 CV *
8037 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
8038 {
8039     CV **spot;
8040     SV **svspot;
8041     const char *ps;
8042     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
8043     U32 ps_utf8 = 0;
8044     CV *cv = NULL;
8045     CV *compcv = PL_compcv;
8046     SV *const_sv;
8047     PADNAME *name;
8048     PADOFFSET pax = o->op_targ;
8049     CV *outcv = CvOUTSIDE(PL_compcv);
8050     CV *clonee = NULL;
8051     HEK *hek = NULL;
8052     bool reusable = FALSE;
8053     OP *start = NULL;
8054 #ifdef PERL_DEBUG_READONLY_OPS
8055     OPSLAB *slab = NULL;
8056 #endif
8057
8058     PERL_ARGS_ASSERT_NEWMYSUB;
8059
8060     /* Find the pad slot for storing the new sub.
8061        We cannot use PL_comppad, as it is the pad owned by the new sub.  We
8062        need to look in CvOUTSIDE and find the pad belonging to the enclos-
8063        ing sub.  And then we need to dig deeper if this is a lexical from
8064        outside, as in:
8065            my sub foo; sub { sub foo { } }
8066      */
8067    redo:
8068     name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
8069     if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
8070         pax = PARENT_PAD_INDEX(name);
8071         outcv = CvOUTSIDE(outcv);
8072         assert(outcv);
8073         goto redo;
8074     }
8075     svspot =
8076         &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
8077                         [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
8078     spot = (CV **)svspot;
8079
8080     if (!(PL_parser && PL_parser->error_count))
8081         move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name));
8082
8083     if (proto) {
8084         assert(proto->op_type == OP_CONST);
8085         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
8086         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
8087     }
8088     else
8089         ps = NULL;
8090
8091     if (proto)
8092         SAVEFREEOP(proto);
8093     if (attrs)
8094         SAVEFREEOP(attrs);
8095
8096     if (PL_parser && PL_parser->error_count) {
8097         op_free(block);
8098         SvREFCNT_dec(PL_compcv);
8099         PL_compcv = 0;
8100         goto done;
8101     }
8102
8103     if (CvDEPTH(outcv) && CvCLONE(compcv)) {
8104         cv = *spot;
8105         svspot = (SV **)(spot = &clonee);
8106     }
8107     else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
8108         cv = *spot;
8109     else {
8110         assert (SvTYPE(*spot) == SVt_PVCV);
8111         if (CvNAMED(*spot))
8112             hek = CvNAME_HEK(*spot);
8113         else {
8114             dVAR;
8115             U32 hash;
8116             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
8117             CvNAME_HEK_set(*spot, hek =
8118                 share_hek(
8119                     PadnamePV(name)+1,
8120                     (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
8121                     hash
8122                 )
8123             );
8124             CvLEXICAL_on(*spot);
8125         }
8126         cv = PadnamePROTOCV(name);
8127         svspot = (SV **)(spot = &PadnamePROTOCV(name));
8128     }
8129
8130     if (block) {
8131         /* This makes sub {}; work as expected.  */
8132         if (block->op_type == OP_STUB) {
8133             const line_t l = PL_parser->copline;
8134             op_free(block);
8135             block = newSTATEOP(0, NULL, 0);
8136             PL_parser->copline = l;
8137         }
8138         block = CvLVALUE(compcv)
8139              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
8140                    ? newUNOP(OP_LEAVESUBLV, 0,
8141                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
8142                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
8143         start = LINKLIST(block);
8144         block->op_next = 0;
8145         if (ps && !*ps && !attrs && !CvLVALUE(compcv))
8146             const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
8147         else
8148             const_sv = NULL;
8149     }
8150     else
8151         const_sv = NULL;
8152
8153     if (cv) {
8154         const bool exists = CvROOT(cv) || CvXSUB(cv);
8155
8156         /* if the subroutine doesn't exist and wasn't pre-declared
8157          * with a prototype, assume it will be AUTOLOADed,
8158          * skipping the prototype check
8159          */
8160         if (exists || SvPOK(cv))
8161             cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
8162                                  ps_utf8);
8163         /* already defined? */
8164         if (exists) {
8165             if (S_already_defined(aTHX_ cv,block,NULL,name,&const_sv))
8166                 cv = NULL;
8167             else {
8168                 if (attrs) goto attrs;
8169                 /* just a "sub foo;" when &foo is already defined */
8170                 SAVEFREESV(compcv);
8171                 goto done;
8172             }
8173         }
8174         else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
8175             cv = NULL;
8176             reusable = TRUE;
8177         }
8178     }
8179     if (const_sv) {
8180         SvREFCNT_inc_simple_void_NN(const_sv);
8181         SvFLAGS(const_sv) |= SVs_PADTMP;
8182         if (cv) {
8183             assert(!CvROOT(cv) && !CvCONST(cv));
8184             cv_forget_slab(cv);
8185         }
8186         else {
8187             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8188             CvFILE_set_from_cop(cv, PL_curcop);
8189             CvSTASH_set(cv, PL_curstash);
8190             *spot = cv;
8191         }
8192         sv_setpvs(MUTABLE_SV(cv), "");  /* prototype is "" */
8193         CvXSUBANY(cv).any_ptr = const_sv;
8194         CvXSUB(cv) = const_sv_xsub;
8195         CvCONST_on(cv);
8196         CvISXSUB_on(cv);
8197         PoisonPADLIST(cv);
8198         CvFLAGS(cv) |= CvMETHOD(compcv);
8199         op_free(block);
8200         SvREFCNT_dec(compcv);
8201         PL_compcv = NULL;
8202         goto setname;
8203     }
8204     /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
8205        determine whether this sub definition is in the same scope as its
8206        declaration.  If this sub definition is inside an inner named pack-
8207        age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
8208        the package sub.  So check PadnameOUTER(name) too.
8209      */
8210     if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
8211         assert(!CvWEAKOUTSIDE(compcv));
8212         SvREFCNT_dec(CvOUTSIDE(compcv));
8213         CvWEAKOUTSIDE_on(compcv);
8214     }
8215     /* XXX else do we have a circular reference? */
8216     if (cv) {   /* must reuse cv in case stub is referenced elsewhere */
8217         /* transfer PL_compcv to cv */
8218         if (block
8219         ) {
8220             cv_flags_t preserved_flags =
8221                 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
8222             PADLIST *const temp_padl = CvPADLIST(cv);
8223             CV *const temp_cv = CvOUTSIDE(cv);
8224             const cv_flags_t other_flags =
8225                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8226             OP * const cvstart = CvSTART(cv);
8227
8228             SvPOK_off(cv);
8229             CvFLAGS(cv) =
8230                 CvFLAGS(compcv) | preserved_flags;
8231             CvOUTSIDE(cv) = CvOUTSIDE(compcv);
8232             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
8233             CvPADLIST_set(cv, CvPADLIST(compcv));
8234             CvOUTSIDE(compcv) = temp_cv;
8235             CvPADLIST_set(compcv, temp_padl);
8236             CvSTART(cv) = CvSTART(compcv);
8237             CvSTART(compcv) = cvstart;
8238             CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8239             CvFLAGS(compcv) |= other_flags;
8240
8241             if (CvFILE(cv) && CvDYNFILE(cv)) {
8242                 Safefree(CvFILE(cv));
8243             }
8244
8245             /* inner references to compcv must be fixed up ... */
8246             pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
8247             if (PERLDB_INTER)/* Advice debugger on the new sub. */
8248               ++PL_sub_generation;
8249         }
8250         else {
8251             /* Might have had built-in attributes applied -- propagate them. */
8252             CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
8253         }
8254         /* ... before we throw it away */
8255         SvREFCNT_dec(compcv);
8256         PL_compcv = compcv = cv;
8257     }
8258     else {
8259         cv = compcv;
8260         *spot = cv;
8261     }
8262    setname:
8263     CvLEXICAL_on(cv);
8264     if (!CvNAME_HEK(cv)) {
8265         if (hek) (void)share_hek_hek(hek);
8266         else {
8267             dVAR;
8268             U32 hash;
8269             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
8270             hek = share_hek(PadnamePV(name)+1,
8271                       (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
8272                       hash);
8273         }
8274         CvNAME_HEK_set(cv, hek);
8275     }
8276     if (const_sv) goto clone;
8277
8278     CvFILE_set_from_cop(cv, PL_curcop);
8279     CvSTASH_set(cv, PL_curstash);
8280
8281     if (ps) {
8282         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8283         if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
8284     }
8285
8286     if (!block)
8287         goto attrs;
8288
8289     /* If we assign an optree to a PVCV, then we've defined a subroutine that
8290        the debugger could be able to set a breakpoint in, so signal to
8291        pp_entereval that it should not throw away any saved lines at scope
8292        exit.  */
8293
8294     PL_breakable_sub_gen++;
8295     CvROOT(cv) = block;
8296     CvROOT(cv)->op_private |= OPpREFCOUNTED;
8297     OpREFCNT_set(CvROOT(cv), 1);
8298     /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8299        itself has a refcount. */
8300     CvSLABBED_off(cv);
8301     OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8302 #ifdef PERL_DEBUG_READONLY_OPS
8303     slab = (OPSLAB *)CvSTART(cv);
8304 #endif
8305     CvSTART(cv) = start;
8306     CALL_PEEP(start);
8307     finalize_optree(CvROOT(cv));
8308     S_prune_chain_head(&CvSTART(cv));
8309
8310     /* now that optimizer has done its work, adjust pad values */
8311
8312     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8313
8314   attrs:
8315     if (attrs) {
8316         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8317         apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
8318     }
8319
8320     if (block) {
8321         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8322             SV * const tmpstr = sv_newmortal();
8323             GV * const db_postponed = gv_fetchpvs("DB::postponed",
8324                                                   GV_ADDMULTI, SVt_PVHV);
8325             HV *hv;
8326             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8327                                           CopFILE(PL_curcop),
8328                                           (long)PL_subline,
8329                                           (long)CopLINE(PL_curcop));
8330             if (HvNAME_HEK(PL_curstash)) {
8331                 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
8332                 sv_catpvs(tmpstr, "::");
8333             }
8334             else sv_setpvs(tmpstr, "__ANON__::");
8335             sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
8336                             PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
8337             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8338                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8339             hv = GvHVn(db_postponed);
8340             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8341                 CV * const pcv = GvCV(db_postponed);
8342                 if (pcv) {
8343                     dSP;
8344                     PUSHMARK(SP);
8345                     XPUSHs(tmpstr);
8346                     PUTBACK;
8347                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
8348                 }
8349             }
8350         }
8351     }
8352
8353   clone:
8354     if (clonee) {
8355         assert(CvDEPTH(outcv));
8356         spot = (CV **)
8357             &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
8358         if (reusable) cv_clone_into(clonee, *spot);
8359         else *spot = cv_clone(clonee);
8360         SvREFCNT_dec_NN(clonee);
8361         cv = *spot;
8362     }
8363     if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
8364         PADOFFSET depth = CvDEPTH(outcv);
8365         while (--depth) {
8366             SV *oldcv;
8367             svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
8368             oldcv = *svspot;
8369             *svspot = SvREFCNT_inc_simple_NN(cv);
8370             SvREFCNT_dec(oldcv);
8371         }
8372     }
8373
8374   done:
8375     if (PL_parser)
8376         PL_parser->copline = NOLINE;
8377     LEAVE_SCOPE(floor);
8378 #ifdef PERL_DEBUG_READONLY_OPS
8379     if (slab)
8380         Slab_to_ro(slab);
8381 #endif
8382     op_free(o);
8383     return cv;
8384 }
8385
8386 /* _x = extended */
8387 CV *
8388 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
8389                             OP *block, bool o_is_gv)
8390 {
8391     GV *gv;
8392     const char *ps;
8393     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
8394     U32 ps_utf8 = 0;
8395     CV *cv = NULL;
8396     SV *const_sv;
8397     const bool ec = PL_parser && PL_parser->error_count;
8398     /* If the subroutine has no body, no attributes, and no builtin attributes
8399        then it's just a sub declaration, and we may be able to get away with
8400        storing with a placeholder scalar in the symbol table, rather than a
8401        full CV.  If anything is present then it will take a full CV to
8402        store it.  */
8403     const I32 gv_fetch_flags
8404         = ec ? GV_NOADD_NOINIT :
8405         (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
8406         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
8407     STRLEN namlen = 0;
8408     const char * const name =
8409          o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
8410     bool has_name;
8411     bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
8412     bool evanescent = FALSE;
8413     OP *start = NULL;
8414 #ifdef PERL_DEBUG_READONLY_OPS
8415     OPSLAB *slab = NULL;
8416 #endif
8417
8418     if (o_is_gv) {
8419         gv = (GV*)o;
8420         o = NULL;
8421         has_name = TRUE;
8422     } else if (name) {
8423         /* Try to optimise and avoid creating a GV.  Instead, the CV’s name
8424            hek and CvSTASH pointer together can imply the GV.  If the name
8425            contains a package name, then GvSTASH(CvGV(cv)) may differ from
8426            CvSTASH, so forego the optimisation if we find any.
8427            Also, we may be called from load_module at run time, so
8428            PL_curstash (which sets CvSTASH) may not point to the stash the
8429            sub is stored in.  */
8430         const I32 flags =
8431            ec ? GV_NOADD_NOINIT
8432               :   PL_curstash != CopSTASH(PL_curcop)
8433                || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
8434                     ? gv_fetch_flags
8435                     : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
8436         gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
8437         has_name = TRUE;
8438     } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
8439         SV * const sv = sv_newmortal();
8440         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
8441                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
8442                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
8443         gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
8444         has_name = TRUE;
8445     } else if (PL_curstash) {
8446         gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
8447         has_name = FALSE;
8448     } else {
8449         gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
8450         has_name = FALSE;
8451     }
8452     if (!ec) {
8453         if (isGV(gv)) {
8454             move_proto_attr(&proto, &attrs, gv);
8455         } else {
8456             assert(cSVOPo);
8457             move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv);
8458         }
8459     }
8460
8461     if (proto) {
8462         assert(proto->op_type == OP_CONST);
8463         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
8464         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
8465     }
8466     else
8467         ps = NULL;
8468
8469     if (o)
8470         SAVEFREEOP(o);
8471     if (proto)
8472         SAVEFREEOP(proto);
8473     if (attrs)
8474         SAVEFREEOP(attrs);
8475
8476     if (ec) {
8477         op_free(block);
8478         if (name) SvREFCNT_dec(PL_compcv);
8479         else cv = PL_compcv;
8480         PL_compcv = 0;
8481         if (name && block) {
8482             const char *s = strrchr(name, ':');
8483             s = s ? s+1 : name;
8484             if (strEQ(s, "BEGIN")) {
8485                 if (PL_in_eval & EVAL_KEEPERR)
8486                     Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
8487                 else {
8488                     SV * const errsv = ERRSV;
8489                     /* force display of errors found but not reported */
8490                     sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
8491                     Perl_croak_nocontext("%"SVf, SVfARG(errsv));
8492                 }
8493             }
8494         }
8495         goto done;
8496     }
8497
8498     if (!block && SvTYPE(gv) != SVt_PVGV) {
8499       /* If we are not defining a new sub and the existing one is not a
8500          full GV + CV... */
8501       if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
8502         /* We are applying attributes to an existing sub, so we need it
8503            upgraded if it is a constant.  */
8504         if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
8505             gv_init_pvn(gv, PL_curstash, name, namlen,
8506                         SVf_UTF8 * name_is_utf8);
8507       }
8508       else {                    /* Maybe prototype now, and had at maximum
8509                                    a prototype or const/sub ref before.  */
8510         if (SvTYPE(gv) > SVt_NULL) {
8511             cv_ckproto_len_flags((const CV *)gv,
8512                                  o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8513                                  ps_len, ps_utf8);
8514         }
8515         if (!SvROK(gv)) {
8516           if (ps) {
8517             sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
8518             if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
8519           }
8520           else
8521             sv_setiv(MUTABLE_SV(gv), -1);
8522         }
8523
8524         SvREFCNT_dec(PL_compcv);
8525         cv = PL_compcv = NULL;
8526         goto done;
8527       }
8528     }
8529
8530     cv = (!name || (isGV(gv) && GvCVGEN(gv)))
8531         ? NULL
8532         : isGV(gv)
8533             ? GvCV(gv)
8534             : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
8535                 ? (CV *)SvRV(gv)
8536                 : NULL;
8537
8538     if (block) {
8539         assert(PL_parser);
8540         /* This makes sub {}; work as expected.  */
8541         if (block->op_type == OP_STUB) {
8542             const line_t l = PL_parser->copline;
8543             op_free(block);
8544             block = newSTATEOP(0, NULL, 0);
8545             PL_parser->copline = l;
8546         }
8547         block = CvLVALUE(PL_compcv)
8548              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
8549                     && (!isGV(gv) || !GvASSUMECV(gv)))
8550                    ? newUNOP(OP_LEAVESUBLV, 0,
8551                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
8552                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
8553         start = LINKLIST(block);
8554         block->op_next = 0;
8555         if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
8556             const_sv =
8557                 S_op_const_sv(aTHX_ start, PL_compcv,
8558                                         cBOOL(CvCLONE(PL_compcv)));
8559         else
8560             const_sv = NULL;
8561     }
8562     else
8563         const_sv = NULL;
8564
8565     if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
8566         cv_ckproto_len_flags((const CV *)gv,
8567                              o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8568                              ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
8569         if (SvROK(gv)) {
8570             /* All the other code for sub redefinition warnings expects the
8571                clobbered sub to be a CV.  Instead of making all those code
8572                paths more complex, just inline the RV version here.  */
8573             const line_t oldline = CopLINE(PL_curcop);
8574             assert(IN_PERL_COMPILETIME);
8575             if (PL_parser && PL_parser->copline != NOLINE)
8576                 /* This ensures that warnings are reported at the first
8577                    line of a redefinition, not the last.  */
8578                 CopLINE_set(PL_curcop, PL_parser->copline);
8579             /* protect against fatal warnings leaking compcv */
8580             SAVEFREESV(PL_compcv);
8581
8582             if (ckWARN(WARN_REDEFINE)
8583              || (  ckWARN_d(WARN_REDEFINE)
8584                 && (  !const_sv || SvRV(gv) == const_sv
8585                    || sv_cmp(SvRV(gv), const_sv)  ))) {
8586                 assert(cSVOPo);
8587                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8588                           "Constant subroutine %"SVf" redefined",
8589                           SVfARG(cSVOPo->op_sv));
8590             }
8591
8592             SvREFCNT_inc_simple_void_NN(PL_compcv);
8593             CopLINE_set(PL_curcop, oldline);
8594             SvREFCNT_dec(SvRV(gv));
8595         }
8596     }
8597
8598     if (cv) {
8599         const bool exists = CvROOT(cv) || CvXSUB(cv);
8600
8601         /* if the subroutine doesn't exist and wasn't pre-declared
8602          * with a prototype, assume it will be AUTOLOADed,
8603          * skipping the prototype check
8604          */
8605         if (exists || SvPOK(cv))
8606             cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
8607         /* already defined (or promised)? */
8608         if (exists || (isGV(gv) && GvASSUMECV(gv))) {
8609             if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv))
8610                 cv = NULL;
8611             else {
8612                 if (attrs) goto attrs;
8613                 /* just a "sub foo;" when &foo is already defined */
8614                 SAVEFREESV(PL_compcv);
8615                 goto done;
8616             }
8617         }
8618     }
8619     if (const_sv) {
8620         SvREFCNT_inc_simple_void_NN(const_sv);
8621         SvFLAGS(const_sv) |= SVs_PADTMP;
8622         if (cv) {
8623             assert(!CvROOT(cv) && !CvCONST(cv));
8624             cv_forget_slab(cv);
8625             sv_setpvs(MUTABLE_SV(cv), "");  /* prototype is "" */
8626             CvXSUBANY(cv).any_ptr = const_sv;
8627             CvXSUB(cv) = const_sv_xsub;
8628             CvCONST_on(cv);
8629             CvISXSUB_on(cv);
8630             PoisonPADLIST(cv);
8631             CvFLAGS(cv) |= CvMETHOD(PL_compcv);
8632         }
8633         else {
8634             if (isGV(gv) || CvMETHOD(PL_compcv)) {
8635                 if (name && isGV(gv))
8636                     GvCV_set(gv, NULL);
8637                 cv = newCONSTSUB_flags(
8638                     NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
8639                     const_sv
8640                 );
8641                 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
8642             }
8643             else {
8644                 if (!SvROK(gv)) {
8645                     SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8646                     prepare_SV_for_RV((SV *)gv);
8647                     SvOK_off((SV *)gv);
8648                     SvROK_on(gv);
8649                 }
8650                 SvRV_set(gv, const_sv);
8651             }
8652         }
8653         op_free(block);
8654         SvREFCNT_dec(PL_compcv);
8655         PL_compcv = NULL;
8656         goto done;
8657     }
8658     if (cv) {                           /* must reuse cv if autoloaded */
8659         /* transfer PL_compcv to cv */
8660         if (block
8661         ) {
8662             cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
8663             PADLIST *const temp_av = CvPADLIST(cv);
8664             CV *const temp_cv = CvOUTSIDE(cv);
8665             const cv_flags_t other_flags =
8666                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8667             OP * const cvstart = CvSTART(cv);
8668
8669             if (isGV(gv)) {
8670                 CvGV_set(cv,gv);
8671                 assert(!CvCVGV_RC(cv));
8672                 assert(CvGV(cv) == gv);
8673             }
8674             else {
8675                 dVAR;
8676                 U32 hash;
8677                 PERL_HASH(hash, name, namlen);
8678                 CvNAME_HEK_set(cv,
8679                                share_hek(name,
8680                                          name_is_utf8
8681                                             ? -(SSize_t)namlen
8682                                             :  (SSize_t)namlen,
8683                                          hash));
8684             }
8685
8686             SvPOK_off(cv);
8687             CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
8688                                              | CvNAMED(cv);
8689             CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
8690             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
8691             CvPADLIST_set(cv,CvPADLIST(PL_compcv));
8692             CvOUTSIDE(PL_compcv) = temp_cv;
8693             CvPADLIST_set(PL_compcv, temp_av);
8694             CvSTART(cv) = CvSTART(PL_compcv);
8695             CvSTART(PL_compcv) = cvstart;
8696             CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8697             CvFLAGS(PL_compcv) |= other_flags;
8698
8699             if (CvFILE(cv) && CvDYNFILE(cv)) {
8700                 Safefree(CvFILE(cv));
8701     }
8702             CvFILE_set_from_cop(cv, PL_curcop);
8703             CvSTASH_set(cv, PL_curstash);
8704
8705             /* inner references to PL_compcv must be fixed up ... */
8706             pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
8707             if (PERLDB_INTER)/* Advice debugger on the new sub. */
8708               ++PL_sub_generation;
8709         }
8710         else {
8711             /* Might have had built-in attributes applied -- propagate them. */
8712             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
8713         }
8714         /* ... before we throw it away */
8715         SvREFCNT_dec(PL_compcv);
8716         PL_compcv = cv;
8717     }
8718     else {
8719         cv = PL_compcv;
8720         if (name && isGV(gv)) {
8721             GvCV_set(gv, cv);
8722             GvCVGEN(gv) = 0;
8723             if (HvENAME_HEK(GvSTASH(gv)))
8724                 /* sub Foo::bar { (shift)+1 } */
8725                 gv_method_changed(gv);
8726         }
8727         else if (name) {
8728             if (!SvROK(gv)) {
8729                 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8730                 prepare_SV_for_RV((SV *)gv);
8731                 SvOK_off((SV *)gv);
8732                 SvROK_on(gv);
8733             }
8734             SvRV_set(gv, (SV *)cv);
8735         }
8736     }
8737     if (!CvHASGV(cv)) {
8738         if (isGV(gv)) CvGV_set(cv, gv);
8739         else {
8740             dVAR;
8741             U32 hash;
8742             PERL_HASH(hash, name, namlen);
8743             CvNAME_HEK_set(cv, share_hek(name,
8744                                          name_is_utf8
8745                                             ? -(SSize_t)namlen
8746                                             :  (SSize_t)namlen,
8747                                          hash));
8748         }
8749         CvFILE_set_from_cop(cv, PL_curcop);
8750         CvSTASH_set(cv, PL_curstash);
8751     }
8752
8753     if (ps) {
8754         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8755         if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
8756     }
8757
8758     if (!block)
8759         goto attrs;
8760
8761     /* If we assign an optree to a PVCV, then we've defined a subroutine that
8762        the debugger could be able to set a breakpoint in, so signal to
8763        pp_entereval that it should not throw away any saved lines at scope
8764        exit.  */
8765
8766     PL_breakable_sub_gen++;
8767     CvROOT(cv) = block;
8768     CvROOT(cv)->op_private |= OPpREFCOUNTED;
8769     OpREFCNT_set(CvROOT(cv), 1);
8770     /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8771        itself has a refcount. */
8772     CvSLABBED_off(cv);
8773     OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8774 #ifdef PERL_DEBUG_READONLY_OPS
8775     slab = (OPSLAB *)CvSTART(cv);
8776 #endif
8777     CvSTART(cv) = start;
8778     CALL_PEEP(start);
8779     finalize_optree(CvROOT(cv));
8780     S_prune_chain_head(&CvSTART(cv));
8781
8782     /* now that optimizer has done its work, adjust pad values */
8783
8784     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8785
8786   attrs:
8787     if (attrs) {
8788         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8789         HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
8790                         ? GvSTASH(CvGV(cv))
8791                         : PL_curstash;
8792         if (!name) SAVEFREESV(cv);
8793         apply_attrs(stash, MUTABLE_SV(cv), attrs);
8794         if (!name) SvREFCNT_inc_simple_void_NN(cv);
8795     }
8796
8797     if (block && has_name) {
8798         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8799             SV * const tmpstr = cv_name(cv,NULL,0);
8800             GV * const db_postponed = gv_fetchpvs("DB::postponed",
8801                                                   GV_ADDMULTI, SVt_PVHV);
8802             HV *hv;
8803             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8804                                           CopFILE(PL_curcop),
8805                                           (long)PL_subline,
8806                                           (long)CopLINE(PL_curcop));
8807             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8808                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8809             hv = GvHVn(db_postponed);
8810             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8811                 CV * const pcv = GvCV(db_postponed);
8812                 if (pcv) {
8813                     dSP;
8814                     PUSHMARK(SP);
8815                     XPUSHs(tmpstr);
8816                     PUTBACK;
8817                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
8818                 }
8819             }
8820         }
8821
8822         if (name) {
8823             if (PL_parser && PL_parser->error_count)
8824                 clear_special_blocks(name, gv, cv);
8825             else
8826                 evanescent =
8827                     process_special_blocks(floor, name, gv, cv);
8828         }
8829     }
8830
8831   done:
8832     if (PL_parser)
8833         PL_parser->copline = NOLINE;
8834     LEAVE_SCOPE(floor);
8835     if (!evanescent) {
8836 #ifdef PERL_DEBUG_READONLY_OPS
8837       if (slab)
8838         Slab_to_ro(slab);
8839 #endif
8840       if (cv && name && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
8841         pad_add_weakref(cv);
8842     }
8843     return cv;
8844 }
8845
8846 STATIC void
8847 S_clear_special_blocks(pTHX_ const char *const fullname,
8848                        GV *const gv, CV *const cv) {
8849     const char *colon;
8850     const char *name;
8851
8852     PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
8853
8854     colon = strrchr(fullname,':');
8855     name = colon ? colon + 1 : fullname;
8856
8857     if ((*name == 'B' && strEQ(name, "BEGIN"))
8858         || (*name == 'E' && strEQ(name, "END"))
8859         || (*name == 'U' && strEQ(name, "UNITCHECK"))
8860         || (*name == 'C' && strEQ(name, "CHECK"))
8861         || (*name == 'I' && strEQ(name, "INIT"))) {
8862         if (!isGV(gv)) {
8863             (void)CvGV(cv);
8864             assert(isGV(gv));
8865         }
8866         GvCV_set(gv, NULL);
8867         SvREFCNT_dec_NN(MUTABLE_SV(cv));
8868     }
8869 }
8870
8871 /* Returns true if the sub has been freed.  */
8872 STATIC bool
8873 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
8874                          GV *const gv,
8875                          CV *const cv)
8876 {
8877     const char *const colon = strrchr(fullname,':');
8878     const char *const name = colon ? colon + 1 : fullname;
8879
8880     PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
8881
8882     if (*name == 'B') {
8883         if (strEQ(name, "BEGIN")) {
8884             const I32 oldscope = PL_scopestack_ix;
8885             dSP;
8886             (void)CvGV(cv);
8887             if (floor) LEAVE_SCOPE(floor);
8888             ENTER;
8889             PUSHSTACKi(PERLSI_REQUIRE);
8890             SAVECOPFILE(&PL_compiling);
8891             SAVECOPLINE(&PL_compiling);
8892             SAVEVPTR(PL_curcop);
8893
8894             DEBUG_x( dump_sub(gv) );
8895             Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
8896             GvCV_set(gv,0);             /* cv has been hijacked */
8897             call_list(oldscope, PL_beginav);
8898
8899             POPSTACK;
8900             LEAVE;
8901             return !PL_savebegin;
8902         }
8903         else
8904             return FALSE;
8905     } else {
8906         if (*name == 'E') {
8907             if strEQ(name, "END") {
8908                 DEBUG_x( dump_sub(gv) );
8909                 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
8910             } else
8911                 return FALSE;
8912         } else if (*name == 'U') {
8913             if (strEQ(name, "UNITCHECK")) {
8914                 /* It's never too late to run a unitcheck block */
8915                 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
8916             }
8917             else
8918                 return FALSE;
8919         } else if (*name == 'C') {
8920             if (strEQ(name, "CHECK")) {
8921                 if (PL_main_start)
8922                     /* diag_listed_as: Too late to run %s block */
8923                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8924                                    "Too late to run CHECK block");
8925                 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
8926             }
8927             else
8928                 return FALSE;
8929         } else if (*name == 'I') {
8930             if (strEQ(name, "INIT")) {
8931                 if (PL_main_start)
8932                     /* diag_listed_as: Too late to run %s block */
8933                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8934                                    "Too late to run INIT block");
8935                 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
8936             }
8937             else
8938                 return FALSE;
8939         } else
8940             return FALSE;
8941         DEBUG_x( dump_sub(gv) );
8942         (void)CvGV(cv);
8943         GvCV_set(gv,0);         /* cv has been hijacked */
8944         return FALSE;
8945     }
8946 }
8947
8948 /*
8949 =for apidoc newCONSTSUB
8950
8951 See L</newCONSTSUB_flags>.
8952
8953 =cut
8954 */
8955
8956 CV *
8957 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
8958 {
8959     return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
8960 }
8961
8962 /*
8963 =for apidoc newCONSTSUB_flags
8964
8965 Creates a constant sub equivalent to Perl S<C<sub FOO () { 123 }>> which is
8966 eligible for inlining at compile-time.
8967
8968 Currently, the only useful value for C<flags> is C<SVf_UTF8>.
8969
8970 The newly created subroutine takes ownership of a reference to the passed in
8971 SV.
8972
8973 Passing C<NULL> for SV creates a constant sub equivalent to S<C<sub BAR () {}>>,
8974 which won't be called if used as a destructor, but will suppress the overhead
8975 of a call to C<AUTOLOAD>.  (This form, however, isn't eligible for inlining at
8976 compile time.)
8977
8978 =cut
8979 */
8980
8981 CV *
8982 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
8983                              U32 flags, SV *sv)
8984 {
8985     CV* cv;
8986     const char *const file = CopFILE(PL_curcop);
8987
8988     ENTER;
8989
8990     if (IN_PERL_RUNTIME) {
8991         /* at runtime, it's not safe to manipulate PL_curcop: it may be
8992          * an op shared between threads. Use a non-shared COP for our
8993          * dirty work */
8994          SAVEVPTR(PL_curcop);
8995          SAVECOMPILEWARNINGS();
8996          PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
8997          PL_curcop = &PL_compiling;
8998     }
8999     SAVECOPLINE(PL_curcop);
9000     CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
9001
9002     SAVEHINTS();
9003     PL_hints &= ~HINT_BLOCK_SCOPE;
9004
9005     if (stash) {
9006         SAVEGENERICSV(PL_curstash);
9007         PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
9008     }
9009
9010     /* Protect sv against leakage caused by fatal warnings. */
9011     if (sv) SAVEFREESV(sv);
9012
9013     /* file becomes the CvFILE. For an XS, it's usually static storage,
9014        and so doesn't get free()d.  (It's expected to be from the C pre-
9015        processor __FILE__ directive). But we need a dynamically allocated one,
9016        and we need it to get freed.  */
9017     cv = newXS_len_flags(name, len,
9018                          sv && SvTYPE(sv) == SVt_PVAV
9019                              ? const_av_xsub
9020                              : const_sv_xsub,
9021                          file ? file : "", "",
9022                          &sv, XS_DYNAMIC_FILENAME | flags);
9023     CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
9024     CvCONST_on(cv);
9025
9026     LEAVE;
9027
9028     return cv;
9029 }
9030
9031 /*
9032 =for apidoc U||newXS
9033
9034 Used by C<xsubpp> to hook up XSUBs as Perl subs.  C<filename> needs to be
9035 static storage, as it is used directly as CvFILE(), without a copy being made.
9036
9037 =cut
9038 */
9039
9040 CV *
9041 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
9042 {
9043     PERL_ARGS_ASSERT_NEWXS;
9044     return newXS_len_flags(
9045         name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
9046     );
9047 }
9048
9049 CV *
9050 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
9051                  const char *const filename, const char *const proto,
9052                  U32 flags)
9053 {
9054     PERL_ARGS_ASSERT_NEWXS_FLAGS;
9055     return newXS_len_flags(
9056        name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
9057     );
9058 }
9059
9060 CV *
9061 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
9062 {
9063     PERL_ARGS_ASSERT_NEWXS_DEFFILE;
9064     return newXS_len_flags(
9065         name, strlen(name), subaddr, NULL, NULL, NULL, 0
9066     );
9067 }
9068
9069 CV *
9070 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
9071                            XSUBADDR_t subaddr, const char *const filename,
9072                            const char *const proto, SV **const_svp,
9073                            U32 flags)
9074 {
9075     CV *cv;
9076     bool interleave = FALSE;
9077
9078     PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
9079
9080     {
9081         GV * const gv = gv_fetchpvn(
9082                             name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
9083                             name ? len : PL_curstash ? sizeof("__ANON__") - 1:
9084                                 sizeof("__ANON__::__ANON__") - 1,
9085                             GV_ADDMULTI | flags, SVt_PVCV);
9086
9087         if ((cv = (name ? GvCV(gv) : NULL))) {
9088             if (GvCVGEN(gv)) {
9089                 /* just a cached method */
9090                 SvREFCNT_dec(cv);
9091                 cv = NULL;
9092             }
9093             else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
9094                 /* already defined (or promised) */
9095                 /* Redundant check that allows us to avoid creating an SV
9096                    most of the time: */
9097                 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
9098                     report_redefined_cv(newSVpvn_flags(
9099                                          name,len,(flags&SVf_UTF8)|SVs_TEMP
9100                                         ),
9101                                         cv, const_svp);
9102                 }
9103                 interleave = TRUE;
9104                 ENTER;
9105                 SAVEFREESV(cv);
9106                 cv = NULL;
9107             }
9108         }
9109
9110         if (cv)                         /* must reuse cv if autoloaded */
9111             cv_undef(cv);
9112         else {
9113             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9114             if (name) {
9115                 GvCV_set(gv,cv);
9116                 GvCVGEN(gv) = 0;
9117                 if (HvENAME_HEK(GvSTASH(gv)))
9118                     gv_method_changed(gv); /* newXS */
9119             }
9120         }
9121
9122         CvGV_set(cv, gv);
9123         if(filename) {
9124             /* XSUBs can't be perl lang/perl5db.pl debugged
9125             if (PERLDB_LINE_OR_SAVESRC)
9126                 (void)gv_fetchfile(filename); */
9127             assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
9128             if (flags & XS_DYNAMIC_FILENAME) {
9129                 CvDYNFILE_on(cv);
9130                 CvFILE(cv) = savepv(filename);
9131             } else {
9132             /* NOTE: not copied, as it is expected to be an external constant string */
9133                 CvFILE(cv) = (char *)filename;
9134             }
9135         } else {
9136             assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
9137             CvFILE(cv) = (char*)PL_xsubfilename;
9138         }
9139         CvISXSUB_on(cv);
9140         CvXSUB(cv) = subaddr;
9141 #ifndef PERL_IMPLICIT_CONTEXT
9142         CvHSCXT(cv) = &PL_stack_sp;
9143 #else
9144         PoisonPADLIST(cv);
9145 #endif
9146
9147         if (name)
9148             process_special_blocks(0, name, gv, cv);
9149         else
9150             CvANON_on(cv);
9151     } /* <- not a conditional branch */
9152
9153
9154     sv_setpv(MUTABLE_SV(cv), proto);
9155     if (interleave) LEAVE;
9156     return cv;
9157 }
9158
9159 CV *
9160 Perl_newSTUB(pTHX_ GV *gv, bool fake)
9161 {
9162     CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9163     GV *cvgv;
9164     PERL_ARGS_ASSERT_NEWSTUB;
9165     assert(!GvCVu(gv));
9166     GvCV_set(gv, cv);
9167     GvCVGEN(gv) = 0;
9168     if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
9169         gv_method_changed(gv);
9170     if (SvFAKE(gv)) {
9171         cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
9172         SvFAKE_off(cvgv);
9173     }
9174     else cvgv = gv;
9175     CvGV_set(cv, cvgv);
9176     CvFILE_set_from_cop(cv, PL_curcop);
9177     CvSTASH_set(cv, PL_curstash);
9178     GvMULTI_on(gv);
9179     return cv;
9180 }
9181
9182 void
9183 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
9184 {
9185     CV *cv;
9186
9187     GV *gv;
9188
9189     if (PL_parser && PL_parser->error_count) {
9190         op_free(block);
9191         goto finish;
9192     }
9193
9194     gv = o
9195         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
9196         : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
9197
9198     GvMULTI_on(gv);
9199     if ((cv = GvFORM(gv))) {
9200         if (ckWARN(WARN_REDEFINE)) {
9201             const line_t oldline = CopLINE(PL_curcop);
9202             if (PL_parser && PL_parser->copline != NOLINE)
9203                 CopLINE_set(PL_curcop, PL_parser->copline);
9204             if (o) {
9205                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9206                             "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
9207             } else {
9208                 /* diag_listed_as: Format %s redefined */
9209                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9210                             "Format STDOUT redefined");
9211             }
9212             CopLINE_set(PL_curcop, oldline);
9213         }
9214         SvREFCNT_dec(cv);
9215     }
9216     cv = PL_compcv;
9217     GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
9218     CvGV_set(cv, gv);
9219     CvFILE_set_from_cop(cv, PL_curcop);
9220
9221
9222     pad_tidy(padtidy_FORMAT);
9223     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
9224     CvROOT(cv)->op_private |= OPpREFCOUNTED;
9225     OpREFCNT_set(CvROOT(cv), 1);
9226     CvSTART(cv) = LINKLIST(CvROOT(cv));
9227     CvROOT(cv)->op_next = 0;
9228     CALL_PEEP(CvSTART(cv));
9229     finalize_optree(CvROOT(cv));
9230     S_prune_chain_head(&CvSTART(cv));
9231     cv_forget_slab(cv);
9232
9233   finish:
9234     op_free(o);
9235     if (PL_parser)
9236         PL_parser->copline = NOLINE;
9237     LEAVE_SCOPE(floor);
9238     PL_compiling.cop_seq = 0;
9239 }
9240
9241 OP *
9242 Perl_newANONLIST(pTHX_ OP *o)
9243 {
9244     return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
9245 }
9246
9247 OP *
9248 Perl_newANONHASH(pTHX_ OP *o)
9249 {
9250     return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
9251 }
9252
9253 OP *
9254 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
9255 {
9256     return newANONATTRSUB(floor, proto, NULL, block);
9257 }
9258
9259 OP *
9260 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
9261 {
9262     SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
9263     OP * anoncode =
9264         newSVOP(OP_ANONCODE, 0,
9265                 cv);
9266     if (CvANONCONST(cv))
9267         anoncode = newUNOP(OP_ANONCONST, 0,
9268                            op_convert_list(OP_ENTERSUB,
9269                                            OPf_STACKED|OPf_WANT_SCALAR,
9270                                            anoncode));
9271     return newUNOP(OP_REFGEN, 0, anoncode);
9272 }
9273
9274 OP *
9275 Perl_oopsAV(pTHX_ OP *o)
9276 {
9277     dVAR;
9278
9279     PERL_ARGS_ASSERT_OOPSAV;
9280
9281     switch (o->op_type) {
9282     case OP_PADSV:
9283     case OP_PADHV:
9284         OpTYPE_set(o, OP_PADAV);
9285         return ref(o, OP_RV2AV);
9286
9287     case OP_RV2SV:
9288     case OP_RV2HV:
9289         OpTYPE_set(o, OP_RV2AV);
9290         ref(o, OP_RV2AV);
9291         break;
9292
9293     default:
9294         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
9295         break;
9296     }
9297     return o;
9298 }
9299
9300 OP *
9301 Perl_oopsHV(pTHX_ OP *o)
9302 {
9303     dVAR;
9304
9305     PERL_ARGS_ASSERT_OOPSHV;
9306
9307     switch (o->op_type) {
9308     case OP_PADSV:
9309     case OP_PADAV:
9310         OpTYPE_set(o, OP_PADHV);
9311         return ref(o, OP_RV2HV);
9312
9313     case OP_RV2SV:
9314     case OP_RV2AV:
9315         OpTYPE_set(o, OP_RV2HV);
9316         ref(o, OP_RV2HV);
9317         break;
9318
9319     default:
9320         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
9321         break;
9322     }
9323     return o;
9324 }
9325
9326 OP *
9327 Perl_newAVREF(pTHX_ OP *o)
9328 {
9329     dVAR;
9330
9331     PERL_ARGS_ASSERT_NEWAVREF;
9332
9333     if (o->op_type == OP_PADANY) {
9334         OpTYPE_set(o, OP_PADAV);
9335         return o;
9336     }
9337     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
9338         Perl_croak(aTHX_ "Can't use an array as a reference");
9339     }
9340     return newUNOP(OP_RV2AV, 0, scalar(o));
9341 }
9342
9343 OP *
9344 Perl_newGVREF(pTHX_ I32 type, OP *o)
9345 {
9346     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
9347         return newUNOP(OP_NULL, 0, o);
9348     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
9349 }
9350
9351 OP *
9352 Perl_newHVREF(pTHX_ OP *o)
9353 {
9354     dVAR;
9355
9356     PERL_ARGS_ASSERT_NEWHVREF;
9357
9358     if (o->op_type == OP_PADANY) {
9359         OpTYPE_set(o, OP_PADHV);
9360         return o;
9361     }
9362     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
9363         Perl_croak(aTHX_ "Can't use a hash as a reference");
9364     }
9365     return newUNOP(OP_RV2HV, 0, scalar(o));
9366 }
9367
9368 OP *
9369 Perl_newCVREF(pTHX_ I32 flags, OP *o)
9370 {
9371     if (o->op_type == OP_PADANY) {
9372         dVAR;
9373         OpTYPE_set(o, OP_PADCV);
9374     }
9375     return newUNOP(OP_RV2CV, flags, scalar(o));
9376 }
9377
9378 OP *
9379 Perl_newSVREF(pTHX_ OP *o)
9380 {
9381     dVAR;
9382
9383     PERL_ARGS_ASSERT_NEWSVREF;
9384
9385     if (o->op_type == OP_PADANY) {
9386         OpTYPE_set(o, OP_PADSV);
9387         scalar(o);
9388         return o;
9389     }
9390     return newUNOP(OP_RV2SV, 0, scalar(o));
9391 }
9392
9393 /* Check routines. See the comments at the top of this file for details
9394  * on when these are called */
9395
9396 OP *
9397 Perl_ck_anoncode(pTHX_ OP *o)
9398 {
9399     PERL_ARGS_ASSERT_CK_ANONCODE;
9400
9401     cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
9402     cSVOPo->op_sv = NULL;
9403     return o;
9404 }
9405
9406 static void
9407 S_io_hints(pTHX_ OP *o)
9408 {
9409 #if O_BINARY != 0 || O_TEXT != 0
9410     HV * const table =
9411         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
9412     if (table) {
9413         SV **svp = hv_fetchs(table, "open_IN", FALSE);
9414         if (svp && *svp) {
9415             STRLEN len = 0;
9416             const char *d = SvPV_const(*svp, len);
9417             const I32 mode = mode_from_discipline(d, len);
9418             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9419 #  if O_BINARY != 0
9420             if (mode & O_BINARY)
9421                 o->op_private |= OPpOPEN_IN_RAW;
9422 #  endif
9423 #  if O_TEXT != 0
9424             if (mode & O_TEXT)
9425                 o->op_private |= OPpOPEN_IN_CRLF;
9426 #  endif
9427         }
9428
9429         svp = hv_fetchs(table, "open_OUT", FALSE);
9430         if (svp && *svp) {
9431             STRLEN len = 0;
9432             const char *d = SvPV_const(*svp, len);
9433             const I32 mode = mode_from_discipline(d, len);
9434             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9435 #  if O_BINARY != 0
9436             if (mode & O_BINARY)
9437                 o->op_private |= OPpOPEN_OUT_RAW;
9438 #  endif
9439 #  if O_TEXT != 0
9440             if (mode & O_TEXT)
9441                 o->op_private |= OPpOPEN_OUT_CRLF;
9442 #  endif
9443         }
9444     }
9445 #else
9446     PERL_UNUSED_CONTEXT;
9447     PERL_UNUSED_ARG(o);
9448 #endif
9449 }
9450
9451 OP *
9452 Perl_ck_backtick(pTHX_ OP *o)
9453 {
9454     GV *gv;
9455     OP *newop = NULL;
9456     OP *sibl;
9457     PERL_ARGS_ASSERT_CK_BACKTICK;
9458     /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
9459     if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
9460      && (gv = gv_override("readpipe",8)))
9461     {
9462         /* detach rest of siblings from o and its first child */
9463         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
9464         newop = S_new_entersubop(aTHX_ gv, sibl);
9465     }
9466     else if (!(o->op_flags & OPf_KIDS))
9467         newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
9468     if (newop) {
9469         op_free(o);
9470         return newop;
9471     }
9472     S_io_hints(aTHX_ o);
9473     return o;
9474 }
9475
9476 OP *
9477 Perl_ck_bitop(pTHX_ OP *o)
9478 {
9479     PERL_ARGS_ASSERT_CK_BITOP;
9480
9481     o->op_private = (U8)(PL_hints & HINT_INTEGER);
9482
9483     if (o->op_type == OP_NBIT_OR     || o->op_type == OP_SBIT_OR
9484      || o->op_type == OP_NBIT_XOR    || o->op_type == OP_SBIT_XOR
9485      || o->op_type == OP_NBIT_AND    || o->op_type == OP_SBIT_AND
9486      || o->op_type == OP_NCOMPLEMENT || o->op_type == OP_SCOMPLEMENT)
9487         Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__BITWISE),
9488                               "The bitwise feature is experimental");
9489     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
9490             && OP_IS_INFIX_BIT(o->op_type))
9491     {
9492         const OP * const left = cBINOPo->op_first;
9493         const OP * const right = OpSIBLING(left);
9494         if ((OP_IS_NUMCOMPARE(left->op_type) &&
9495                 (left->op_flags & OPf_PARENS) == 0) ||
9496             (OP_IS_NUMCOMPARE(right->op_type) &&
9497                 (right->op_flags & OPf_PARENS) == 0))
9498             Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
9499                           "Possible precedence problem on bitwise %s operator",
9500                            o->op_type ==  OP_BIT_OR
9501                          ||o->op_type == OP_NBIT_OR  ? "|"
9502                         :  o->op_type ==  OP_BIT_AND
9503                          ||o->op_type == OP_NBIT_AND ? "&"
9504                         :  o->op_type ==  OP_BIT_XOR
9505                          ||o->op_type == OP_NBIT_XOR ? "^"
9506                         :  o->op_type == OP_SBIT_OR  ? "|."
9507                         :  o->op_type == OP_SBIT_AND ? "&." : "^."
9508                            );
9509     }
9510     return o;
9511 }
9512
9513 PERL_STATIC_INLINE bool
9514 is_dollar_bracket(pTHX_ const OP * const o)
9515 {
9516     const OP *kid;
9517     PERL_UNUSED_CONTEXT;
9518     return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
9519         && (kid = cUNOPx(o)->op_first)
9520         && kid->op_type == OP_GV
9521         && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
9522 }
9523
9524 OP *
9525 Perl_ck_cmp(pTHX_ OP *o)
9526 {
9527     PERL_ARGS_ASSERT_CK_CMP;
9528     if (ckWARN(WARN_SYNTAX)) {
9529         const OP *kid = cUNOPo->op_first;
9530         if (kid &&
9531             (
9532                 (   is_dollar_bracket(aTHX_ kid)
9533                  && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
9534                 )
9535              || (   kid->op_type == OP_CONST
9536                  && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
9537                 )
9538            )
9539         )
9540             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9541                         "$[ used in %s (did you mean $] ?)", OP_DESC(o));
9542     }
9543     return o;
9544 }
9545
9546 OP *
9547 Perl_ck_concat(pTHX_ OP *o)
9548 {
9549     const OP * const kid = cUNOPo->op_first;
9550
9551     PERL_ARGS_ASSERT_CK_CONCAT;
9552     PERL_UNUSED_CONTEXT;
9553
9554     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
9555             !(kUNOP->op_first->op_flags & OPf_MOD))
9556         o->op_flags |= OPf_STACKED;
9557     return o;
9558 }
9559
9560 OP *
9561 Perl_ck_spair(pTHX_ OP *o)
9562 {
9563     dVAR;
9564
9565     PERL_ARGS_ASSERT_CK_SPAIR;
9566
9567     if (o->op_flags & OPf_KIDS) {
9568         OP* newop;
9569         OP* kid;
9570         OP* kidkid;
9571         const OPCODE type = o->op_type;
9572         o = modkids(ck_fun(o), type);
9573         kid    = cUNOPo->op_first;
9574         kidkid = kUNOP->op_first;
9575         newop = OpSIBLING(kidkid);
9576         if (newop) {
9577             const OPCODE type = newop->op_type;
9578             if (OpHAS_SIBLING(newop))
9579                 return o;
9580             if (o->op_type == OP_REFGEN
9581              && (  type == OP_RV2CV
9582                 || (  !(newop->op_flags & OPf_PARENS)
9583                    && (  type == OP_RV2AV || type == OP_PADAV
9584                       || type == OP_RV2HV || type == OP_PADHV))))
9585                 NOOP; /* OK (allow srefgen for \@a and \%h) */
9586             else if (OP_GIMME(newop,0) != G_SCALAR)
9587                 return o;
9588         }
9589         /* excise first sibling */
9590         op_sibling_splice(kid, NULL, 1, NULL);
9591         op_free(kidkid);
9592     }
9593     /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
9594      * and OP_CHOMP into OP_SCHOMP */
9595     o->op_ppaddr = PL_ppaddr[++o->op_type];
9596     return ck_fun(o);
9597 }
9598
9599 OP *
9600 Perl_ck_delete(pTHX_ OP *o)
9601 {
9602     PERL_ARGS_ASSERT_CK_DELETE;
9603
9604     o = ck_fun(o);
9605     o->op_private = 0;
9606     if (o->op_flags & OPf_KIDS) {
9607         OP * const kid = cUNOPo->op_first;
9608         switch (kid->op_type) {
9609         case OP_ASLICE:
9610             o->op_flags |= OPf_SPECIAL;
9611             /* FALLTHROUGH */
9612         case OP_HSLICE:
9613             o->op_private |= OPpSLICE;
9614             break;
9615         case OP_AELEM:
9616             o->op_flags |= OPf_SPECIAL;
9617             /* FALLTHROUGH */
9618         case OP_HELEM:
9619             break;
9620         case OP_KVASLICE:
9621             Perl_croak(aTHX_ "delete argument is index/value array slice,"
9622                              " use array slice");
9623         case OP_KVHSLICE:
9624             Perl_croak(aTHX_ "delete argument is key/value hash slice, use"
9625                              " hash slice");
9626         default:
9627             Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
9628                              "element or slice");
9629         }
9630         if (kid->op_private & OPpLVAL_INTRO)
9631             o->op_private |= OPpLVAL_INTRO;
9632         op_null(kid);
9633     }
9634     return o;
9635 }
9636
9637 OP *
9638 Perl_ck_eof(pTHX_ OP *o)
9639 {
9640     PERL_ARGS_ASSERT_CK_EOF;
9641
9642     if (o->op_flags & OPf_KIDS) {
9643         OP *kid;
9644         if (cLISTOPo->op_first->op_type == OP_STUB) {
9645             OP * const newop
9646                 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
9647             op_free(o);
9648             o = newop;
9649         }
9650         o = ck_fun(o);
9651         kid = cLISTOPo->op_first;
9652         if (kid->op_type == OP_RV2GV)
9653             kid->op_private |= OPpALLOW_FAKE;
9654     }
9655     return o;
9656 }
9657
9658 OP *
9659 Perl_ck_eval(pTHX_ OP *o)
9660 {
9661     dVAR;
9662
9663     PERL_ARGS_ASSERT_CK_EVAL;
9664
9665     PL_hints |= HINT_BLOCK_SCOPE;
9666     if (o->op_flags & OPf_KIDS) {
9667         SVOP * const kid = (SVOP*)cUNOPo->op_first;
9668         assert(kid);
9669
9670         if (o->op_type == OP_ENTERTRY) {
9671             LOGOP *enter;
9672
9673             /* cut whole sibling chain free from o */
9674             op_sibling_splice(o, NULL, -1, NULL);
9675             op_free(o);
9676
9677             enter = S_alloc_LOGOP(aTHX_ OP_ENTERTRY, NULL, NULL);
9678
9679             /* establish postfix order */
9680             enter->op_next = (OP*)enter;
9681
9682             o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
9683             OpTYPE_set(o, OP_LEAVETRY);
9684             enter->op_other = o;
9685             return o;
9686         }
9687         else {
9688             scalar((OP*)kid);
9689             S_set_haseval(aTHX);
9690         }
9691     }
9692     else {
9693         const U8 priv = o->op_private;
9694         op_free(o);
9695         /* the newUNOP will recursively call ck_eval(), which will handle
9696          * all the stuff at the end of this function, like adding
9697          * OP_HINTSEVAL
9698          */
9699         return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
9700     }
9701     o->op_targ = (PADOFFSET)PL_hints;
9702     if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
9703     if ((PL_hints & HINT_LOCALIZE_HH) != 0
9704      && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
9705         /* Store a copy of %^H that pp_entereval can pick up. */
9706         OP *hhop = newSVOP(OP_HINTSEVAL, 0,
9707                            MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
9708         /* append hhop to only child  */
9709         op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
9710
9711         o->op_private |= OPpEVAL_HAS_HH;
9712     }
9713     if (!(o->op_private & OPpEVAL_BYTES)
9714          && FEATURE_UNIEVAL_IS_ENABLED)
9715             o->op_private |= OPpEVAL_UNICODE;
9716     return o;
9717 }
9718
9719 OP *
9720 Perl_ck_exec(pTHX_ OP *o)
9721 {
9722     PERL_ARGS_ASSERT_CK_EXEC;
9723
9724     if (o->op_flags & OPf_STACKED) {
9725         OP *kid;
9726         o = ck_fun(o);
9727         kid = OpSIBLING(cUNOPo->op_first);
9728         if (kid->op_type == OP_RV2GV)
9729             op_null(kid);
9730     }
9731     else
9732         o = listkids(o);
9733     return o;
9734 }
9735
9736 OP *
9737 Perl_ck_exists(pTHX_ OP *o)
9738 {
9739     PERL_ARGS_ASSERT_CK_EXISTS;
9740
9741     o = ck_fun(o);
9742     if (o->op_flags & OPf_KIDS) {
9743         OP * const kid = cUNOPo->op_first;
9744         if (kid->op_type == OP_ENTERSUB) {
9745             (void) ref(kid, o->op_type);
9746             if (kid->op_type != OP_RV2CV
9747                         && !(PL_parser && PL_parser->error_count))
9748                 Perl_croak(aTHX_
9749                           "exists argument is not a subroutine name");
9750             o->op_private |= OPpEXISTS_SUB;
9751         }
9752         else if (kid->op_type == OP_AELEM)
9753             o->op_flags |= OPf_SPECIAL;
9754         else if (kid->op_type != OP_HELEM)
9755             Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
9756                              "element or a subroutine");
9757         op_null(kid);
9758     }
9759     return o;
9760 }
9761
9762 OP *
9763 Perl_ck_rvconst(pTHX_ OP *o)
9764 {
9765     dVAR;
9766     SVOP * const kid = (SVOP*)cUNOPo->op_first;
9767
9768     PERL_ARGS_ASSERT_CK_RVCONST;
9769
9770     o->op_private |= (PL_hints & HINT_STRICT_REFS);
9771
9772     if (kid->op_type == OP_CONST) {
9773         int iscv;
9774         GV *gv;
9775         SV * const kidsv = kid->op_sv;
9776
9777         /* Is it a constant from cv_const_sv()? */
9778         if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
9779             return o;
9780         }
9781         if (SvTYPE(kidsv) == SVt_PVAV) return o;
9782         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
9783             const char *badthing;
9784             switch (o->op_type) {
9785             case OP_RV2SV:
9786                 badthing = "a SCALAR";
9787                 break;
9788             case OP_RV2AV:
9789                 badthing = "an ARRAY";
9790                 break;
9791             case OP_RV2HV:
9792                 badthing = "a HASH";
9793                 break;
9794             default:
9795                 badthing = NULL;
9796                 break;
9797             }
9798             if (badthing)
9799                 Perl_croak(aTHX_
9800                            "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
9801                            SVfARG(kidsv), badthing);
9802         }
9803         /*
9804          * This is a little tricky.  We only want to add the symbol if we
9805          * didn't add it in the lexer.  Otherwise we get duplicate strict
9806          * warnings.  But if we didn't add it in the lexer, we must at
9807          * least pretend like we wanted to add it even if it existed before,
9808          * or we get possible typo warnings.  OPpCONST_ENTERED says
9809          * whether the lexer already added THIS instance of this symbol.
9810          */
9811         iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
9812         gv = gv_fetchsv(kidsv,
9813                 o->op_type == OP_RV2CV
9814                         && o->op_private & OPpMAY_RETURN_CONSTANT
9815                     ? GV_NOEXPAND
9816                     : iscv | !(kid->op_private & OPpCONST_ENTERED),
9817                 iscv
9818                     ? SVt_PVCV
9819                     : o->op_type == OP_RV2SV
9820                         ? SVt_PV
9821                         : o->op_type == OP_RV2AV
9822                             ? SVt_PVAV
9823                             : o->op_type == OP_RV2HV
9824                                 ? SVt_PVHV
9825                                 : SVt_PVGV);
9826         if (gv) {
9827             if (!isGV(gv)) {
9828                 assert(iscv);
9829                 assert(SvROK(gv));
9830                 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
9831                   && SvTYPE(SvRV(gv)) != SVt_PVCV)
9832                     gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
9833             }
9834             OpTYPE_set(kid, OP_GV);
9835             SvREFCNT_dec(kid->op_sv);
9836 #ifdef USE_ITHREADS
9837             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
9838             STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
9839             kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
9840             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
9841             PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
9842 #else
9843             kid->op_sv = SvREFCNT_inc_simple_NN(gv);
9844 #endif
9845             kid->op_private = 0;
9846             /* FAKE globs in the symbol table cause weird bugs (#77810) */
9847             SvFAKE_off(gv);
9848         }
9849     }
9850     return o;
9851 }
9852
9853 OP *
9854 Perl_ck_ftst(pTHX_ OP *o)
9855 {
9856     dVAR;
9857     const I32 type = o->op_type;
9858
9859     PERL_ARGS_ASSERT_CK_FTST;
9860
9861     if (o->op_flags & OPf_REF) {
9862         NOOP;
9863     }
9864     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
9865         SVOP * const kid = (SVOP*)cUNOPo->op_first;
9866         const OPCODE kidtype = kid->op_type;
9867
9868         if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
9869          && !kid->op_folded) {
9870             OP * const newop = newGVOP(type, OPf_REF,
9871                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
9872             op_free(o);
9873             return newop;
9874         }
9875
9876         if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
9877             SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
9878             if (name) {
9879                 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
9880                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
9881                             array_passed_to_stat, name);
9882             }
9883             else {
9884                 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
9885                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
9886             }
9887        }
9888         scalar((OP *) kid);
9889         if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
9890             o->op_private |= OPpFT_ACCESS;
9891         if (type != OP_STAT && type != OP_LSTAT
9892             && PL_check[kidtype] == Perl_ck_ftst
9893             && kidtype != OP_STAT && kidtype != OP_LSTAT
9894         ) {
9895             o->op_private |= OPpFT_STACKED;
9896             kid->op_private |= OPpFT_STACKING;
9897             if (kidtype == OP_FTTTY && (
9898                    !(kid->op_private & OPpFT_STACKED)
9899                 || kid->op_private & OPpFT_AFTER_t
9900                ))
9901                 o->op_private |= OPpFT_AFTER_t;
9902         }
9903     }
9904     else {
9905         op_free(o);
9906         if (type == OP_FTTTY)
9907             o = newGVOP(type, OPf_REF, PL_stdingv);
9908         else
9909             o = newUNOP(type, 0, newDEFSVOP());
9910     }
9911     return o;
9912 }
9913
9914 OP *
9915 Perl_ck_fun(pTHX_ OP *o)
9916 {
9917     const int type = o->op_type;
9918     I32 oa = PL_opargs[type] >> OASHIFT;
9919
9920     PERL_ARGS_ASSERT_CK_FUN;
9921
9922     if (o->op_flags & OPf_STACKED) {
9923         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
9924             oa &= ~OA_OPTIONAL;
9925         else
9926             return no_fh_allowed(o);
9927     }
9928
9929     if (o->op_flags & OPf_KIDS) {
9930         OP *prev_kid = NULL;
9931         OP *kid = cLISTOPo->op_first;
9932         I32 numargs = 0;
9933         bool seen_optional = FALSE;
9934
9935         if (kid->op_type == OP_PUSHMARK ||
9936             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
9937         {
9938             prev_kid = kid;
9939             kid = OpSIBLING(kid);
9940         }
9941         if (kid && kid->op_type == OP_COREARGS) {
9942             bool optional = FALSE;
9943             while (oa) {
9944                 numargs++;
9945                 if (oa & OA_OPTIONAL) optional = TRUE;
9946                 oa = oa >> 4;
9947             }
9948             if (optional) o->op_private |= numargs;
9949             return o;
9950         }
9951
9952         while (oa) {
9953             if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
9954                 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
9955                     kid = newDEFSVOP();
9956                     /* append kid to chain */
9957                     op_sibling_splice(o, prev_kid, 0, kid);
9958                 }
9959                 seen_optional = TRUE;
9960             }
9961             if (!kid) break;
9962
9963             numargs++;
9964             switch (oa & 7) {
9965             case OA_SCALAR:
9966                 /* list seen where single (scalar) arg expected? */
9967                 if (numargs == 1 && !(oa >> 4)
9968                     && kid->op_type == OP_LIST && type != OP_SCALAR)
9969                 {
9970                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
9971                 }
9972                 if (type != OP_DELETE) scalar(kid);
9973                 break;
9974             case OA_LIST:
9975                 if (oa < 16) {
9976                     kid = 0;
9977                     continue;
9978                 }
9979                 else
9980                     list(kid);
9981                 break;
9982             case OA_AVREF:
9983                 if ((type == OP_PUSH || type == OP_UNSHIFT)
9984                     && !OpHAS_SIBLING(kid))
9985                     Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
9986                                    "Useless use of %s with no values",
9987                                    PL_op_desc[type]);
9988
9989                 if (kid->op_type == OP_CONST
9990                       && (  !SvROK(cSVOPx_sv(kid))
9991                          || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV  )
9992                         )
9993                     bad_type_pv(numargs, "array", o, kid);
9994                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
9995                     yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
9996                                          PL_op_desc[type]), 0);
9997                 }
9998                 else {
9999                     op_lvalue(kid, type);
10000                 }
10001                 break;
10002             case OA_HVREF:
10003                 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
10004                     bad_type_pv(numargs, "hash", o, kid);
10005                 op_lvalue(kid, type);
10006                 break;
10007             case OA_CVREF:
10008                 {
10009                     /* replace kid with newop in chain */
10010                     OP * const newop =
10011                         S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
10012                     newop->op_next = newop;
10013                     kid = newop;
10014                 }
10015                 break;
10016             case OA_FILEREF:
10017                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
10018                     if (kid->op_type == OP_CONST &&
10019                         (kid->op_private & OPpCONST_BARE))
10020                     {
10021                         OP * const newop = newGVOP(OP_GV, 0,
10022                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
10023                         /* replace kid with newop in chain */
10024                         op_sibling_splice(o, prev_kid, 1, newop);
10025                         op_free(kid);
10026                         kid = newop;
10027                     }
10028                     else if (kid->op_type == OP_READLINE) {
10029                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
10030                         bad_type_pv(numargs, "HANDLE", o, kid);
10031                     }
10032                     else {
10033                         I32 flags = OPf_SPECIAL;
10034                         I32 priv = 0;
10035                         PADOFFSET targ = 0;
10036
10037                         /* is this op a FH constructor? */
10038                         if (is_handle_constructor(o,numargs)) {
10039                             const char *name = NULL;
10040                             STRLEN len = 0;
10041                             U32 name_utf8 = 0;
10042                             bool want_dollar = TRUE;
10043
10044                             flags = 0;
10045                             /* Set a flag to tell rv2gv to vivify
10046                              * need to "prove" flag does not mean something
10047                              * else already - NI-S 1999/05/07
10048                              */
10049                             priv = OPpDEREF;
10050                             if (kid->op_type == OP_PADSV) {
10051                                 PADNAME * const pn
10052                                     = PAD_COMPNAME_SV(kid->op_targ);
10053                                 name = PadnamePV (pn);
10054                                 len  = PadnameLEN(pn);
10055                                 name_utf8 = PadnameUTF8(pn);
10056                             }
10057                             else if (kid->op_type == OP_RV2SV
10058                                      && kUNOP->op_first->op_type == OP_GV)
10059                             {
10060                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
10061                                 name = GvNAME(gv);
10062                                 len = GvNAMELEN(gv);
10063                                 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
10064                             }
10065                             else if (kid->op_type == OP_AELEM
10066                                      || kid->op_type == OP_HELEM)
10067                             {
10068                                  OP *firstop;
10069                                  OP *op = ((BINOP*)kid)->op_first;
10070                                  name = NULL;
10071                                  if (op) {
10072                                       SV *tmpstr = NULL;
10073                                       const char * const a =
10074                                            kid->op_type == OP_AELEM ?
10075                                            "[]" : "{}";
10076                                       if (((op->op_type == OP_RV2AV) ||
10077                                            (op->op_type == OP_RV2HV)) &&
10078                                           (firstop = ((UNOP*)op)->op_first) &&
10079                                           (firstop->op_type == OP_GV)) {
10080                                            /* packagevar $a[] or $h{} */
10081                                            GV * const gv = cGVOPx_gv(firstop);
10082                                            if (gv)
10083                                                 tmpstr =
10084                                                      Perl_newSVpvf(aTHX_
10085                                                                    "%s%c...%c",
10086                                                                    GvNAME(gv),
10087                                                                    a[0], a[1]);
10088                                       }
10089                                       else if (op->op_type == OP_PADAV
10090                                                || op->op_type == OP_PADHV) {
10091                                            /* lexicalvar $a[] or $h{} */
10092                                            const char * const padname =
10093                                                 PAD_COMPNAME_PV(op->op_targ);
10094                                            if (padname)
10095                                                 tmpstr =
10096                                                      Perl_newSVpvf(aTHX_
10097                                                                    "%s%c...%c",
10098                                                                    padname + 1,
10099                                                                    a[0], a[1]);
10100                                       }
10101                                       if (tmpstr) {
10102                                            name = SvPV_const(tmpstr, len);
10103                                            name_utf8 = SvUTF8(tmpstr);
10104                                            sv_2mortal(tmpstr);
10105                                       }
10106                                  }
10107                                  if (!name) {
10108                                       name = "__ANONIO__";
10109                                       len = 10;
10110                                       want_dollar = FALSE;
10111                                  }
10112                                  op_lvalue(kid, type);
10113                             }
10114                             if (name) {
10115                                 SV *namesv;
10116                                 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
10117                                 namesv = PAD_SVl(targ);
10118                                 if (want_dollar && *name != '$')
10119                                     sv_setpvs(namesv, "$");
10120                                 else
10121                                     sv_setpvs(namesv, "");
10122                                 sv_catpvn(namesv, name, len);
10123                                 if ( name_utf8 ) SvUTF8_on(namesv);
10124                             }
10125                         }
10126                         scalar(kid);
10127                         kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
10128                                     OP_RV2GV, flags);
10129                         kid->op_targ = targ;
10130                         kid->op_private |= priv;
10131                     }
10132                 }
10133                 scalar(kid);
10134                 break;
10135             case OA_SCALARREF:
10136                 if ((type == OP_UNDEF || type == OP_POS)
10137                     && numargs == 1 && !(oa >> 4)
10138                     && kid->op_type == OP_LIST)
10139                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
10140                 op_lvalue(scalar(kid), type);
10141                 break;
10142             }
10143             oa >>= 4;
10144             prev_kid = kid;
10145             kid = OpSIBLING(kid);
10146         }
10147         /* FIXME - should the numargs or-ing move after the too many
10148          * arguments check? */
10149         o->op_private |= numargs;
10150         if (kid)
10151             return too_many_arguments_pv(o,OP_DESC(o), 0);
10152         listkids(o);
10153     }
10154     else if (PL_opargs[type] & OA_DEFGV) {
10155         /* Ordering of these two is important to keep f_map.t passing.  */
10156         op_free(o);
10157         return newUNOP(type, 0, newDEFSVOP());
10158     }
10159
10160     if (oa) {
10161         while (oa & OA_OPTIONAL)
10162             oa >>= 4;
10163         if (oa && oa != OA_LIST)
10164             return too_few_arguments_pv(o,OP_DESC(o), 0);
10165     }
10166     return o;
10167 }
10168
10169 OP *
10170 Perl_ck_glob(pTHX_ OP *o)
10171 {
10172     GV *gv;
10173
10174     PERL_ARGS_ASSERT_CK_GLOB;
10175
10176     o = ck_fun(o);
10177     if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
10178         op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
10179
10180     if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
10181     {
10182         /* convert
10183          *     glob
10184          *       \ null - const(wildcard)
10185          * into
10186          *     null
10187          *       \ enter
10188          *            \ list
10189          *                 \ mark - glob - rv2cv
10190          *                             |        \ gv(CORE::GLOBAL::glob)
10191          *                             |
10192          *                              \ null - const(wildcard)
10193          */
10194         o->op_flags |= OPf_SPECIAL;
10195         o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
10196         o = S_new_entersubop(aTHX_ gv, o);
10197         o = newUNOP(OP_NULL, 0, o);
10198         o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
10199         return o;
10200     }
10201     else o->op_flags &= ~OPf_SPECIAL;
10202 #if !defined(PERL_EXTERNAL_GLOB)
10203     if (!PL_globhook) {
10204         ENTER;
10205         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
10206                                newSVpvs("File::Glob"), NULL, NULL, NULL);
10207         LEAVE;
10208     }
10209 #endif /* !PERL_EXTERNAL_GLOB */
10210     gv = (GV *)newSV(0);
10211     gv_init(gv, 0, "", 0, 0);
10212     gv_IOadd(gv);
10213     op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
10214     SvREFCNT_dec_NN(gv); /* newGVOP increased it */
10215     scalarkids(o);
10216     return o;
10217 }
10218
10219 OP *
10220 Perl_ck_grep(pTHX_ OP *o)
10221 {
10222     LOGOP *gwop;
10223     OP *kid;
10224     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
10225
10226     PERL_ARGS_ASSERT_CK_GREP;
10227
10228     /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
10229
10230     if (o->op_flags & OPf_STACKED) {
10231         kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
10232         if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
10233             return no_fh_allowed(o);
10234         o->op_flags &= ~OPf_STACKED;
10235     }
10236     kid = OpSIBLING(cLISTOPo->op_first);
10237     if (type == OP_MAPWHILE)
10238         list(kid);
10239     else
10240         scalar(kid);
10241     o = ck_fun(o);
10242     if (PL_parser && PL_parser->error_count)
10243         return o;
10244     kid = OpSIBLING(cLISTOPo->op_first);
10245     if (kid->op_type != OP_NULL)
10246         Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
10247     kid = kUNOP->op_first;
10248
10249     gwop = S_alloc_LOGOP(aTHX_ type, o, LINKLIST(kid));
10250     kid->op_next = (OP*)gwop;
10251     o->op_private = gwop->op_private = 0;
10252     gwop->op_targ = pad_alloc(type, SVs_PADTMP);
10253
10254     kid = OpSIBLING(cLISTOPo->op_first);
10255     for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
10256         op_lvalue(kid, OP_GREPSTART);
10257
10258     return (OP*)gwop;
10259 }
10260
10261 OP *
10262 Perl_ck_index(pTHX_ OP *o)
10263 {
10264     PERL_ARGS_ASSERT_CK_INDEX;
10265
10266     if (o->op_flags & OPf_KIDS) {
10267         OP *kid = OpSIBLING(cLISTOPo->op_first);        /* get past pushmark */
10268         if (kid)
10269             kid = OpSIBLING(kid);                       /* get past "big" */
10270         if (kid && kid->op_type == OP_CONST) {
10271             const bool save_taint = TAINT_get;
10272             SV *sv = kSVOP->op_sv;
10273             if ((!SvPOK(sv) || SvNIOKp(sv)) && SvOK(sv) && !SvROK(sv)) {
10274                 sv = newSV(0);
10275                 sv_copypv(sv, kSVOP->op_sv);
10276                 SvREFCNT_dec_NN(kSVOP->op_sv);
10277                 kSVOP->op_sv = sv;
10278             }
10279             if (SvOK(sv)) fbm_compile(sv, 0);
10280             TAINT_set(save_taint);
10281 #ifdef NO_TAINT_SUPPORT
10282             PERL_UNUSED_VAR(save_taint);
10283 #endif
10284         }
10285     }
10286     return ck_fun(o);
10287 }
10288
10289 OP *
10290 Perl_ck_lfun(pTHX_ OP *o)
10291 {
10292     const OPCODE type = o->op_type;
10293
10294     PERL_ARGS_ASSERT_CK_LFUN;
10295
10296     return modkids(ck_fun(o), type);
10297 }
10298
10299 OP *
10300 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
10301 {
10302     PERL_ARGS_ASSERT_CK_DEFINED;
10303
10304     if ((o->op_flags & OPf_KIDS)) {
10305         switch (cUNOPo->op_first->op_type) {
10306         case OP_RV2AV:
10307         case OP_PADAV:
10308             Perl_croak(aTHX_ "Can't use 'defined(@array)'"
10309                              " (Maybe you should just omit the defined()?)");
10310         break;
10311         case OP_RV2HV:
10312         case OP_PADHV:
10313             Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
10314                              " (Maybe you should just omit the defined()?)");
10315             break;
10316         default:
10317             /* no warning */
10318             break;
10319         }
10320     }
10321     return ck_rfun(o);
10322 }
10323
10324 OP *
10325 Perl_ck_readline(pTHX_ OP *o)
10326 {
10327     PERL_ARGS_ASSERT_CK_READLINE;
10328
10329     if (o->op_flags & OPf_KIDS) {
10330          OP *kid = cLISTOPo->op_first;
10331          if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
10332     }
10333     else {
10334         OP * const newop
10335             = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
10336         op_free(o);
10337         return newop;
10338     }
10339     return o;
10340 }
10341
10342 OP *
10343 Perl_ck_rfun(pTHX_ OP *o)
10344 {
10345     const OPCODE type = o->op_type;
10346
10347     PERL_ARGS_ASSERT_CK_RFUN;
10348
10349     return refkids(ck_fun(o), type);
10350 }
10351
10352 OP *
10353 Perl_ck_listiob(pTHX_ OP *o)
10354 {
10355     OP *kid;
10356
10357     PERL_ARGS_ASSERT_CK_LISTIOB;
10358
10359     kid = cLISTOPo->op_first;
10360     if (!kid) {
10361         o = force_list(o, 1);
10362         kid = cLISTOPo->op_first;
10363     }
10364     if (kid->op_type == OP_PUSHMARK)
10365         kid = OpSIBLING(kid);
10366     if (kid && o->op_flags & OPf_STACKED)
10367         kid = OpSIBLING(kid);
10368     else if (kid && !OpHAS_SIBLING(kid)) {              /* print HANDLE; */
10369         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
10370          && !kid->op_folded) {
10371             o->op_flags |= OPf_STACKED; /* make it a filehandle */
10372             scalar(kid);
10373             /* replace old const op with new OP_RV2GV parent */
10374             kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
10375                                         OP_RV2GV, OPf_REF);
10376             kid = OpSIBLING(kid);
10377         }
10378     }
10379
10380     if (!kid)
10381         op_append_elem(o->op_type, o, newDEFSVOP());
10382
10383     if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
10384     return listkids(o);
10385 }
10386
10387 OP *
10388 Perl_ck_smartmatch(pTHX_ OP *o)
10389 {
10390     dVAR;
10391     PERL_ARGS_ASSERT_CK_SMARTMATCH;
10392     if (0 == (o->op_flags & OPf_SPECIAL)) {
10393         OP *first  = cBINOPo->op_first;
10394         OP *second = OpSIBLING(first);
10395
10396         /* Implicitly take a reference to an array or hash */
10397
10398         /* remove the original two siblings, then add back the
10399          * (possibly different) first and second sibs.
10400          */
10401         op_sibling_splice(o, NULL, 1, NULL);
10402         op_sibling_splice(o, NULL, 1, NULL);
10403         first  = ref_array_or_hash(first);
10404         second = ref_array_or_hash(second);
10405         op_sibling_splice(o, NULL, 0, second);
10406         op_sibling_splice(o, NULL, 0, first);
10407
10408         /* Implicitly take a reference to a regular expression */
10409         if (first->op_type == OP_MATCH) {
10410             OpTYPE_set(first, OP_QR);
10411         }
10412         if (second->op_type == OP_MATCH) {
10413             OpTYPE_set(second, OP_QR);
10414         }
10415     }
10416
10417     return o;
10418 }
10419
10420
10421 static OP *
10422 S_maybe_targlex(pTHX_ OP *o)
10423 {
10424     OP * const kid = cLISTOPo->op_first;
10425     /* has a disposable target? */
10426     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
10427         && !(kid->op_flags & OPf_STACKED)
10428         /* Cannot steal the second time! */
10429         && !(kid->op_private & OPpTARGET_MY)
10430         )
10431     {
10432         OP * const kkid = OpSIBLING(kid);
10433
10434         /* Can just relocate the target. */
10435         if (kkid && kkid->op_type == OP_PADSV
10436             && (!(kkid->op_private & OPpLVAL_INTRO)
10437                || kkid->op_private & OPpPAD_STATE))
10438         {
10439             kid->op_targ = kkid->op_targ;
10440             kkid->op_targ = 0;
10441             /* Now we do not need PADSV and SASSIGN.
10442              * Detach kid and free the rest. */
10443             op_sibling_splice(o, NULL, 1, NULL);
10444             op_free(o);
10445             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
10446             return kid;
10447         }
10448     }
10449     return o;
10450 }
10451
10452 OP *
10453 Perl_ck_sassign(pTHX_ OP *o)
10454 {
10455     dVAR;
10456     OP * const kid = cLISTOPo->op_first;
10457
10458     PERL_ARGS_ASSERT_CK_SASSIGN;
10459
10460     if (OpHAS_SIBLING(kid)) {
10461         OP *kkid = OpSIBLING(kid);
10462         /* For state variable assignment with attributes, kkid is a list op
10463            whose op_last is a padsv. */
10464         if ((kkid->op_type == OP_PADSV ||
10465              (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
10466               (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
10467              )
10468             )
10469                 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
10470                     == (OPpLVAL_INTRO|OPpPAD_STATE)) {
10471             const PADOFFSET target = kkid->op_targ;
10472             OP *const other = newOP(OP_PADSV,
10473                                     kkid->op_flags
10474                                     | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
10475             OP *const first = newOP(OP_NULL, 0);
10476             OP *const nullop =
10477                 newCONDOP(0, first, o, other);
10478             /* XXX targlex disabled for now; see ticket #124160
10479                 newCONDOP(0, first, S_maybe_targlex(aTHX_ o), other);
10480              */
10481             OP *const condop = first->op_next;
10482
10483             OpTYPE_set(condop, OP_ONCE);
10484             other->op_targ = target;
10485             nullop->op_flags |= OPf_WANT_SCALAR;
10486
10487             /* Store the initializedness of state vars in a separate
10488                pad entry.  */
10489             condop->op_targ =
10490               pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
10491             /* hijacking PADSTALE for uninitialized state variables */
10492             SvPADSTALE_on(PAD_SVl(condop->op_targ));
10493
10494             return nullop;
10495         }
10496     }
10497     return S_maybe_targlex(aTHX_ o);
10498 }
10499
10500 OP *
10501 Perl_ck_match(pTHX_ OP *o)
10502 {
10503     PERL_UNUSED_CONTEXT;
10504     PERL_ARGS_ASSERT_CK_MATCH;
10505
10506     if (o->op_type == OP_MATCH || o->op_type == OP_QR)
10507         o->op_private |= OPpRUNTIME;
10508     return o;
10509 }
10510
10511 OP *
10512 Perl_ck_method(pTHX_ OP *o)
10513 {
10514     SV *sv, *methsv, *rclass;
10515     const char* method;
10516     char* compatptr;
10517     int utf8;
10518     STRLEN len, nsplit = 0, i;
10519     OP* new_op;
10520     OP * const kid = cUNOPo->op_first;
10521
10522     PERL_ARGS_ASSERT_CK_METHOD;
10523     if (kid->op_type != OP_CONST) return o;
10524
10525     sv = kSVOP->op_sv;
10526
10527     /* replace ' with :: */
10528     while ((compatptr = strchr(SvPVX(sv), '\''))) {
10529         *compatptr = ':';
10530         sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
10531     }
10532
10533     method = SvPVX_const(sv);
10534     len = SvCUR(sv);
10535     utf8 = SvUTF8(sv) ? -1 : 1;
10536
10537     for (i = len - 1; i > 0; --i) if (method[i] == ':') {
10538         nsplit = i+1;
10539         break;
10540     }
10541
10542     methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
10543
10544     if (!nsplit) { /* $proto->method() */
10545         op_free(o);
10546         return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
10547     }
10548
10549     if (nsplit == 7 && memEQ(method, "SUPER::", nsplit)) { /* $proto->SUPER::method() */
10550         op_free(o);
10551         return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
10552     }
10553
10554     /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
10555     if (nsplit >= 9 && strnEQ(method+nsplit-9, "::SUPER::", 9)) {
10556         rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
10557         new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
10558     } else {
10559         rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
10560         new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
10561     }
10562 #ifdef USE_ITHREADS
10563     op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
10564 #else
10565     cMETHOPx(new_op)->op_rclass_sv = rclass;
10566 #endif
10567     op_free(o);
10568     return new_op;
10569 }
10570
10571 OP *
10572 Perl_ck_null(pTHX_ OP *o)
10573 {
10574     PERL_ARGS_ASSERT_CK_NULL;
10575     PERL_UNUSED_CONTEXT;
10576     return o;
10577 }
10578
10579 OP *
10580 Perl_ck_open(pTHX_ OP *o)
10581 {
10582     PERL_ARGS_ASSERT_CK_OPEN;
10583
10584     S_io_hints(aTHX_ o);
10585     {
10586          /* In case of three-arg dup open remove strictness
10587           * from the last arg if it is a bareword. */
10588          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
10589          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
10590          OP *oa;
10591          const char *mode;
10592
10593          if ((last->op_type == OP_CONST) &&             /* The bareword. */
10594              (last->op_private & OPpCONST_BARE) &&
10595              (last->op_private & OPpCONST_STRICT) &&
10596              (oa = OpSIBLING(first)) &&         /* The fh. */
10597              (oa = OpSIBLING(oa)) &&                    /* The mode. */
10598              (oa->op_type == OP_CONST) &&
10599              SvPOK(((SVOP*)oa)->op_sv) &&
10600              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
10601              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
10602              (last == OpSIBLING(oa)))                   /* The bareword. */
10603               last->op_private &= ~OPpCONST_STRICT;
10604     }
10605     return ck_fun(o);
10606 }
10607
10608 OP *
10609 Perl_ck_prototype(pTHX_ OP *o)
10610 {
10611     PERL_ARGS_ASSERT_CK_PROTOTYPE;
10612     if (!(o->op_flags & OPf_KIDS)) {
10613         op_free(o);
10614         return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
10615     }
10616     return o;
10617 }
10618
10619 OP *
10620 Perl_ck_refassign(pTHX_ OP *o)
10621 {
10622     OP * const right = cLISTOPo->op_first;
10623     OP * const left = OpSIBLING(right);
10624     OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
10625     bool stacked = 0;
10626
10627     PERL_ARGS_ASSERT_CK_REFASSIGN;
10628     assert (left);
10629     assert (left->op_type == OP_SREFGEN);
10630
10631     o->op_private = 0;
10632     /* we use OPpPAD_STATE in refassign to mean either of those things,
10633      * and the code assumes the two flags occupy the same bit position
10634      * in the various ops below */
10635     assert(OPpPAD_STATE == OPpOUR_INTRO);
10636
10637     switch (varop->op_type) {
10638     case OP_PADAV:
10639         o->op_private |= OPpLVREF_AV;
10640         goto settarg;
10641     case OP_PADHV:
10642         o->op_private |= OPpLVREF_HV;
10643         /* FALLTHROUGH */
10644     case OP_PADSV:
10645       settarg:
10646         o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
10647         o->op_targ = varop->op_targ;
10648         varop->op_targ = 0;
10649         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
10650         break;
10651
10652     case OP_RV2AV:
10653         o->op_private |= OPpLVREF_AV;
10654         goto checkgv;
10655         NOT_REACHED; /* NOTREACHED */
10656     case OP_RV2HV:
10657         o->op_private |= OPpLVREF_HV;
10658         /* FALLTHROUGH */
10659     case OP_RV2SV:
10660       checkgv:
10661         o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
10662         if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
10663       detach_and_stack:
10664         /* Point varop to its GV kid, detached.  */
10665         varop = op_sibling_splice(varop, NULL, -1, NULL);
10666         stacked = TRUE;
10667         break;
10668     case OP_RV2CV: {
10669         OP * const kidparent =
10670             OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
10671         OP * const kid = cUNOPx(kidparent)->op_first;
10672         o->op_private |= OPpLVREF_CV;
10673         if (kid->op_type == OP_GV) {
10674             varop = kidparent;
10675             goto detach_and_stack;
10676         }
10677         if (kid->op_type != OP_PADCV)   goto bad;
10678         o->op_targ = kid->op_targ;
10679         kid->op_targ = 0;
10680         break;
10681     }
10682     case OP_AELEM:
10683     case OP_HELEM:
10684         o->op_private |= (varop->op_private & OPpLVAL_INTRO);
10685         o->op_private |= OPpLVREF_ELEM;
10686         op_null(varop);
10687         stacked = TRUE;
10688         /* Detach varop.  */
10689         op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
10690         break;
10691     default:
10692       bad:
10693         /* diag_listed_as: Can't modify reference to %s in %s assignment */
10694         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
10695                                 "assignment",
10696                                  OP_DESC(varop)));
10697         return o;
10698     }
10699     if (!FEATURE_REFALIASING_IS_ENABLED)
10700         Perl_croak(aTHX_
10701                   "Experimental aliasing via reference not enabled");
10702     Perl_ck_warner_d(aTHX_
10703                      packWARN(WARN_EXPERIMENTAL__REFALIASING),
10704                     "Aliasing via reference is experimental");
10705     if (stacked) {
10706         o->op_flags |= OPf_STACKED;
10707         op_sibling_splice(o, right, 1, varop);
10708     }
10709     else {
10710         o->op_flags &=~ OPf_STACKED;
10711         op_sibling_splice(o, right, 1, NULL);
10712     }
10713     op_free(left);
10714     return o;
10715 }
10716
10717 OP *
10718 Perl_ck_repeat(pTHX_ OP *o)
10719 {
10720     PERL_ARGS_ASSERT_CK_REPEAT;
10721
10722     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
10723         OP* kids;
10724         o->op_private |= OPpREPEAT_DOLIST;
10725         kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
10726         kids = force_list(kids, 1); /* promote it to a list */
10727         op_sibling_splice(o, NULL, 0, kids); /* and add back */
10728     }
10729     else
10730         scalar(o);
10731     return o;
10732 }
10733
10734 OP *
10735 Perl_ck_require(pTHX_ OP *o)
10736 {
10737     GV* gv;
10738
10739     PERL_ARGS_ASSERT_CK_REQUIRE;
10740
10741     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
10742         SVOP * const kid = (SVOP*)cUNOPo->op_first;
10743         HEK *hek;
10744         U32 hash;
10745         char *s;
10746         STRLEN len;
10747         if (kid->op_type == OP_CONST) {
10748           SV * const sv = kid->op_sv;
10749           U32 const was_readonly = SvREADONLY(sv);
10750           if (kid->op_private & OPpCONST_BARE) {
10751             dVAR;
10752             const char *end;
10753
10754             if (was_readonly) {
10755                     SvREADONLY_off(sv);
10756             }
10757             if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
10758
10759             s = SvPVX(sv);
10760             len = SvCUR(sv);
10761             end = s + len;
10762             /* treat ::foo::bar as foo::bar */
10763             if (len >= 2 && s[0] == ':' && s[1] == ':')
10764                 DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
10765             if (s == end)
10766                 DIE(aTHX_ "Bareword in require maps to empty filename");
10767
10768             for (; s < end; s++) {
10769                 if (*s == ':' && s[1] == ':') {
10770                     *s = '/';
10771                     Move(s+2, s+1, end - s - 1, char);
10772                     --end;
10773                 }
10774             }
10775             SvEND_set(sv, end);
10776             sv_catpvs(sv, ".pm");
10777             PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
10778             hek = share_hek(SvPVX(sv),
10779                             (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
10780                             hash);
10781             sv_sethek(sv, hek);
10782             unshare_hek(hek);
10783             SvFLAGS(sv) |= was_readonly;
10784           }
10785           else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
10786                 && !SvVOK(sv)) {
10787             s = SvPV(sv, len);
10788             if (SvREFCNT(sv) > 1) {
10789                 kid->op_sv = newSVpvn_share(
10790                     s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
10791                 SvREFCNT_dec_NN(sv);
10792             }
10793             else {
10794                 dVAR;
10795                 if (was_readonly) SvREADONLY_off(sv);
10796                 PERL_HASH(hash, s, len);
10797                 hek = share_hek(s,
10798                                 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
10799                                 hash);
10800                 sv_sethek(sv, hek);
10801                 unshare_hek(hek);
10802                 SvFLAGS(sv) |= was_readonly;
10803             }
10804           }
10805         }
10806     }
10807
10808     if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
10809         /* handle override, if any */
10810      && (gv = gv_override("require", 7))) {
10811         OP *kid, *newop;
10812         if (o->op_flags & OPf_KIDS) {
10813             kid = cUNOPo->op_first;
10814             op_sibling_splice(o, NULL, -1, NULL);
10815         }
10816         else {
10817             kid = newDEFSVOP();
10818         }
10819         op_free(o);
10820         newop = S_new_entersubop(aTHX_ gv, kid);
10821         return newop;
10822     }
10823
10824     return ck_fun(o);
10825 }
10826
10827 OP *
10828 Perl_ck_return(pTHX_ OP *o)
10829 {
10830     OP *kid;
10831
10832     PERL_ARGS_ASSERT_CK_RETURN;
10833
10834     kid = OpSIBLING(cLISTOPo->op_first);
10835     if (CvLVALUE(PL_compcv)) {
10836         for (; kid; kid = OpSIBLING(kid))
10837             op_lvalue(kid, OP_LEAVESUBLV);
10838     }
10839
10840     return o;
10841 }
10842
10843 OP *
10844 Perl_ck_select(pTHX_ OP *o)
10845 {
10846     dVAR;
10847     OP* kid;
10848
10849     PERL_ARGS_ASSERT_CK_SELECT;
10850
10851     if (o->op_flags & OPf_KIDS) {
10852         kid = OpSIBLING(cLISTOPo->op_first);     /* get past pushmark */
10853         if (kid && OpHAS_SIBLING(kid)) {
10854             OpTYPE_set(o, OP_SSELECT);
10855             o = ck_fun(o);
10856             return fold_constants(op_integerize(op_std_init(o)));
10857         }
10858     }
10859     o = ck_fun(o);
10860     kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
10861     if (kid && kid->op_type == OP_RV2GV)
10862         kid->op_private &= ~HINT_STRICT_REFS;
10863     return o;
10864 }
10865
10866 OP *
10867 Perl_ck_shift(pTHX_ OP *o)
10868 {
10869     const I32 type = o->op_type;
10870
10871     PERL_ARGS_ASSERT_CK_SHIFT;
10872
10873     if (!(o->op_flags & OPf_KIDS)) {
10874         OP *argop;
10875
10876         if (!CvUNIQUE(PL_compcv)) {
10877             o->op_flags |= OPf_SPECIAL;
10878             return o;
10879         }
10880
10881         argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
10882         op_free(o);
10883         return newUNOP(type, 0, scalar(argop));
10884     }
10885     return scalar(ck_fun(o));
10886 }
10887
10888 OP *
10889 Perl_ck_sort(pTHX_ OP *o)
10890 {
10891     OP *firstkid;
10892     OP *kid;
10893     HV * const hinthv =
10894         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
10895     U8 stacked;
10896
10897     PERL_ARGS_ASSERT_CK_SORT;
10898
10899     if (hinthv) {
10900             SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
10901             if (svp) {
10902                 const I32 sorthints = (I32)SvIV(*svp);
10903                 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
10904                     o->op_private |= OPpSORT_QSORT;
10905                 if ((sorthints & HINT_SORT_STABLE) != 0)
10906                     o->op_private |= OPpSORT_STABLE;
10907             }
10908     }
10909
10910     if (o->op_flags & OPf_STACKED)
10911         simplify_sort(o);
10912     firstkid = OpSIBLING(cLISTOPo->op_first);           /* get past pushmark */
10913
10914     if ((stacked = o->op_flags & OPf_STACKED)) {        /* may have been cleared */
10915         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
10916
10917         /* if the first arg is a code block, process it and mark sort as
10918          * OPf_SPECIAL */
10919         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
10920             LINKLIST(kid);
10921             if (kid->op_type == OP_LEAVE)
10922                     op_null(kid);                       /* wipe out leave */
10923             /* Prevent execution from escaping out of the sort block. */
10924             kid->op_next = 0;
10925
10926             /* provide scalar context for comparison function/block */
10927             kid = scalar(firstkid);
10928             kid->op_next = kid;
10929             o->op_flags |= OPf_SPECIAL;
10930         }
10931         else if (kid->op_type == OP_CONST
10932               && kid->op_private & OPpCONST_BARE) {
10933             char tmpbuf[256];
10934             STRLEN len;
10935             PADOFFSET off;
10936             const char * const name = SvPV(kSVOP_sv, len);
10937             *tmpbuf = '&';
10938             assert (len < 256);
10939             Copy(name, tmpbuf+1, len, char);
10940             off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv));
10941             if (off != NOT_IN_PAD) {
10942                 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
10943                     SV * const fq =
10944                         newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
10945                     sv_catpvs(fq, "::");
10946                     sv_catsv(fq, kSVOP_sv);
10947                     SvREFCNT_dec_NN(kSVOP_sv);
10948                     kSVOP->op_sv = fq;
10949                 }
10950                 else {
10951                     OP * const padop = newOP(OP_PADCV, 0);
10952                     padop->op_targ = off;
10953                     /* replace the const op with the pad op */
10954                     op_sibling_splice(firstkid, NULL, 1, padop);
10955                     op_free(kid);
10956                 }
10957             }
10958         }
10959
10960         firstkid = OpSIBLING(firstkid);
10961     }
10962
10963     for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
10964         /* provide list context for arguments */
10965         list(kid);
10966         if (stacked)
10967             op_lvalue(kid, OP_GREPSTART);
10968     }
10969
10970     return o;
10971 }
10972
10973 /* for sort { X } ..., where X is one of
10974  *   $a <=> $b, $b <= $a, $a cmp $b, $b cmp $a
10975  * elide the second child of the sort (the one containing X),
10976  * and set these flags as appropriate
10977         OPpSORT_NUMERIC;
10978         OPpSORT_INTEGER;
10979         OPpSORT_DESCEND;
10980  * Also, check and warn on lexical $a, $b.
10981  */
10982
10983 STATIC void
10984 S_simplify_sort(pTHX_ OP *o)
10985 {
10986     OP *kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
10987     OP *k;
10988     int descending;
10989     GV *gv;
10990     const char *gvname;
10991     bool have_scopeop;
10992
10993     PERL_ARGS_ASSERT_SIMPLIFY_SORT;
10994
10995     kid = kUNOP->op_first;                              /* get past null */
10996     if (!(have_scopeop = kid->op_type == OP_SCOPE)
10997      && kid->op_type != OP_LEAVE)
10998         return;
10999     kid = kLISTOP->op_last;                             /* get past scope */
11000     switch(kid->op_type) {
11001         case OP_NCMP:
11002         case OP_I_NCMP:
11003         case OP_SCMP:
11004             if (!have_scopeop) goto padkids;
11005             break;
11006         default:
11007             return;
11008     }
11009     k = kid;                                            /* remember this node*/
11010     if (kBINOP->op_first->op_type != OP_RV2SV
11011      || kBINOP->op_last ->op_type != OP_RV2SV)
11012     {
11013         /*
11014            Warn about my($a) or my($b) in a sort block, *if* $a or $b is
11015            then used in a comparison.  This catches most, but not
11016            all cases.  For instance, it catches
11017                sort { my($a); $a <=> $b }
11018            but not
11019                sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
11020            (although why you'd do that is anyone's guess).
11021         */
11022
11023        padkids:
11024         if (!ckWARN(WARN_SYNTAX)) return;
11025         kid = kBINOP->op_first;
11026         do {
11027             if (kid->op_type == OP_PADSV) {
11028                 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
11029                 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
11030                  && (  PadnamePV(name)[1] == 'a'
11031                     || PadnamePV(name)[1] == 'b'  ))
11032                     /* diag_listed_as: "my %s" used in sort comparison */
11033                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11034                                      "\"%s %s\" used in sort comparison",
11035                                       PadnameIsSTATE(name)
11036                                         ? "state"
11037                                         : "my",
11038                                       PadnamePV(name));
11039             }
11040         } while ((kid = OpSIBLING(kid)));
11041         return;
11042     }
11043     kid = kBINOP->op_first;                             /* get past cmp */
11044     if (kUNOP->op_first->op_type != OP_GV)
11045         return;
11046     kid = kUNOP->op_first;                              /* get past rv2sv */
11047     gv = kGVOP_gv;
11048     if (GvSTASH(gv) != PL_curstash)
11049         return;
11050     gvname = GvNAME(gv);
11051     if (*gvname == 'a' && gvname[1] == '\0')
11052         descending = 0;
11053     else if (*gvname == 'b' && gvname[1] == '\0')
11054         descending = 1;
11055     else
11056         return;
11057
11058     kid = k;                                            /* back to cmp */
11059     /* already checked above that it is rv2sv */
11060     kid = kBINOP->op_last;                              /* down to 2nd arg */
11061     if (kUNOP->op_first->op_type != OP_GV)
11062         return;
11063     kid = kUNOP->op_first;                              /* get past rv2sv */
11064     gv = kGVOP_gv;
11065     if (GvSTASH(gv) != PL_curstash)
11066         return;
11067     gvname = GvNAME(gv);
11068     if ( descending
11069          ? !(*gvname == 'a' && gvname[1] == '\0')
11070          : !(*gvname == 'b' && gvname[1] == '\0'))
11071         return;
11072     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
11073     if (descending)
11074         o->op_private |= OPpSORT_DESCEND;
11075     if (k->op_type == OP_NCMP)
11076         o->op_private |= OPpSORT_NUMERIC;
11077     if (k->op_type == OP_I_NCMP)
11078         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
11079     kid = OpSIBLING(cLISTOPo->op_first);
11080     /* cut out and delete old block (second sibling) */
11081     op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
11082     op_free(kid);
11083 }
11084
11085 OP *
11086 Perl_ck_split(pTHX_ OP *o)
11087 {
11088     dVAR;
11089     OP *kid;
11090
11091     PERL_ARGS_ASSERT_CK_SPLIT;
11092
11093     if (o->op_flags & OPf_STACKED)
11094         return no_fh_allowed(o);
11095
11096     kid = cLISTOPo->op_first;
11097     if (kid->op_type != OP_NULL)
11098         Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
11099     /* delete leading NULL node, then add a CONST if no other nodes */
11100     op_sibling_splice(o, NULL, 1,
11101         OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
11102     op_free(kid);
11103     kid = cLISTOPo->op_first;
11104
11105     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
11106         /* remove kid, and replace with new optree */
11107         op_sibling_splice(o, NULL, 1, NULL);
11108         /* OPf_SPECIAL is used to trigger split " " behavior */
11109         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, NULL, 0, 0);
11110         op_sibling_splice(o, NULL, 0, kid);
11111     }
11112     OpTYPE_set(kid, OP_PUSHRE);
11113     /* target implies @ary=..., so wipe it */
11114     kid->op_targ = 0;
11115     scalar(kid);
11116     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
11117       Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
11118                      "Use of /g modifier is meaningless in split");
11119     }
11120
11121     if (!OpHAS_SIBLING(kid))
11122         op_append_elem(OP_SPLIT, o, newDEFSVOP());
11123
11124     kid = OpSIBLING(kid);
11125     assert(kid);
11126     scalar(kid);
11127
11128     if (!OpHAS_SIBLING(kid))
11129     {
11130         op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
11131         o->op_private |= OPpSPLIT_IMPLIM;
11132     }
11133     assert(OpHAS_SIBLING(kid));
11134
11135     kid = OpSIBLING(kid);
11136     scalar(kid);
11137
11138     if (OpHAS_SIBLING(kid))
11139         return too_many_arguments_pv(o,OP_DESC(o), 0);
11140
11141     return o;
11142 }
11143
11144 OP *
11145 Perl_ck_stringify(pTHX_ OP *o)
11146 {
11147     OP * const kid = OpSIBLING(cUNOPo->op_first);
11148     PERL_ARGS_ASSERT_CK_STRINGIFY;
11149     if ((   kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
11150          || kid->op_type == OP_LC   || kid->op_type == OP_LCFIRST
11151          || kid->op_type == OP_UC   || kid->op_type == OP_UCFIRST)
11152         && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
11153     {
11154         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
11155         op_free(o);
11156         return kid;
11157     }
11158     return ck_fun(o);
11159 }
11160
11161 OP *
11162 Perl_ck_join(pTHX_ OP *o)
11163 {
11164     OP * const kid = OpSIBLING(cLISTOPo->op_first);
11165
11166     PERL_ARGS_ASSERT_CK_JOIN;
11167
11168     if (kid && kid->op_type == OP_MATCH) {
11169         if (ckWARN(WARN_SYNTAX)) {
11170             const REGEXP *re = PM_GETRE(kPMOP);
11171             const SV *msg = re
11172                     ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
11173                                             SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
11174                     : newSVpvs_flags( "STRING", SVs_TEMP );
11175             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11176                         "/%"SVf"/ should probably be written as \"%"SVf"\"",
11177                         SVfARG(msg), SVfARG(msg));
11178         }
11179     }
11180     if (kid
11181      && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
11182         || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
11183         || (  kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
11184            && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
11185     {
11186         const OP * const bairn = OpSIBLING(kid); /* the list */
11187         if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
11188          && OP_GIMME(bairn,0) == G_SCALAR)
11189         {
11190             OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
11191                                      op_sibling_splice(o, kid, 1, NULL));
11192             op_free(o);
11193             return ret;
11194         }
11195     }
11196
11197     return ck_fun(o);
11198 }
11199
11200 /*
11201 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
11202
11203 Examines an op, which is expected to identify a subroutine at runtime,
11204 and attempts to determine at compile time which subroutine it identifies.
11205 This is normally used during Perl compilation to determine whether
11206 a prototype can be applied to a function call.  C<cvop> is the op
11207 being considered, normally an C<rv2cv> op.  A pointer to the identified
11208 subroutine is returned, if it could be determined statically, and a null
11209 pointer is returned if it was not possible to determine statically.
11210
11211 Currently, the subroutine can be identified statically if the RV that the
11212 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
11213 A C<gv> op is suitable if the GV's CV slot is populated.  A C<const> op is
11214 suitable if the constant value must be an RV pointing to a CV.  Details of
11215 this process may change in future versions of Perl.  If the C<rv2cv> op
11216 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
11217 the subroutine statically: this flag is used to suppress compile-time
11218 magic on a subroutine call, forcing it to use default runtime behaviour.
11219
11220 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
11221 of a GV reference is modified.  If a GV was examined and its CV slot was
11222 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
11223 If the op is not optimised away, and the CV slot is later populated with
11224 a subroutine having a prototype, that flag eventually triggers the warning
11225 "called too early to check prototype".
11226
11227 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
11228 of returning a pointer to the subroutine it returns a pointer to the
11229 GV giving the most appropriate name for the subroutine in this context.
11230 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
11231 (C<CvANON>) subroutine that is referenced through a GV it will be the
11232 referencing GV.  The resulting C<GV*> is cast to C<CV*> to be returned.
11233 A null pointer is returned as usual if there is no statically-determinable
11234 subroutine.
11235
11236 =cut
11237 */
11238
11239 /* shared by toke.c:yylex */
11240 CV *
11241 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
11242 {
11243     PADNAME *name = PAD_COMPNAME(off);
11244     CV *compcv = PL_compcv;
11245     while (PadnameOUTER(name)) {
11246         assert(PARENT_PAD_INDEX(name));
11247         compcv = CvOUTSIDE(compcv);
11248         name = PadlistNAMESARRAY(CvPADLIST(compcv))
11249                 [off = PARENT_PAD_INDEX(name)];
11250     }
11251     assert(!PadnameIsOUR(name));
11252     if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
11253         return PadnamePROTOCV(name);
11254     }
11255     return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
11256 }
11257
11258 CV *
11259 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
11260 {
11261     OP *rvop;
11262     CV *cv;
11263     GV *gv;
11264     PERL_ARGS_ASSERT_RV2CV_OP_CV;
11265     if (flags & ~RV2CVOPCV_FLAG_MASK)
11266         Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
11267     if (cvop->op_type != OP_RV2CV)
11268         return NULL;
11269     if (cvop->op_private & OPpENTERSUB_AMPER)
11270         return NULL;
11271     if (!(cvop->op_flags & OPf_KIDS))
11272         return NULL;
11273     rvop = cUNOPx(cvop)->op_first;
11274     switch (rvop->op_type) {
11275         case OP_GV: {
11276             gv = cGVOPx_gv(rvop);
11277             if (!isGV(gv)) {
11278                 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
11279                     cv = MUTABLE_CV(SvRV(gv));
11280                     gv = NULL;
11281                     break;
11282                 }
11283                 if (flags & RV2CVOPCV_RETURN_STUB)
11284                     return (CV *)gv;
11285                 else return NULL;
11286             }
11287             cv = GvCVu(gv);
11288             if (!cv) {
11289                 if (flags & RV2CVOPCV_MARK_EARLY)
11290                     rvop->op_private |= OPpEARLY_CV;
11291                 return NULL;
11292             }
11293         } break;
11294         case OP_CONST: {
11295             SV *rv = cSVOPx_sv(rvop);
11296             if (!SvROK(rv))
11297                 return NULL;
11298             cv = (CV*)SvRV(rv);
11299             gv = NULL;
11300         } break;
11301         case OP_PADCV: {
11302             cv = find_lexical_cv(rvop->op_targ);
11303             gv = NULL;
11304         } break;
11305         default: {
11306             return NULL;
11307         } NOT_REACHED; /* NOTREACHED */
11308     }
11309     if (SvTYPE((SV*)cv) != SVt_PVCV)
11310         return NULL;
11311     if (flags & (RV2CVOPCV_RETURN_NAME_GV|RV2CVOPCV_MAYBE_NAME_GV)) {
11312         if ((!CvANON(cv) || !gv) && !CvLEXICAL(cv)
11313          && ((flags & RV2CVOPCV_RETURN_NAME_GV) || !CvNAMED(cv)))
11314             gv = CvGV(cv);
11315         return (CV*)gv;
11316     } else {
11317         return cv;
11318     }
11319 }
11320
11321 /*
11322 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
11323
11324 Performs the default fixup of the arguments part of an C<entersub>
11325 op tree.  This consists of applying list context to each of the
11326 argument ops.  This is the standard treatment used on a call marked
11327 with C<&>, or a method call, or a call through a subroutine reference,
11328 or any other call where the callee can't be identified at compile time,
11329 or a call where the callee has no prototype.
11330
11331 =cut
11332 */
11333
11334 OP *
11335 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
11336 {
11337     OP *aop;
11338
11339     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
11340
11341     aop = cUNOPx(entersubop)->op_first;
11342     if (!OpHAS_SIBLING(aop))
11343         aop = cUNOPx(aop)->op_first;
11344     for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
11345         /* skip the extra attributes->import() call implicitly added in
11346          * something like foo(my $x : bar)
11347          */
11348         if (   aop->op_type == OP_ENTERSUB
11349             && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
11350         )
11351             continue;
11352         list(aop);
11353         op_lvalue(aop, OP_ENTERSUB);
11354     }
11355     return entersubop;
11356 }
11357
11358 /*
11359 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
11360
11361 Performs the fixup of the arguments part of an C<entersub> op tree
11362 based on a subroutine prototype.  This makes various modifications to
11363 the argument ops, from applying context up to inserting C<refgen> ops,
11364 and checking the number and syntactic types of arguments, as directed by
11365 the prototype.  This is the standard treatment used on a subroutine call,
11366 not marked with C<&>, where the callee can be identified at compile time
11367 and has a prototype.
11368
11369 C<protosv> supplies the subroutine prototype to be applied to the call.
11370 It may be a normal defined scalar, of which the string value will be used.
11371 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11372 that has been cast to C<SV*>) which has a prototype.  The prototype
11373 supplied, in whichever form, does not need to match the actual callee
11374 referenced by the op tree.
11375
11376 If the argument ops disagree with the prototype, for example by having
11377 an unacceptable number of arguments, a valid op tree is returned anyway.
11378 The error is reflected in the parser state, normally resulting in a single
11379 exception at the top level of parsing which covers all the compilation
11380 errors that occurred.  In the error message, the callee is referred to
11381 by the name defined by the C<namegv> parameter.
11382
11383 =cut
11384 */
11385
11386 OP *
11387 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11388 {
11389     STRLEN proto_len;
11390     const char *proto, *proto_end;
11391     OP *aop, *prev, *cvop, *parent;
11392     int optional = 0;
11393     I32 arg = 0;
11394     I32 contextclass = 0;
11395     const char *e = NULL;
11396     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
11397     if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
11398         Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
11399                    "flags=%lx", (unsigned long) SvFLAGS(protosv));
11400     if (SvTYPE(protosv) == SVt_PVCV)
11401          proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
11402     else proto = SvPV(protosv, proto_len);
11403     proto = S_strip_spaces(aTHX_ proto, &proto_len);
11404     proto_end = proto + proto_len;
11405     parent = entersubop;
11406     aop = cUNOPx(entersubop)->op_first;
11407     if (!OpHAS_SIBLING(aop)) {
11408         parent = aop;
11409         aop = cUNOPx(aop)->op_first;
11410     }
11411     prev = aop;
11412     aop = OpSIBLING(aop);
11413     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11414     while (aop != cvop) {
11415         OP* o3 = aop;
11416
11417         if (proto >= proto_end)
11418         {
11419             SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11420             yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf,
11421                                         SVfARG(namesv)), SvUTF8(namesv));
11422             return entersubop;
11423         }
11424
11425         switch (*proto) {
11426             case ';':
11427                 optional = 1;
11428                 proto++;
11429                 continue;
11430             case '_':
11431                 /* _ must be at the end */
11432                 if (proto[1] && !strchr(";@%", proto[1]))
11433                     goto oops;
11434                 /* FALLTHROUGH */
11435             case '$':
11436                 proto++;
11437                 arg++;
11438                 scalar(aop);
11439                 break;
11440             case '%':
11441             case '@':
11442                 list(aop);
11443                 arg++;
11444                 break;
11445             case '&':
11446                 proto++;
11447                 arg++;
11448                 if (    o3->op_type != OP_UNDEF
11449                     && (o3->op_type != OP_SREFGEN
11450                         || (  cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
11451                                 != OP_ANONCODE
11452                             && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
11453                                 != OP_RV2CV)))
11454                     bad_type_gv(arg, namegv, o3,
11455                             arg == 1 ? "block or sub {}" : "sub {}");
11456                 break;
11457             case '*':
11458                 /* '*' allows any scalar type, including bareword */
11459                 proto++;
11460                 arg++;
11461                 if (o3->op_type == OP_RV2GV)
11462                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
11463                 else if (o3->op_type == OP_CONST)
11464                     o3->op_private &= ~OPpCONST_STRICT;
11465                 scalar(aop);
11466                 break;
11467             case '+':
11468                 proto++;
11469                 arg++;
11470                 if (o3->op_type == OP_RV2AV ||
11471                     o3->op_type == OP_PADAV ||
11472                     o3->op_type == OP_RV2HV ||
11473                     o3->op_type == OP_PADHV
11474                 ) {
11475                     goto wrapref;
11476                 }
11477                 scalar(aop);
11478                 break;
11479             case '[': case ']':
11480                 goto oops;
11481
11482             case '\\':
11483                 proto++;
11484                 arg++;
11485             again:
11486                 switch (*proto++) {
11487                     case '[':
11488                         if (contextclass++ == 0) {
11489                             e = strchr(proto, ']');
11490                             if (!e || e == proto)
11491                                 goto oops;
11492                         }
11493                         else
11494                             goto oops;
11495                         goto again;
11496
11497                     case ']':
11498                         if (contextclass) {
11499                             const char *p = proto;
11500                             const char *const end = proto;
11501                             contextclass = 0;
11502                             while (*--p != '[')
11503                                 /* \[$] accepts any scalar lvalue */
11504                                 if (*p == '$'
11505                                  && Perl_op_lvalue_flags(aTHX_
11506                                      scalar(o3),
11507                                      OP_READ, /* not entersub */
11508                                      OP_LVALUE_NO_CROAK
11509                                     )) goto wrapref;
11510                             bad_type_gv(arg, namegv, o3,
11511                                     Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
11512                         } else
11513                             goto oops;
11514                         break;
11515                     case '*':
11516                         if (o3->op_type == OP_RV2GV)
11517                             goto wrapref;
11518                         if (!contextclass)
11519                             bad_type_gv(arg, namegv, o3, "symbol");
11520                         break;
11521                     case '&':
11522                         if (o3->op_type == OP_ENTERSUB
11523                          && !(o3->op_flags & OPf_STACKED))
11524                             goto wrapref;
11525                         if (!contextclass)
11526                             bad_type_gv(arg, namegv, o3, "subroutine");
11527                         break;
11528                     case '$':
11529                         if (o3->op_type == OP_RV2SV ||
11530                                 o3->op_type == OP_PADSV ||
11531                                 o3->op_type == OP_HELEM ||
11532                                 o3->op_type == OP_AELEM)
11533                             goto wrapref;
11534                         if (!contextclass) {
11535                             /* \$ accepts any scalar lvalue */
11536                             if (Perl_op_lvalue_flags(aTHX_
11537                                     scalar(o3),
11538                                     OP_READ,  /* not entersub */
11539                                     OP_LVALUE_NO_CROAK
11540                                )) goto wrapref;
11541                             bad_type_gv(arg, namegv, o3, "scalar");
11542                         }
11543                         break;
11544                     case '@':
11545                         if (o3->op_type == OP_RV2AV ||
11546                                 o3->op_type == OP_PADAV)
11547                         {
11548                             o3->op_flags &=~ OPf_PARENS;
11549                             goto wrapref;
11550                         }
11551                         if (!contextclass)
11552                             bad_type_gv(arg, namegv, o3, "array");
11553                         break;
11554                     case '%':
11555                         if (o3->op_type == OP_RV2HV ||
11556                                 o3->op_type == OP_PADHV)
11557                         {
11558                             o3->op_flags &=~ OPf_PARENS;
11559                             goto wrapref;
11560                         }
11561                         if (!contextclass)
11562                             bad_type_gv(arg, namegv, o3, "hash");
11563                         break;
11564                     wrapref:
11565                             aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
11566                                                 OP_REFGEN, 0);
11567                         if (contextclass && e) {
11568                             proto = e + 1;
11569                             contextclass = 0;
11570                         }
11571                         break;
11572                     default: goto oops;
11573                 }
11574                 if (contextclass)
11575                     goto again;
11576                 break;
11577             case ' ':
11578                 proto++;
11579                 continue;
11580             default:
11581             oops: {
11582                 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
11583                                   SVfARG(cv_name((CV *)namegv, NULL, 0)),
11584                                   SVfARG(protosv));
11585             }
11586         }
11587
11588         op_lvalue(aop, OP_ENTERSUB);
11589         prev = aop;
11590         aop = OpSIBLING(aop);
11591     }
11592     if (aop == cvop && *proto == '_') {
11593         /* generate an access to $_ */
11594         op_sibling_splice(parent, prev, 0, newDEFSVOP());
11595     }
11596     if (!optional && proto_end > proto &&
11597         (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
11598     {
11599         SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11600         yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf,
11601                                     SVfARG(namesv)), SvUTF8(namesv));
11602     }
11603     return entersubop;
11604 }
11605
11606 /*
11607 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
11608
11609 Performs the fixup of the arguments part of an C<entersub> op tree either
11610 based on a subroutine prototype or using default list-context processing.
11611 This is the standard treatment used on a subroutine call, not marked
11612 with C<&>, where the callee can be identified at compile time.
11613
11614 C<protosv> supplies the subroutine prototype to be applied to the call,
11615 or indicates that there is no prototype.  It may be a normal scalar,
11616 in which case if it is defined then the string value will be used
11617 as a prototype, and if it is undefined then there is no prototype.
11618 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11619 that has been cast to C<SV*>), of which the prototype will be used if it
11620 has one.  The prototype (or lack thereof) supplied, in whichever form,
11621 does not need to match the actual callee referenced by the op tree.
11622
11623 If the argument ops disagree with the prototype, for example by having
11624 an unacceptable number of arguments, a valid op tree is returned anyway.
11625 The error is reflected in the parser state, normally resulting in a single
11626 exception at the top level of parsing which covers all the compilation
11627 errors that occurred.  In the error message, the callee is referred to
11628 by the name defined by the C<namegv> parameter.
11629
11630 =cut
11631 */
11632
11633 OP *
11634 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
11635         GV *namegv, SV *protosv)
11636 {
11637     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
11638     if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
11639         return ck_entersub_args_proto(entersubop, namegv, protosv);
11640     else
11641         return ck_entersub_args_list(entersubop);
11642 }
11643
11644 OP *
11645 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11646 {
11647     int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
11648     OP *aop = cUNOPx(entersubop)->op_first;
11649
11650     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
11651
11652     if (!opnum) {
11653         OP *cvop;
11654         if (!OpHAS_SIBLING(aop))
11655             aop = cUNOPx(aop)->op_first;
11656         aop = OpSIBLING(aop);
11657         for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11658         if (aop != cvop)
11659             (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
11660
11661         op_free(entersubop);
11662         switch(GvNAME(namegv)[2]) {
11663         case 'F': return newSVOP(OP_CONST, 0,
11664                                         newSVpv(CopFILE(PL_curcop),0));
11665         case 'L': return newSVOP(
11666                            OP_CONST, 0,
11667                            Perl_newSVpvf(aTHX_
11668                              "%"IVdf, (IV)CopLINE(PL_curcop)
11669                            )
11670                          );
11671         case 'P': return newSVOP(OP_CONST, 0,
11672                                    (PL_curstash
11673                                      ? newSVhek(HvNAME_HEK(PL_curstash))
11674                                      : &PL_sv_undef
11675                                    )
11676                                 );
11677         }
11678         NOT_REACHED; /* NOTREACHED */
11679     }
11680     else {
11681         OP *prev, *cvop, *first, *parent;
11682         U32 flags = 0;
11683
11684         parent = entersubop;
11685         if (!OpHAS_SIBLING(aop)) {
11686             parent = aop;
11687             aop = cUNOPx(aop)->op_first;
11688         }
11689
11690         first = prev = aop;
11691         aop = OpSIBLING(aop);
11692         /* find last sibling */
11693         for (cvop = aop;
11694              OpHAS_SIBLING(cvop);
11695              prev = cvop, cvop = OpSIBLING(cvop))
11696             ;
11697         if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
11698             /* Usually, OPf_SPECIAL on an op with no args means that it had
11699              * parens, but these have their own meaning for that flag: */
11700             && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
11701             && opnum != OP_DELETE && opnum != OP_EXISTS)
11702                 flags |= OPf_SPECIAL;
11703         /* excise cvop from end of sibling chain */
11704         op_sibling_splice(parent, prev, 1, NULL);
11705         op_free(cvop);
11706         if (aop == cvop) aop = NULL;
11707
11708         /* detach remaining siblings from the first sibling, then
11709          * dispose of original optree */
11710
11711         if (aop)
11712             op_sibling_splice(parent, first, -1, NULL);
11713         op_free(entersubop);
11714
11715         if (opnum == OP_ENTEREVAL
11716          && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
11717             flags |= OPpEVAL_BYTES <<8;
11718
11719         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
11720         case OA_UNOP:
11721         case OA_BASEOP_OR_UNOP:
11722         case OA_FILESTATOP:
11723             return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
11724         case OA_BASEOP:
11725             if (aop) {
11726                     (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
11727                 op_free(aop);
11728             }
11729             return opnum == OP_RUNCV
11730                 ? newPVOP(OP_RUNCV,0,NULL)
11731                 : newOP(opnum,0);
11732         default:
11733             return op_convert_list(opnum,0,aop);
11734         }
11735     }
11736     NOT_REACHED; /* NOTREACHED */
11737     return entersubop;
11738 }
11739
11740 /*
11741 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
11742
11743 Retrieves the function that will be used to fix up a call to C<cv>.
11744 Specifically, the function is applied to an C<entersub> op tree for a
11745 subroutine call, not marked with C<&>, where the callee can be identified
11746 at compile time as C<cv>.
11747
11748 The C-level function pointer is returned in C<*ckfun_p>, and an SV
11749 argument for it is returned in C<*ckobj_p>.  The function is intended
11750 to be called in this manner:
11751
11752  entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
11753
11754 In this call, C<entersubop> is a pointer to the C<entersub> op,
11755 which may be replaced by the check function, and C<namegv> is a GV
11756 supplying the name that should be used by the check function to refer
11757 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11758 It is permitted to apply the check function in non-standard situations,
11759 such as to a call to a different subroutine or to a method call.
11760
11761 By default, the function is
11762 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
11763 and the SV parameter is C<cv> itself.  This implements standard
11764 prototype processing.  It can be changed, for a particular subroutine,
11765 by L</cv_set_call_checker>.
11766
11767 =cut
11768 */
11769
11770 static void
11771 S_cv_get_call_checker(CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p,
11772                       U8 *flagsp)
11773 {
11774     MAGIC *callmg;
11775     callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
11776     if (callmg) {
11777         *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
11778         *ckobj_p = callmg->mg_obj;
11779         if (flagsp) *flagsp = callmg->mg_flags;
11780     } else {
11781         *ckfun_p = Perl_ck_entersub_args_proto_or_list;
11782         *ckobj_p = (SV*)cv;
11783         if (flagsp) *flagsp = 0;
11784     }
11785 }
11786
11787 void
11788 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
11789 {
11790     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
11791     PERL_UNUSED_CONTEXT;
11792     S_cv_get_call_checker(cv, ckfun_p, ckobj_p, NULL);
11793 }
11794
11795 /*
11796 =for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 flags
11797
11798 Sets the function that will be used to fix up a call to C<cv>.
11799 Specifically, the function is applied to an C<entersub> op tree for a
11800 subroutine call, not marked with C<&>, where the callee can be identified
11801 at compile time as C<cv>.
11802
11803 The C-level function pointer is supplied in C<ckfun>, and an SV argument
11804 for it is supplied in C<ckobj>.  The function should be defined like this:
11805
11806     STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
11807
11808 It is intended to be called in this manner:
11809
11810     entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
11811
11812 In this call, C<entersubop> is a pointer to the C<entersub> op,
11813 which may be replaced by the check function, and C<namegv> supplies
11814 the name that should be used by the check function to refer
11815 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11816 It is permitted to apply the check function in non-standard situations,
11817 such as to a call to a different subroutine or to a method call.
11818
11819 C<namegv> may not actually be a GV.  For efficiency, perl may pass a
11820 CV or other SV instead.  Whatever is passed can be used as the first
11821 argument to L</cv_name>.  You can force perl to pass a GV by including
11822 C<CALL_CHECKER_REQUIRE_GV> in the C<flags>.
11823
11824 The current setting for a particular CV can be retrieved by
11825 L</cv_get_call_checker>.
11826
11827 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
11828
11829 The original form of L</cv_set_call_checker_flags>, which passes it the
11830 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.
11831
11832 =cut
11833 */
11834
11835 void
11836 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
11837 {
11838     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
11839     cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
11840 }
11841
11842 void
11843 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
11844                                      SV *ckobj, U32 flags)
11845 {
11846     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
11847     if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
11848         if (SvMAGICAL((SV*)cv))
11849             mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
11850     } else {
11851         MAGIC *callmg;
11852         sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
11853         callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
11854         assert(callmg);
11855         if (callmg->mg_flags & MGf_REFCOUNTED) {
11856             SvREFCNT_dec(callmg->mg_obj);
11857             callmg->mg_flags &= ~MGf_REFCOUNTED;
11858         }
11859         callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
11860         callmg->mg_obj = ckobj;
11861         if (ckobj != (SV*)cv) {
11862             SvREFCNT_inc_simple_void_NN(ckobj);
11863             callmg->mg_flags |= MGf_REFCOUNTED;
11864         }
11865         callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
11866                          | (U8)(flags & MGf_REQUIRE_GV) | MGf_COPY;
11867     }
11868 }
11869
11870 static void
11871 S_entersub_alloc_targ(pTHX_ OP * const o)
11872 {
11873     o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
11874     o->op_private |= OPpENTERSUB_HASTARG;
11875 }
11876
11877 OP *
11878 Perl_ck_subr(pTHX_ OP *o)
11879 {
11880     OP *aop, *cvop;
11881     CV *cv;
11882     GV *namegv;
11883     SV **const_class = NULL;
11884
11885     PERL_ARGS_ASSERT_CK_SUBR;
11886
11887     aop = cUNOPx(o)->op_first;
11888     if (!OpHAS_SIBLING(aop))
11889         aop = cUNOPx(aop)->op_first;
11890     aop = OpSIBLING(aop);
11891     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11892     cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
11893     namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
11894
11895     o->op_private &= ~1;
11896     o->op_private |= (PL_hints & HINT_STRICT_REFS);
11897     if (PERLDB_SUB && PL_curstash != PL_debstash)
11898         o->op_private |= OPpENTERSUB_DB;
11899     switch (cvop->op_type) {
11900         case OP_RV2CV:
11901             o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
11902             op_null(cvop);
11903             break;
11904         case OP_METHOD:
11905         case OP_METHOD_NAMED:
11906         case OP_METHOD_SUPER:
11907         case OP_METHOD_REDIR:
11908         case OP_METHOD_REDIR_SUPER:
11909             if (aop->op_type == OP_CONST) {
11910                 aop->op_private &= ~OPpCONST_STRICT;
11911                 const_class = &cSVOPx(aop)->op_sv;
11912             }
11913             else if (aop->op_type == OP_LIST) {
11914                 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
11915                 if (sib && sib->op_type == OP_CONST) {
11916                     sib->op_private &= ~OPpCONST_STRICT;
11917                     const_class = &cSVOPx(sib)->op_sv;
11918                 }
11919             }
11920             /* make class name a shared cow string to speedup method calls */
11921             /* constant string might be replaced with object, f.e. bigint */
11922             if (const_class && SvPOK(*const_class)) {
11923                 STRLEN len;
11924                 const char* str = SvPV(*const_class, len);
11925                 if (len) {
11926                     SV* const shared = newSVpvn_share(
11927                         str, SvUTF8(*const_class)
11928                                     ? -(SSize_t)len : (SSize_t)len,
11929                         0
11930                     );
11931                     if (SvREADONLY(*const_class))
11932                         SvREADONLY_on(shared);
11933                     SvREFCNT_dec(*const_class);
11934                     *const_class = shared;
11935                 }
11936             }
11937             break;
11938     }
11939
11940     if (!cv) {
11941         S_entersub_alloc_targ(aTHX_ o);
11942         return ck_entersub_args_list(o);
11943     } else {
11944         Perl_call_checker ckfun;
11945         SV *ckobj;
11946         U8 flags;
11947         S_cv_get_call_checker(cv, &ckfun, &ckobj, &flags);
11948         if (CvISXSUB(cv) || !CvROOT(cv))
11949             S_entersub_alloc_targ(aTHX_ o);
11950         if (!namegv) {
11951             /* The original call checker API guarantees that a GV will be
11952                be provided with the right name.  So, if the old API was
11953                used (or the REQUIRE_GV flag was passed), we have to reify
11954                the CV’s GV, unless this is an anonymous sub.  This is not
11955                ideal for lexical subs, as its stringification will include
11956                the package.  But it is the best we can do.  */
11957             if (flags & MGf_REQUIRE_GV) {
11958                 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
11959                     namegv = CvGV(cv);
11960             }
11961             else namegv = MUTABLE_GV(cv);
11962             /* After a syntax error in a lexical sub, the cv that
11963                rv2cv_op_cv returns may be a nameless stub. */
11964             if (!namegv) return ck_entersub_args_list(o);
11965
11966         }
11967         return ckfun(aTHX_ o, namegv, ckobj);
11968     }
11969 }
11970
11971 OP *
11972 Perl_ck_svconst(pTHX_ OP *o)
11973 {
11974     SV * const sv = cSVOPo->op_sv;
11975     PERL_ARGS_ASSERT_CK_SVCONST;
11976     PERL_UNUSED_CONTEXT;
11977 #ifdef PERL_COPY_ON_WRITE
11978     /* Since the read-only flag may be used to protect a string buffer, we
11979        cannot do copy-on-write with existing read-only scalars that are not
11980        already copy-on-write scalars.  To allow $_ = "hello" to do COW with
11981        that constant, mark the constant as COWable here, if it is not
11982        already read-only. */
11983     if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
11984         SvIsCOW_on(sv);
11985         CowREFCNT(sv) = 0;
11986 # ifdef PERL_DEBUG_READONLY_COW
11987         sv_buf_to_ro(sv);
11988 # endif
11989     }
11990 #endif
11991     SvREADONLY_on(sv);
11992     return o;
11993 }
11994
11995 OP *
11996 Perl_ck_trunc(pTHX_ OP *o)
11997 {
11998     PERL_ARGS_ASSERT_CK_TRUNC;
11999
12000     if (o->op_flags & OPf_KIDS) {
12001         SVOP *kid = (SVOP*)cUNOPo->op_first;
12002
12003         if (kid->op_type == OP_NULL)
12004             kid = (SVOP*)OpSIBLING(kid);
12005         if (kid && kid->op_type == OP_CONST &&
12006             (kid->op_private & OPpCONST_BARE) &&
12007             !kid->op_folded)
12008         {
12009             o->op_flags |= OPf_SPECIAL;
12010             kid->op_private &= ~OPpCONST_STRICT;
12011         }
12012     }
12013     return ck_fun(o);
12014 }
12015
12016 OP *
12017 Perl_ck_substr(pTHX_ OP *o)
12018 {
12019     PERL_ARGS_ASSERT_CK_SUBSTR;
12020
12021     o = ck_fun(o);
12022     if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
12023         OP *kid = cLISTOPo->op_first;
12024
12025         if (kid->op_type == OP_NULL)
12026             kid = OpSIBLING(kid);
12027         if (kid)
12028             kid->op_flags |= OPf_MOD;
12029
12030     }
12031     return o;
12032 }
12033
12034 OP *
12035 Perl_ck_tell(pTHX_ OP *o)
12036 {
12037     PERL_ARGS_ASSERT_CK_TELL;
12038     o = ck_fun(o);
12039     if (o->op_flags & OPf_KIDS) {
12040      OP *kid = cLISTOPo->op_first;
12041      if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
12042      if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
12043     }
12044     return o;
12045 }
12046
12047 OP *
12048 Perl_ck_each(pTHX_ OP *o)
12049 {
12050     dVAR;
12051     OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
12052     const unsigned orig_type  = o->op_type;
12053
12054     PERL_ARGS_ASSERT_CK_EACH;
12055
12056     if (kid) {
12057         switch (kid->op_type) {
12058             case OP_PADHV:
12059             case OP_RV2HV:
12060                 break;
12061             case OP_PADAV:
12062             case OP_RV2AV:
12063                 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
12064                             : orig_type == OP_KEYS ? OP_AKEYS
12065                             :                        OP_AVALUES);
12066                 break;
12067             case OP_CONST:
12068                 if (kid->op_private == OPpCONST_BARE
12069                  || !SvROK(cSVOPx_sv(kid))
12070                  || (  SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
12071                     && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV  )
12072                    )
12073                     goto bad;
12074             default:
12075                 qerror(Perl_mess(aTHX_
12076                     "Experimental %s on scalar is now forbidden",
12077                      PL_op_desc[orig_type]));
12078                bad:
12079                 bad_type_pv(1, "hash or array", o, kid);
12080                 return o;
12081         }
12082     }
12083     return ck_fun(o);
12084 }
12085
12086 OP *
12087 Perl_ck_length(pTHX_ OP *o)
12088 {
12089     PERL_ARGS_ASSERT_CK_LENGTH;
12090
12091     o = ck_fun(o);
12092
12093     if (ckWARN(WARN_SYNTAX)) {
12094         const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
12095
12096         if (kid) {
12097             SV *name = NULL;
12098             const bool hash = kid->op_type == OP_PADHV
12099                            || kid->op_type == OP_RV2HV;
12100             switch (kid->op_type) {
12101                 case OP_PADHV:
12102                 case OP_PADAV:
12103                 case OP_RV2HV:
12104                 case OP_RV2AV:
12105                     name = S_op_varname(aTHX_ kid);
12106                     break;
12107                 default:
12108                     return o;
12109             }
12110             if (name)
12111                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12112                     "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
12113                     ")\"?)",
12114                     SVfARG(name), hash ? "keys " : "", SVfARG(name)
12115                 );
12116             else if (hash)
12117      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
12118                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12119                     "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
12120             else
12121      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
12122                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12123                     "length() used on @array (did you mean \"scalar(@array)\"?)");
12124         }
12125     }
12126
12127     return o;
12128 }
12129
12130
12131
12132 /*
12133    ---------------------------------------------------------
12134
12135    Common vars in list assignment
12136
12137    There now follows some enums and static functions for detecting
12138    common variables in list assignments. Here is a little essay I wrote
12139    for myself when trying to get my head around this. DAPM.
12140
12141    ----
12142
12143    First some random observations:
12144
12145    * If a lexical var is an alias of something else, e.g.
12146        for my $x ($lex, $pkg, $a[0]) {...}
12147      then the act of aliasing will increase the reference count of the SV
12148
12149    * If a package var is an alias of something else, it may still have a
12150      reference count of 1, depending on how the alias was created, e.g.
12151      in *a = *b, $a may have a refcount of 1 since the GP is shared
12152      with a single GvSV pointer to the SV. So If it's an alias of another
12153      package var, then RC may be 1; if it's an alias of another scalar, e.g.
12154      a lexical var or an array element, then it will have RC > 1.
12155
12156    * There are many ways to create a package alias; ultimately, XS code
12157      may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
12158      run-time tracing mechanisms are unlikely to be able to catch all cases.
12159
12160    * When the LHS is all my declarations, the same vars can't appear directly
12161      on the RHS, but they can indirectly via closures, aliasing and lvalue
12162      subs. But those techniques all involve an increase in the lexical
12163      scalar's ref count.
12164
12165    * When the LHS is all lexical vars (but not necessarily my declarations),
12166      it is possible for the same lexicals to appear directly on the RHS, and
12167      without an increased ref count, since the stack isn't refcounted.
12168      This case can be detected at compile time by scanning for common lex
12169      vars with PL_generation.
12170
12171    * lvalue subs defeat common var detection, but they do at least
12172      return vars with a temporary ref count increment. Also, you can't
12173      tell at compile time whether a sub call is lvalue.
12174
12175
12176    So...
12177
12178    A: There are a few circumstances where there definitely can't be any
12179      commonality:
12180
12181        LHS empty:  () = (...);
12182        RHS empty:  (....) = ();
12183        RHS contains only constants or other 'can't possibly be shared'
12184            elements (e.g. ops that return PADTMPs):  (...) = (1,2, length)
12185            i.e. they only contain ops not marked as dangerous, whose children
12186            are also not dangerous;
12187        LHS ditto;
12188        LHS contains a single scalar element: e.g. ($x) = (....); because
12189            after $x has been modified, it won't be used again on the RHS;
12190        RHS contains a single element with no aggregate on LHS: e.g.
12191            ($a,$b,$c)  = ($x); again, once $a has been modified, its value
12192            won't be used again.
12193
12194    B: If LHS are all 'my' lexical var declarations (or safe ops, which
12195      we can ignore):
12196
12197        my ($a, $b, @c) = ...;
12198
12199        Due to closure and goto tricks, these vars may already have content.
12200        For the same reason, an element on the RHS may be a lexical or package
12201        alias of one of the vars on the left, or share common elements, for
12202        example:
12203
12204            my ($x,$y) = f(); # $x and $y on both sides
12205            sub f : lvalue { ($x,$y) = (1,2); $y, $x }
12206
12207        and
12208
12209            my $ra = f();
12210            my @a = @$ra;  # elements of @a on both sides
12211            sub f { @a = 1..4; \@a }
12212
12213
12214        First, just consider scalar vars on LHS:
12215
12216            RHS is safe only if (A), or in addition,
12217                * contains only lexical *scalar* vars, where neither side's
12218                  lexicals have been flagged as aliases
12219
12220            If RHS is not safe, then it's always legal to check LHS vars for
12221            RC==1, since the only RHS aliases will always be associated
12222            with an RC bump.
12223
12224            Note that in particular, RHS is not safe if:
12225
12226                * it contains package scalar vars; e.g.:
12227
12228                    f();
12229                    my ($x, $y) = (2, $x_alias);
12230                    sub f { $x = 1; *x_alias = \$x; }
12231
12232                * It contains other general elements, such as flattened or
12233                * spliced or single array or hash elements, e.g.
12234
12235                    f();
12236                    my ($x,$y) = @a; # or $a[0] or @a{@b} etc
12237
12238                    sub f {
12239                        ($x, $y) = (1,2);
12240                        use feature 'refaliasing';
12241                        \($a[0], $a[1]) = \($y,$x);
12242                    }
12243
12244                  It doesn't matter if the array/hash is lexical or package.
12245
12246                * it contains a function call that happens to be an lvalue
12247                  sub which returns one or more of the above, e.g.
12248
12249                    f();
12250                    my ($x,$y) = f();
12251
12252                    sub f : lvalue {
12253                        ($x, $y) = (1,2);
12254                        *x1 = \$x;
12255                        $y, $x1;
12256                    }
12257
12258                    (so a sub call on the RHS should be treated the same
12259                    as having a package var on the RHS).
12260
12261                * any other "dangerous" thing, such an op or built-in that
12262                  returns one of the above, e.g. pp_preinc
12263
12264
12265            If RHS is not safe, what we can do however is at compile time flag
12266            that the LHS are all my declarations, and at run time check whether
12267            all the LHS have RC == 1, and if so skip the full scan.
12268
12269        Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
12270
12271            Here the issue is whether there can be elements of @a on the RHS
12272            which will get prematurely freed when @a is cleared prior to
12273            assignment. This is only a problem if the aliasing mechanism
12274            is one which doesn't increase the refcount - only if RC == 1
12275            will the RHS element be prematurely freed.
12276
12277            Because the array/hash is being INTROed, it or its elements
12278            can't directly appear on the RHS:
12279
12280                my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
12281
12282            but can indirectly, e.g.:
12283
12284                my $r = f();
12285                my (@a) = @$r;
12286                sub f { @a = 1..3; \@a }
12287
12288            So if the RHS isn't safe as defined by (A), we must always
12289            mortalise and bump the ref count of any remaining RHS elements
12290            when assigning to a non-empty LHS aggregate.
12291
12292            Lexical scalars on the RHS aren't safe if they've been involved in
12293            aliasing, e.g.
12294
12295                use feature 'refaliasing';
12296
12297                f();
12298                \(my $lex) = \$pkg;
12299                my @a = ($lex,3); # equivalent to ($a[0],3)
12300
12301                sub f {
12302                    @a = (1,2);
12303                    \$pkg = \$a[0];
12304                }
12305
12306            Similarly with lexical arrays and hashes on the RHS:
12307
12308                f();
12309                my @b;
12310                my @a = (@b);
12311
12312                sub f {
12313                    @a = (1,2);
12314                    \$b[0] = \$a[1];
12315                    \$b[1] = \$a[0];
12316                }
12317
12318
12319
12320    C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
12321        my $a; ($a, my $b) = (....);
12322
12323        The difference between (B) and (C) is that it is now physically
12324        possible for the LHS vars to appear on the RHS too, where they
12325        are not reference counted; but in this case, the compile-time
12326        PL_generation sweep will detect such common vars.
12327
12328        So the rules for (C) differ from (B) in that if common vars are
12329        detected, the runtime "test RC==1" optimisation can no longer be used,
12330        and a full mark and sweep is required
12331
12332    D: As (C), but in addition the LHS may contain package vars.
12333
12334        Since package vars can be aliased without a corresponding refcount
12335        increase, all bets are off. It's only safe if (A). E.g.
12336
12337            my ($x, $y) = (1,2);
12338
12339            for $x_alias ($x) {
12340                ($x_alias, $y) = (3, $x); # whoops
12341            }
12342
12343        Ditto for LHS aggregate package vars.
12344
12345    E: Any other dangerous ops on LHS, e.g.
12346            (f(), $a[0], @$r) = (...);
12347
12348        this is similar to (E) in that all bets are off. In addition, it's
12349        impossible to determine at compile time whether the LHS
12350        contains a scalar or an aggregate, e.g.
12351
12352            sub f : lvalue { @a }
12353            (f()) = 1..3;
12354
12355 * ---------------------------------------------------------
12356 */
12357
12358
12359 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates
12360  * that at least one of the things flagged was seen.
12361  */
12362
12363 enum {
12364     AAS_MY_SCALAR       = 0x001, /* my $scalar */
12365     AAS_MY_AGG          = 0x002, /* aggregate: my @array or my %hash */
12366     AAS_LEX_SCALAR      = 0x004, /* $lexical */
12367     AAS_LEX_AGG         = 0x008, /* @lexical or %lexical aggregate */
12368     AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
12369     AAS_PKG_SCALAR      = 0x020, /* $scalar (where $scalar is pkg var) */
12370     AAS_PKG_AGG         = 0x040, /* package @array or %hash aggregate */
12371     AAS_DANGEROUS       = 0x080, /* an op (other than the above)
12372                                          that's flagged OA_DANGEROUS */
12373     AAS_SAFE_SCALAR     = 0x100, /* produces at least one scalar SV that's
12374                                         not in any of the categories above */
12375     AAS_DEFAV           = 0x200  /* contains just a single '@_' on RHS */
12376 };
12377
12378
12379
12380 /* helper function for S_aassign_scan().
12381  * check a PAD-related op for commonality and/or set its generation number.
12382  * Returns a boolean indicating whether its shared */
12383
12384 static bool
12385 S_aassign_padcheck(pTHX_ OP* o, bool rhs)
12386 {
12387     if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
12388         /* lexical used in aliasing */
12389         return TRUE;
12390
12391     if (rhs)
12392         return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
12393     else
12394         PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
12395
12396     return FALSE;
12397 }
12398
12399
12400 /*
12401   Helper function for OPpASSIGN_COMMON* detection in rpeep().
12402   It scans the left or right hand subtree of the aassign op, and returns a
12403   set of flags indicating what sorts of things it found there.
12404   'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
12405   set PL_generation on lexical vars; if the latter, we see if
12406   PL_generation matches.
12407   'top' indicates whether we're recursing or at the top level.
12408   'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
12409   This fn will increment it by the number seen. It's not intended to
12410   be an accurate count (especially as many ops can push a variable
12411   number of SVs onto the stack); rather it's used as to test whether there
12412   can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
12413 */
12414
12415 static int
12416 S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *scalars_p)
12417 {
12418     int flags = 0;
12419     bool kid_top = FALSE;
12420
12421     /* first, look for a solitary @_ on the RHS */
12422     if (   rhs
12423         && top
12424         && (o->op_flags & OPf_KIDS)
12425         && OP_TYPE_IS_OR_WAS(o, OP_LIST)
12426     ) {
12427         OP *kid = cUNOPo->op_first;
12428         if (   (   kid->op_type == OP_PUSHMARK
12429                 || kid->op_type == OP_PADRANGE) /* ex-pushmark */
12430             && ((kid = OpSIBLING(kid)))
12431             && !OpHAS_SIBLING(kid)
12432             && kid->op_type == OP_RV2AV
12433             && !(kid->op_flags & OPf_REF)
12434             && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
12435             && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
12436             && ((kid = cUNOPx(kid)->op_first))
12437             && kid->op_type == OP_GV
12438             && cGVOPx_gv(kid) == PL_defgv
12439         )
12440             flags |= AAS_DEFAV;
12441     }
12442
12443     switch (o->op_type) {
12444     case OP_GVSV:
12445         (*scalars_p)++;
12446         return AAS_PKG_SCALAR;
12447
12448     case OP_PADAV:
12449     case OP_PADHV:
12450         (*scalars_p) += 2;
12451         if (top && (o->op_flags & OPf_REF))
12452             return (o->op_private & OPpLVAL_INTRO)
12453                 ? AAS_MY_AGG : AAS_LEX_AGG;
12454         return AAS_DANGEROUS;
12455
12456     case OP_PADSV:
12457         {
12458             int comm = S_aassign_padcheck(aTHX_ o, rhs)
12459                         ?  AAS_LEX_SCALAR_COMM : 0;
12460             (*scalars_p)++;
12461             return (o->op_private & OPpLVAL_INTRO)
12462                 ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
12463         }
12464
12465     case OP_RV2AV:
12466     case OP_RV2HV:
12467         (*scalars_p) += 2;
12468         if (cUNOPx(o)->op_first->op_type != OP_GV)
12469             return AAS_DANGEROUS; /* @{expr}, %{expr} */
12470         /* @pkg, %pkg */
12471         if (top && (o->op_flags & OPf_REF))
12472             return AAS_PKG_AGG;
12473         return AAS_DANGEROUS;
12474
12475     case OP_RV2SV:
12476         (*scalars_p)++;
12477         if (cUNOPx(o)->op_first->op_type != OP_GV) {
12478             (*scalars_p) += 2;
12479             return AAS_DANGEROUS; /* ${expr} */
12480         }
12481         return AAS_PKG_SCALAR; /* $pkg */
12482
12483     case OP_SPLIT:
12484         if (cLISTOPo->op_first->op_type == OP_PUSHRE) {
12485             /* "@foo = split... " optimises away the aassign and stores its
12486              * destination array in the OP_PUSHRE that precedes it.
12487              * A flattened array is always dangerous.
12488              */
12489             (*scalars_p) += 2;
12490             return AAS_DANGEROUS;
12491         }
12492         break;
12493
12494     case OP_UNDEF:
12495         /* undef counts as a scalar on the RHS:
12496          *   (undef, $x) = ...;         # only 1 scalar on LHS: always safe
12497          *   ($x, $y)    = (undef, $x); # 2 scalars on RHS: unsafe
12498          */
12499         if (rhs)
12500             (*scalars_p)++;
12501         flags = AAS_SAFE_SCALAR;
12502         break;
12503
12504     case OP_PUSHMARK:
12505     case OP_STUB:
12506         /* these are all no-ops; they don't push a potentially common SV
12507          * onto the stack, so they are neither AAS_DANGEROUS nor
12508          * AAS_SAFE_SCALAR */
12509         return 0;
12510
12511     case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
12512         break;
12513
12514     case OP_NULL:
12515     case OP_LIST:
12516         /* these do nothing but may have children; but their children
12517          * should also be treated as top-level */
12518         kid_top = top;
12519         break;
12520
12521     default:
12522         if (PL_opargs[o->op_type] & OA_DANGEROUS) {
12523             (*scalars_p) += 2;
12524             flags = AAS_DANGEROUS;
12525             break;
12526         }
12527
12528         if (   (PL_opargs[o->op_type] & OA_TARGLEX)
12529             && (o->op_private & OPpTARGET_MY))
12530         {
12531             (*scalars_p)++;
12532             return S_aassign_padcheck(aTHX_ o, rhs)
12533                 ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
12534         }
12535
12536         /* if its an unrecognised, non-dangerous op, assume that it
12537          * it the cause of at least one safe scalar */
12538         (*scalars_p)++;
12539         flags = AAS_SAFE_SCALAR;
12540         break;
12541     }
12542
12543     if (o->op_flags & OPf_KIDS) {
12544         OP *kid;
12545         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
12546             flags |= S_aassign_scan(aTHX_ kid, rhs, kid_top, scalars_p);
12547     }
12548     return flags;
12549 }
12550
12551
12552 /* Check for in place reverse and sort assignments like "@a = reverse @a"
12553    and modify the optree to make them work inplace */
12554
12555 STATIC void
12556 S_inplace_aassign(pTHX_ OP *o) {
12557
12558     OP *modop, *modop_pushmark;
12559     OP *oright;
12560     OP *oleft, *oleft_pushmark;
12561
12562     PERL_ARGS_ASSERT_INPLACE_AASSIGN;
12563
12564     assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
12565
12566     assert(cUNOPo->op_first->op_type == OP_NULL);
12567     modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
12568     assert(modop_pushmark->op_type == OP_PUSHMARK);
12569     modop = OpSIBLING(modop_pushmark);
12570
12571     if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
12572         return;
12573
12574     /* no other operation except sort/reverse */
12575     if (OpHAS_SIBLING(modop))
12576         return;
12577
12578     assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
12579     if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
12580
12581     if (modop->op_flags & OPf_STACKED) {
12582         /* skip sort subroutine/block */
12583         assert(oright->op_type == OP_NULL);
12584         oright = OpSIBLING(oright);
12585     }
12586
12587     assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
12588     oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
12589     assert(oleft_pushmark->op_type == OP_PUSHMARK);
12590     oleft = OpSIBLING(oleft_pushmark);
12591
12592     /* Check the lhs is an array */
12593     if (!oleft ||
12594         (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
12595         || OpHAS_SIBLING(oleft)
12596         || (oleft->op_private & OPpLVAL_INTRO)
12597     )
12598         return;
12599
12600     /* Only one thing on the rhs */
12601     if (OpHAS_SIBLING(oright))
12602         return;
12603
12604     /* check the array is the same on both sides */
12605     if (oleft->op_type == OP_RV2AV) {
12606         if (oright->op_type != OP_RV2AV
12607             || !cUNOPx(oright)->op_first
12608             || cUNOPx(oright)->op_first->op_type != OP_GV
12609             || cUNOPx(oleft )->op_first->op_type != OP_GV
12610             || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
12611                cGVOPx_gv(cUNOPx(oright)->op_first)
12612         )
12613             return;
12614     }
12615     else if (oright->op_type != OP_PADAV
12616         || oright->op_targ != oleft->op_targ
12617     )
12618         return;
12619
12620     /* This actually is an inplace assignment */
12621
12622     modop->op_private |= OPpSORT_INPLACE;
12623
12624     /* transfer MODishness etc from LHS arg to RHS arg */
12625     oright->op_flags = oleft->op_flags;
12626
12627     /* remove the aassign op and the lhs */
12628     op_null(o);
12629     op_null(oleft_pushmark);
12630     if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
12631         op_null(cUNOPx(oleft)->op_first);
12632     op_null(oleft);
12633 }
12634
12635
12636
12637 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
12638  * that potentially represent a series of one or more aggregate derefs
12639  * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
12640  * the whole chain to a single OP_MULTIDEREF op (maybe with a few
12641  * additional ops left in too).
12642  *
12643  * The caller will have already verified that the first few ops in the
12644  * chain following 'start' indicate a multideref candidate, and will have
12645  * set 'orig_o' to the point further on in the chain where the first index
12646  * expression (if any) begins.  'orig_action' specifies what type of
12647  * beginning has already been determined by the ops between start..orig_o
12648  * (e.g.  $lex_ary[], $pkg_ary->{}, expr->[], etc).
12649  *
12650  * 'hints' contains any hints flags that need adding (currently just
12651  * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
12652  */
12653
12654 STATIC void
12655 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
12656 {
12657     dVAR;
12658     int pass;
12659     UNOP_AUX_item *arg_buf = NULL;
12660     bool reset_start_targ  = FALSE; /* start->op_targ needs zeroing */
12661     int index_skip         = -1;    /* don't output index arg on this action */
12662
12663     /* similar to regex compiling, do two passes; the first pass
12664      * determines whether the op chain is convertible and calculates the
12665      * buffer size; the second pass populates the buffer and makes any
12666      * changes necessary to ops (such as moving consts to the pad on
12667      * threaded builds).
12668      *
12669      * NB: for things like Coverity, note that both passes take the same
12670      * path through the logic tree (except for 'if (pass)' bits), since
12671      * both passes are following the same op_next chain; and in
12672      * particular, if it would return early on the second pass, it would
12673      * already have returned early on the first pass.
12674      */
12675     for (pass = 0; pass < 2; pass++) {
12676         OP *o                = orig_o;
12677         UV action            = orig_action;
12678         OP *first_elem_op    = NULL;  /* first seen aelem/helem */
12679         OP *top_op           = NULL;  /* highest [ah]elem/exists/del/rv2[ah]v */
12680         int action_count     = 0;     /* number of actions seen so far */
12681         int action_ix        = 0;     /* action_count % (actions per IV) */
12682         bool next_is_hash    = FALSE; /* is the next lookup to be a hash? */
12683         bool is_last         = FALSE; /* no more derefs to follow */
12684         bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
12685         UNOP_AUX_item *arg     = arg_buf;
12686         UNOP_AUX_item *action_ptr = arg_buf;
12687
12688         if (pass)
12689             action_ptr->uv = 0;
12690         arg++;
12691
12692         switch (action) {
12693         case MDEREF_HV_gvsv_vivify_rv2hv_helem:
12694         case MDEREF_HV_gvhv_helem:
12695             next_is_hash = TRUE;
12696             /* FALLTHROUGH */
12697         case MDEREF_AV_gvsv_vivify_rv2av_aelem:
12698         case MDEREF_AV_gvav_aelem:
12699             if (pass) {
12700 #ifdef USE_ITHREADS
12701                 arg->pad_offset = cPADOPx(start)->op_padix;
12702                 /* stop it being swiped when nulled */
12703                 cPADOPx(start)->op_padix = 0;
12704 #else
12705                 arg->sv = cSVOPx(start)->op_sv;
12706                 cSVOPx(start)->op_sv = NULL;
12707 #endif
12708             }
12709             arg++;
12710             break;
12711
12712         case MDEREF_HV_padhv_helem:
12713         case MDEREF_HV_padsv_vivify_rv2hv_helem:
12714             next_is_hash = TRUE;
12715             /* FALLTHROUGH */
12716         case MDEREF_AV_padav_aelem:
12717         case MDEREF_AV_padsv_vivify_rv2av_aelem:
12718             if (pass) {
12719                 arg->pad_offset = start->op_targ;
12720                 /* we skip setting op_targ = 0 for now, since the intact
12721                  * OP_PADXV is needed by S_check_hash_fields_and_hekify */
12722                 reset_start_targ = TRUE;
12723             }
12724             arg++;
12725             break;
12726
12727         case MDEREF_HV_pop_rv2hv_helem:
12728             next_is_hash = TRUE;
12729             /* FALLTHROUGH */
12730         case MDEREF_AV_pop_rv2av_aelem:
12731             break;
12732
12733         default:
12734             NOT_REACHED; /* NOTREACHED */
12735             return;
12736         }
12737
12738         while (!is_last) {
12739             /* look for another (rv2av/hv; get index;
12740              * aelem/helem/exists/delele) sequence */
12741
12742             OP *kid;
12743             bool is_deref;
12744             bool ok;
12745             UV index_type = MDEREF_INDEX_none;
12746
12747             if (action_count) {
12748                 /* if this is not the first lookup, consume the rv2av/hv  */
12749
12750                 /* for N levels of aggregate lookup, we normally expect
12751                  * that the first N-1 [ah]elem ops will be flagged as
12752                  * /DEREF (so they autovivifiy if necessary), and the last
12753                  * lookup op not to be.
12754                  * For other things (like @{$h{k1}{k2}}) extra scope or
12755                  * leave ops can appear, so abandon the effort in that
12756                  * case */
12757                 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
12758                     return;
12759
12760                 /* rv2av or rv2hv sKR/1 */
12761
12762                 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12763                                             |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12764                 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
12765                     return;
12766
12767                 /* at this point, we wouldn't expect any of these
12768                  * possible private flags:
12769                  * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
12770                  * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
12771                  */
12772                 ASSUME(!(o->op_private &
12773                     ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
12774
12775                 hints = (o->op_private & OPpHINT_STRICT_REFS);
12776
12777                 /* make sure the type of the previous /DEREF matches the
12778                  * type of the next lookup */
12779                 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
12780                 top_op = o;
12781
12782                 action = next_is_hash
12783                             ? MDEREF_HV_vivify_rv2hv_helem
12784                             : MDEREF_AV_vivify_rv2av_aelem;
12785                 o = o->op_next;
12786             }
12787
12788             /* if this is the second pass, and we're at the depth where
12789              * previously we encountered a non-simple index expression,
12790              * stop processing the index at this point */
12791             if (action_count != index_skip) {
12792
12793                 /* look for one or more simple ops that return an array
12794                  * index or hash key */
12795
12796                 switch (o->op_type) {
12797                 case OP_PADSV:
12798                     /* it may be a lexical var index */
12799                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
12800                                             |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12801                     ASSUME(!(o->op_private &
12802                             ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
12803
12804                     if (   OP_GIMME(o,0) == G_SCALAR
12805                         && !(o->op_flags & (OPf_REF|OPf_MOD))
12806                         && o->op_private == 0)
12807                     {
12808                         if (pass)
12809                             arg->pad_offset = o->op_targ;
12810                         arg++;
12811                         index_type = MDEREF_INDEX_padsv;
12812                         o = o->op_next;
12813                     }
12814                     break;
12815
12816                 case OP_CONST:
12817                     if (next_is_hash) {
12818                         /* it's a constant hash index */
12819                         if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
12820                             /* "use constant foo => FOO; $h{+foo}" for
12821                              * some weird FOO, can leave you with constants
12822                              * that aren't simple strings. It's not worth
12823                              * the extra hassle for those edge cases */
12824                             break;
12825
12826                         if (pass) {
12827                             UNOP *rop = NULL;
12828                             OP * helem_op = o->op_next;
12829
12830                             ASSUME(   helem_op->op_type == OP_HELEM
12831                                    || helem_op->op_type == OP_NULL);
12832                             if (helem_op->op_type == OP_HELEM) {
12833                                 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
12834                                 if (   helem_op->op_private & OPpLVAL_INTRO
12835                                     || rop->op_type != OP_RV2HV
12836                                 )
12837                                     rop = NULL;
12838                             }
12839                             S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo);
12840
12841 #ifdef USE_ITHREADS
12842                             /* Relocate sv to the pad for thread safety */
12843                             op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
12844                             arg->pad_offset = o->op_targ;
12845                             o->op_targ = 0;
12846 #else
12847                             arg->sv = cSVOPx_sv(o);
12848 #endif
12849                         }
12850                     }
12851                     else {
12852                         /* it's a constant array index */
12853                         IV iv;
12854                         SV *ix_sv = cSVOPo->op_sv;
12855                         if (!SvIOK(ix_sv))
12856                             break;
12857                         iv = SvIV(ix_sv);
12858
12859                         if (   action_count == 0
12860                             && iv >= -128
12861                             && iv <= 127
12862                             && (   action == MDEREF_AV_padav_aelem
12863                                 || action == MDEREF_AV_gvav_aelem)
12864                         )
12865                             maybe_aelemfast = TRUE;
12866
12867                         if (pass) {
12868                             arg->iv = iv;
12869                             SvREFCNT_dec_NN(cSVOPo->op_sv);
12870                         }
12871                     }
12872                     if (pass)
12873                         /* we've taken ownership of the SV */
12874                         cSVOPo->op_sv = NULL;
12875                     arg++;
12876                     index_type = MDEREF_INDEX_const;
12877                     o = o->op_next;
12878                     break;
12879
12880                 case OP_GV:
12881                     /* it may be a package var index */
12882
12883                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_SPECIAL)));
12884                     ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
12885                     if (  (o->op_flags &~ OPf_SPECIAL) != OPf_WANT_SCALAR
12886                         || o->op_private != 0
12887                     )
12888                         break;
12889
12890                     kid = o->op_next;
12891                     if (kid->op_type != OP_RV2SV)
12892                         break;
12893
12894                     ASSUME(!(kid->op_flags &
12895                             ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
12896                              |OPf_SPECIAL|OPf_PARENS)));
12897                     ASSUME(!(kid->op_private &
12898                                     ~(OPpARG1_MASK
12899                                      |OPpHINT_STRICT_REFS|OPpOUR_INTRO
12900                                      |OPpDEREF|OPpLVAL_INTRO)));
12901                     if(   (kid->op_flags &~ OPf_PARENS)
12902                             != (OPf_WANT_SCALAR|OPf_KIDS)
12903                        || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
12904                     )
12905                         break;
12906
12907                     if (pass) {
12908 #ifdef USE_ITHREADS
12909                         arg->pad_offset = cPADOPx(o)->op_padix;
12910                         /* stop it being swiped when nulled */
12911                         cPADOPx(o)->op_padix = 0;
12912 #else
12913                         arg->sv = cSVOPx(o)->op_sv;
12914                         cSVOPo->op_sv = NULL;
12915 #endif
12916                     }
12917                     arg++;
12918                     index_type = MDEREF_INDEX_gvsv;
12919                     o = kid->op_next;
12920                     break;
12921
12922                 } /* switch */
12923             } /* action_count != index_skip */
12924
12925             action |= index_type;
12926
12927
12928             /* at this point we have either:
12929              *   * detected what looks like a simple index expression,
12930              *     and expect the next op to be an [ah]elem, or
12931              *     an nulled  [ah]elem followed by a delete or exists;
12932              *  * found a more complex expression, so something other
12933              *    than the above follows.
12934              */
12935
12936             /* possibly an optimised away [ah]elem (where op_next is
12937              * exists or delete) */
12938             if (o->op_type == OP_NULL)
12939                 o = o->op_next;
12940
12941             /* at this point we're looking for an OP_AELEM, OP_HELEM,
12942              * OP_EXISTS or OP_DELETE */
12943
12944             /* if something like arybase (a.k.a $[ ) is in scope,
12945              * abandon optimisation attempt */
12946             if (  (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
12947                && PL_check[o->op_type] != Perl_ck_null)
12948                 return;
12949
12950             if (   o->op_type != OP_AELEM
12951                 || (o->op_private &
12952                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
12953                 )
12954                 maybe_aelemfast = FALSE;
12955
12956             /* look for aelem/helem/exists/delete. If it's not the last elem
12957              * lookup, it *must* have OPpDEREF_AV/HV, but not many other
12958              * flags; if it's the last, then it mustn't have
12959              * OPpDEREF_AV/HV, but may have lots of other flags, like
12960              * OPpLVAL_INTRO etc
12961              */
12962
12963             if (   index_type == MDEREF_INDEX_none
12964                 || (   o->op_type != OP_AELEM  && o->op_type != OP_HELEM
12965                     && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
12966             )
12967                 ok = FALSE;
12968             else {
12969                 /* we have aelem/helem/exists/delete with valid simple index */
12970
12971                 is_deref =    (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
12972                            && (   (o->op_private & OPpDEREF) == OPpDEREF_AV
12973                                || (o->op_private & OPpDEREF) == OPpDEREF_HV);
12974
12975                 if (is_deref) {
12976                     ASSUME(!(o->op_flags &
12977                                  ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
12978                     ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
12979
12980                     ok =    (o->op_flags &~ OPf_PARENS)
12981                                == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
12982                          && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
12983                 }
12984                 else if (o->op_type == OP_EXISTS) {
12985                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12986                                 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12987                     ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
12988                     ok =  !(o->op_private & ~OPpARG1_MASK);
12989                 }
12990                 else if (o->op_type == OP_DELETE) {
12991                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12992                                 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12993                     ASSUME(!(o->op_private &
12994                                     ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
12995                     /* don't handle slices or 'local delete'; the latter
12996                      * is fairly rare, and has a complex runtime */
12997                     ok =  !(o->op_private & ~OPpARG1_MASK);
12998                     if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
12999                         /* skip handling run-tome error */
13000                         ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
13001                 }
13002                 else {
13003                     ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
13004                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
13005                                             |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
13006                     ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
13007                                     |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
13008                     ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
13009                 }
13010             }
13011
13012             if (ok) {
13013                 if (!first_elem_op)
13014                     first_elem_op = o;
13015                 top_op = o;
13016                 if (is_deref) {
13017                     next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
13018                     o = o->op_next;
13019                 }
13020                 else {
13021                     is_last = TRUE;
13022                     action |= MDEREF_FLAG_last;
13023                 }
13024             }
13025             else {
13026                 /* at this point we have something that started
13027                  * promisingly enough (with rv2av or whatever), but failed
13028                  * to find a simple index followed by an
13029                  * aelem/helem/exists/delete. If this is the first action,
13030                  * give up; but if we've already seen at least one
13031                  * aelem/helem, then keep them and add a new action with
13032                  * MDEREF_INDEX_none, which causes it to do the vivify
13033                  * from the end of the previous lookup, and do the deref,
13034                  * but stop at that point. So $a[0][expr] will do one
13035                  * av_fetch, vivify and deref, then continue executing at
13036                  * expr */
13037                 if (!action_count)
13038                     return;
13039                 is_last = TRUE;
13040                 index_skip = action_count;
13041                 action |= MDEREF_FLAG_last;
13042             }
13043
13044             if (pass)
13045                 action_ptr->uv |= (action << (action_ix * MDEREF_SHIFT));
13046             action_ix++;
13047             action_count++;
13048             /* if there's no space for the next action, create a new slot
13049              * for it *before* we start adding args for that action */
13050             if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
13051                 action_ptr = arg;
13052                 if (pass)
13053                     arg->uv = 0;
13054                 arg++;
13055                 action_ix = 0;
13056             }
13057         } /* while !is_last */
13058
13059         /* success! */
13060
13061         if (pass) {
13062             OP *mderef;
13063             OP *p, *q;
13064
13065             mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
13066             if (index_skip == -1) {
13067                 mderef->op_flags = o->op_flags
13068                         & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
13069                 if (o->op_type == OP_EXISTS)
13070                     mderef->op_private = OPpMULTIDEREF_EXISTS;
13071                 else if (o->op_type == OP_DELETE)
13072                     mderef->op_private = OPpMULTIDEREF_DELETE;
13073                 else
13074                     mderef->op_private = o->op_private
13075                         & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
13076             }
13077             /* accumulate strictness from every level (although I don't think
13078              * they can actually vary) */
13079             mderef->op_private |= hints;
13080
13081             /* integrate the new multideref op into the optree and the
13082              * op_next chain.
13083              *
13084              * In general an op like aelem or helem has two child
13085              * sub-trees: the aggregate expression (a_expr) and the
13086              * index expression (i_expr):
13087              *
13088              *     aelem
13089              *       |
13090              *     a_expr - i_expr
13091              *
13092              * The a_expr returns an AV or HV, while the i-expr returns an
13093              * index. In general a multideref replaces most or all of a
13094              * multi-level tree, e.g.
13095              *
13096              *     exists
13097              *       |
13098              *     ex-aelem
13099              *       |
13100              *     rv2av  - i_expr1
13101              *       |
13102              *     helem
13103              *       |
13104              *     rv2hv  - i_expr2
13105              *       |
13106              *     aelem
13107              *       |
13108              *     a_expr - i_expr3
13109              *
13110              * With multideref, all the i_exprs will be simple vars or
13111              * constants, except that i_expr1 may be arbitrary in the case
13112              * of MDEREF_INDEX_none.
13113              *
13114              * The bottom-most a_expr will be either:
13115              *   1) a simple var (so padXv or gv+rv2Xv);
13116              *   2) a simple scalar var dereferenced (e.g. $r->[0]):
13117              *      so a simple var with an extra rv2Xv;
13118              *   3) or an arbitrary expression.
13119              *
13120              * 'start', the first op in the execution chain, will point to
13121              *   1),2): the padXv or gv op;
13122              *   3):    the rv2Xv which forms the last op in the a_expr
13123              *          execution chain, and the top-most op in the a_expr
13124              *          subtree.
13125              *
13126              * For all cases, the 'start' node is no longer required,
13127              * but we can't free it since one or more external nodes
13128              * may point to it. E.g. consider
13129              *     $h{foo} = $a ? $b : $c
13130              * Here, both the op_next and op_other branches of the
13131              * cond_expr point to the gv[*h] of the hash expression, so
13132              * we can't free the 'start' op.
13133              *
13134              * For expr->[...], we need to save the subtree containing the
13135              * expression; for the other cases, we just need to save the
13136              * start node.
13137              * So in all cases, we null the start op and keep it around by
13138              * making it the child of the multideref op; for the expr->
13139              * case, the expr will be a subtree of the start node.
13140              *
13141              * So in the simple 1,2 case the  optree above changes to
13142              *
13143              *     ex-exists
13144              *       |
13145              *     multideref
13146              *       |
13147              *     ex-gv (or ex-padxv)
13148              *
13149              *  with the op_next chain being
13150              *
13151              *  -> ex-gv -> multideref -> op-following-ex-exists ->
13152              *
13153              *  In the 3 case, we have
13154              *
13155              *     ex-exists
13156              *       |
13157              *     multideref
13158              *       |
13159              *     ex-rv2xv
13160              *       |
13161              *    rest-of-a_expr
13162              *      subtree
13163              *
13164              *  and
13165              *
13166              *  -> rest-of-a_expr subtree ->
13167              *    ex-rv2xv -> multideref -> op-following-ex-exists ->
13168              *
13169              *
13170              * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
13171              * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
13172              * multideref attached as the child, e.g.
13173              *
13174              *     exists
13175              *       |
13176              *     ex-aelem
13177              *       |
13178              *     ex-rv2av  - i_expr1
13179              *       |
13180              *     multideref
13181              *       |
13182              *     ex-whatever
13183              *
13184              */
13185
13186             /* if we free this op, don't free the pad entry */
13187             if (reset_start_targ)
13188                 start->op_targ = 0;
13189
13190
13191             /* Cut the bit we need to save out of the tree and attach to
13192              * the multideref op, then free the rest of the tree */
13193
13194             /* find parent of node to be detached (for use by splice) */
13195             p = first_elem_op;
13196             if (   orig_action == MDEREF_AV_pop_rv2av_aelem
13197                 || orig_action == MDEREF_HV_pop_rv2hv_helem)
13198             {
13199                 /* there is an arbitrary expression preceding us, e.g.
13200                  * expr->[..]? so we need to save the 'expr' subtree */
13201                 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
13202                     p = cUNOPx(p)->op_first;
13203                 ASSUME(   start->op_type == OP_RV2AV
13204                        || start->op_type == OP_RV2HV);
13205             }
13206             else {
13207                 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
13208                  * above for exists/delete. */
13209                 while (   (p->op_flags & OPf_KIDS)
13210                        && cUNOPx(p)->op_first != start
13211                 )
13212                     p = cUNOPx(p)->op_first;
13213             }
13214             ASSUME(cUNOPx(p)->op_first == start);
13215
13216             /* detach from main tree, and re-attach under the multideref */
13217             op_sibling_splice(mderef, NULL, 0,
13218                     op_sibling_splice(p, NULL, 1, NULL));
13219             op_null(start);
13220
13221             start->op_next = mderef;
13222
13223             mderef->op_next = index_skip == -1 ? o->op_next : o;
13224
13225             /* excise and free the original tree, and replace with
13226              * the multideref op */
13227             p = op_sibling_splice(top_op, NULL, -1, mderef);
13228             while (p) {
13229                 q = OpSIBLING(p);
13230                 op_free(p);
13231                 p = q;
13232             }
13233             op_null(top_op);
13234         }
13235         else {
13236             Size_t size = arg - arg_buf;
13237
13238             if (maybe_aelemfast && action_count == 1)
13239                 return;
13240
13241             arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
13242                                 sizeof(UNOP_AUX_item) * (size + 1));
13243             /* for dumping etc: store the length in a hidden first slot;
13244              * we set the op_aux pointer to the second slot */
13245             arg_buf->uv = size;
13246             arg_buf++;
13247         }
13248     } /* for (pass = ...) */
13249 }
13250
13251
13252
13253 /* mechanism for deferring recursion in rpeep() */
13254
13255 #define MAX_DEFERRED 4
13256
13257 #define DEFER(o) \
13258   STMT_START { \
13259     if (defer_ix == (MAX_DEFERRED-1)) { \
13260         OP **defer = defer_queue[defer_base]; \
13261         CALL_RPEEP(*defer); \
13262         S_prune_chain_head(defer); \
13263         defer_base = (defer_base + 1) % MAX_DEFERRED; \
13264         defer_ix--; \
13265     } \
13266     defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
13267   } STMT_END
13268
13269 #define IS_AND_OP(o)   (o->op_type == OP_AND)
13270 #define IS_OR_OP(o)    (o->op_type == OP_OR)
13271
13272
13273 /* A peephole optimizer.  We visit the ops in the order they're to execute.
13274  * See the comments at the top of this file for more details about when
13275  * peep() is called */
13276
13277 void
13278 Perl_rpeep(pTHX_ OP *o)
13279 {
13280     dVAR;
13281     OP* oldop = NULL;
13282     OP* oldoldop = NULL;
13283     OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
13284     int defer_base = 0;
13285     int defer_ix = -1;
13286     OP *fop;
13287     OP *sop;
13288
13289     if (!o || o->op_opt)
13290         return;
13291     ENTER;
13292     SAVEOP();
13293     SAVEVPTR(PL_curcop);
13294     for (;; o = o->op_next) {
13295         if (o && o->op_opt)
13296             o = NULL;
13297         if (!o) {
13298             while (defer_ix >= 0) {
13299                 OP **defer =
13300                         defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
13301                 CALL_RPEEP(*defer);
13302                 S_prune_chain_head(defer);
13303             }
13304             break;
13305         }
13306
13307       redo:
13308
13309         /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */
13310         assert(!oldoldop || oldoldop->op_next == oldop);
13311         assert(!oldop    || oldop->op_next    == o);
13312
13313         /* By default, this op has now been optimised. A couple of cases below
13314            clear this again.  */
13315         o->op_opt = 1;
13316         PL_op = o;
13317
13318         /* look for a series of 1 or more aggregate derefs, e.g.
13319          *   $a[1]{foo}[$i]{$k}
13320          * and replace with a single OP_MULTIDEREF op.
13321          * Each index must be either a const, or a simple variable,
13322          *
13323          * First, look for likely combinations of starting ops,
13324          * corresponding to (global and lexical variants of)
13325          *     $a[...]   $h{...}
13326          *     $r->[...] $r->{...}
13327          *     (preceding expression)->[...]
13328          *     (preceding expression)->{...}
13329          * and if so, call maybe_multideref() to do a full inspection
13330          * of the op chain and if appropriate, replace with an
13331          * OP_MULTIDEREF
13332          */
13333         {
13334             UV action;
13335             OP *o2 = o;
13336             U8 hints = 0;
13337
13338             switch (o2->op_type) {
13339             case OP_GV:
13340                 /* $pkg[..]   :   gv[*pkg]
13341                  * $pkg->[...]:   gv[*pkg]; rv2sv sKM/DREFAV */
13342
13343                 /* Fail if there are new op flag combinations that we're
13344                  * not aware of, rather than:
13345                  *  * silently failing to optimise, or
13346                  *  * silently optimising the flag away.
13347                  * If this ASSUME starts failing, examine what new flag
13348                  * has been added to the op, and decide whether the
13349                  * optimisation should still occur with that flag, then
13350                  * update the code accordingly. This applies to all the
13351                  * other ASSUMEs in the block of code too.
13352                  */
13353                 ASSUME(!(o2->op_flags &
13354                             ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
13355                 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
13356
13357                 o2 = o2->op_next;
13358
13359                 if (o2->op_type == OP_RV2AV) {
13360                     action = MDEREF_AV_gvav_aelem;
13361                     goto do_deref;
13362                 }
13363
13364                 if (o2->op_type == OP_RV2HV) {
13365                     action = MDEREF_HV_gvhv_helem;
13366                     goto do_deref;
13367                 }
13368
13369                 if (o2->op_type != OP_RV2SV)
13370                     break;
13371
13372                 /* at this point we've seen gv,rv2sv, so the only valid
13373                  * construct left is $pkg->[] or $pkg->{} */
13374
13375                 ASSUME(!(o2->op_flags & OPf_STACKED));
13376                 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13377                             != (OPf_WANT_SCALAR|OPf_MOD))
13378                     break;
13379
13380                 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
13381                                     |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
13382                 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
13383                     break;
13384                 if (   (o2->op_private & OPpDEREF) != OPpDEREF_AV
13385                     && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
13386                     break;
13387
13388                 o2 = o2->op_next;
13389                 if (o2->op_type == OP_RV2AV) {
13390                     action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
13391                     goto do_deref;
13392                 }
13393                 if (o2->op_type == OP_RV2HV) {
13394                     action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
13395                     goto do_deref;
13396                 }
13397                 break;
13398
13399             case OP_PADSV:
13400                 /* $lex->[...]: padsv[$lex] sM/DREFAV */
13401
13402                 ASSUME(!(o2->op_flags &
13403                     ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
13404                 if ((o2->op_flags &
13405                         (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13406                      != (OPf_WANT_SCALAR|OPf_MOD))
13407                     break;
13408
13409                 ASSUME(!(o2->op_private &
13410                                 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
13411                 /* skip if state or intro, or not a deref */
13412                 if (      o2->op_private != OPpDEREF_AV
13413                        && o2->op_private != OPpDEREF_HV)
13414                     break;
13415
13416                 o2 = o2->op_next;
13417                 if (o2->op_type == OP_RV2AV) {
13418                     action = MDEREF_AV_padsv_vivify_rv2av_aelem;
13419                     goto do_deref;
13420                 }
13421                 if (o2->op_type == OP_RV2HV) {
13422                     action = MDEREF_HV_padsv_vivify_rv2hv_helem;
13423                     goto do_deref;
13424                 }
13425                 break;
13426
13427             case OP_PADAV:
13428             case OP_PADHV:
13429                 /*    $lex[..]:  padav[@lex:1,2] sR *
13430                  * or $lex{..}:  padhv[%lex:1,2] sR */
13431                 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
13432                                             OPf_REF|OPf_SPECIAL)));
13433                 if ((o2->op_flags &
13434                         (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13435                      != (OPf_WANT_SCALAR|OPf_REF))
13436                     break;
13437                 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
13438                     break;
13439                 /* OPf_PARENS isn't currently used in this case;
13440                  * if that changes, let us know! */
13441                 ASSUME(!(o2->op_flags & OPf_PARENS));
13442
13443                 /* at this point, we wouldn't expect any of the remaining
13444                  * possible private flags:
13445                  * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
13446                  * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
13447                  *
13448                  * OPpSLICEWARNING shouldn't affect runtime
13449                  */
13450                 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
13451
13452                 action = o2->op_type == OP_PADAV
13453                             ? MDEREF_AV_padav_aelem
13454                             : MDEREF_HV_padhv_helem;
13455                 o2 = o2->op_next;
13456                 S_maybe_multideref(aTHX_ o, o2, action, 0);
13457                 break;
13458
13459
13460             case OP_RV2AV:
13461             case OP_RV2HV:
13462                 action = o2->op_type == OP_RV2AV
13463                             ? MDEREF_AV_pop_rv2av_aelem
13464                             : MDEREF_HV_pop_rv2hv_helem;
13465                 /* FALLTHROUGH */
13466             do_deref:
13467                 /* (expr)->[...]:  rv2av sKR/1;
13468                  * (expr)->{...}:  rv2hv sKR/1; */
13469
13470                 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
13471
13472                 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
13473                                 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
13474                 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
13475                     break;
13476
13477                 /* at this point, we wouldn't expect any of these
13478                  * possible private flags:
13479                  * OPpMAYBE_LVSUB, OPpLVAL_INTRO
13480                  * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
13481                  */
13482                 ASSUME(!(o2->op_private &
13483                     ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
13484                      |OPpOUR_INTRO)));
13485                 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
13486
13487                 o2 = o2->op_next;
13488
13489                 S_maybe_multideref(aTHX_ o, o2, action, hints);
13490                 break;
13491
13492             default:
13493                 break;
13494             }
13495         }
13496
13497
13498         switch (o->op_type) {
13499         case OP_DBSTATE:
13500             PL_curcop = ((COP*)o);              /* for warnings */
13501             break;
13502         case OP_NEXTSTATE:
13503             PL_curcop = ((COP*)o);              /* for warnings */
13504
13505             /* Optimise a "return ..." at the end of a sub to just be "...".
13506              * This saves 2 ops. Before:
13507              * 1  <;> nextstate(main 1 -e:1) v ->2
13508              * 4  <@> return K ->5
13509              * 2    <0> pushmark s ->3
13510              * -    <1> ex-rv2sv sK/1 ->4
13511              * 3      <#> gvsv[*cat] s ->4
13512              *
13513              * After:
13514              * -  <@> return K ->-
13515              * -    <0> pushmark s ->2
13516              * -    <1> ex-rv2sv sK/1 ->-
13517              * 2      <$> gvsv(*cat) s ->3
13518              */
13519             {
13520                 OP *next = o->op_next;
13521                 OP *sibling = OpSIBLING(o);
13522                 if (   OP_TYPE_IS(next, OP_PUSHMARK)
13523                     && OP_TYPE_IS(sibling, OP_RETURN)
13524                     && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
13525                     && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
13526                        ||OP_TYPE_IS(sibling->op_next->op_next,
13527                                     OP_LEAVESUBLV))
13528                     && cUNOPx(sibling)->op_first == next
13529                     && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
13530                     && next->op_next
13531                 ) {
13532                     /* Look through the PUSHMARK's siblings for one that
13533                      * points to the RETURN */
13534                     OP *top = OpSIBLING(next);
13535                     while (top && top->op_next) {
13536                         if (top->op_next == sibling) {
13537                             top->op_next = sibling->op_next;
13538                             o->op_next = next->op_next;
13539                             break;
13540                         }
13541                         top = OpSIBLING(top);
13542                     }
13543                 }
13544             }
13545
13546             /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
13547              *
13548              * This latter form is then suitable for conversion into padrange
13549              * later on. Convert:
13550              *
13551              *   nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
13552              *
13553              * into:
13554              *
13555              *   nextstate1 ->     listop     -> nextstate3
13556              *                 /            \
13557              *         pushmark -> padop1 -> padop2
13558              */
13559             if (o->op_next && (
13560                     o->op_next->op_type == OP_PADSV
13561                  || o->op_next->op_type == OP_PADAV
13562                  || o->op_next->op_type == OP_PADHV
13563                 )
13564                 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
13565                 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
13566                 && o->op_next->op_next->op_next && (
13567                     o->op_next->op_next->op_next->op_type == OP_PADSV
13568                  || o->op_next->op_next->op_next->op_type == OP_PADAV
13569                  || o->op_next->op_next->op_next->op_type == OP_PADHV
13570                 )
13571                 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
13572                 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
13573                 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
13574                 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
13575             ) {
13576                 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
13577
13578                 pad1 =    o->op_next;
13579                 ns2  = pad1->op_next;
13580                 pad2 =  ns2->op_next;
13581                 ns3  = pad2->op_next;
13582
13583                 /* we assume here that the op_next chain is the same as
13584                  * the op_sibling chain */
13585                 assert(OpSIBLING(o)    == pad1);
13586                 assert(OpSIBLING(pad1) == ns2);
13587                 assert(OpSIBLING(ns2)  == pad2);
13588                 assert(OpSIBLING(pad2) == ns3);
13589
13590                 /* excise and delete ns2 */
13591                 op_sibling_splice(NULL, pad1, 1, NULL);
13592                 op_free(ns2);
13593
13594                 /* excise pad1 and pad2 */
13595                 op_sibling_splice(NULL, o, 2, NULL);
13596
13597                 /* create new listop, with children consisting of:
13598                  * a new pushmark, pad1, pad2. */
13599                 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
13600                 newop->op_flags |= OPf_PARENS;
13601                 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
13602
13603                 /* insert newop between o and ns3 */
13604                 op_sibling_splice(NULL, o, 0, newop);
13605
13606                 /*fixup op_next chain */
13607                 newpm = cUNOPx(newop)->op_first; /* pushmark */
13608                 o    ->op_next = newpm;
13609                 newpm->op_next = pad1;
13610                 pad1 ->op_next = pad2;
13611                 pad2 ->op_next = newop; /* listop */
13612                 newop->op_next = ns3;
13613
13614                 /* Ensure pushmark has this flag if padops do */
13615                 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
13616                     newpm->op_flags |= OPf_MOD;
13617                 }
13618
13619                 break;
13620             }
13621
13622             /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
13623                to carry two labels. For now, take the easier option, and skip
13624                this optimisation if the first NEXTSTATE has a label.  */
13625             if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
13626                 OP *nextop = o->op_next;
13627                 while (nextop && nextop->op_type == OP_NULL)
13628                     nextop = nextop->op_next;
13629
13630                 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
13631                     op_null(o);
13632                     if (oldop)
13633                         oldop->op_next = nextop;
13634                     o = nextop;
13635                     /* Skip (old)oldop assignment since the current oldop's
13636                        op_next already points to the next op.  */
13637                     goto redo;
13638                 }
13639             }
13640             break;
13641
13642         case OP_CONCAT:
13643             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
13644                 if (o->op_next->op_private & OPpTARGET_MY) {
13645                     if (o->op_flags & OPf_STACKED) /* chained concats */
13646                         break; /* ignore_optimization */
13647                     else {
13648                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
13649                         o->op_targ = o->op_next->op_targ;
13650                         o->op_next->op_targ = 0;
13651                         o->op_private |= OPpTARGET_MY;
13652                     }
13653                 }
13654                 op_null(o->op_next);
13655             }
13656             break;
13657         case OP_STUB:
13658             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
13659                 break; /* Scalar stub must produce undef.  List stub is noop */
13660             }
13661             goto nothin;
13662         case OP_NULL:
13663             if (o->op_targ == OP_NEXTSTATE
13664                 || o->op_targ == OP_DBSTATE)
13665             {
13666                 PL_curcop = ((COP*)o);
13667             }
13668             /* XXX: We avoid setting op_seq here to prevent later calls
13669                to rpeep() from mistakenly concluding that optimisation
13670                has already occurred. This doesn't fix the real problem,
13671                though (See 20010220.007 (#5874)). AMS 20010719 */
13672             /* op_seq functionality is now replaced by op_opt */
13673             o->op_opt = 0;
13674             /* FALLTHROUGH */
13675         case OP_SCALAR:
13676         case OP_LINESEQ:
13677         case OP_SCOPE:
13678         nothin:
13679             if (oldop) {
13680                 oldop->op_next = o->op_next;
13681                 o->op_opt = 0;
13682                 continue;
13683             }
13684             break;
13685
13686         case OP_PUSHMARK:
13687
13688             /* Given
13689                  5 repeat/DOLIST
13690                  3   ex-list
13691                  1     pushmark
13692                  2     scalar or const
13693                  4   const[0]
13694                convert repeat into a stub with no kids.
13695              */
13696             if (o->op_next->op_type == OP_CONST
13697              || (  o->op_next->op_type == OP_PADSV
13698                 && !(o->op_next->op_private & OPpLVAL_INTRO))
13699              || (  o->op_next->op_type == OP_GV
13700                 && o->op_next->op_next->op_type == OP_RV2SV
13701                 && !(o->op_next->op_next->op_private
13702                         & (OPpLVAL_INTRO|OPpOUR_INTRO))))
13703             {
13704                 const OP *kid = o->op_next->op_next;
13705                 if (o->op_next->op_type == OP_GV)
13706                    kid = kid->op_next;
13707                 /* kid is now the ex-list.  */
13708                 if (kid->op_type == OP_NULL
13709                  && (kid = kid->op_next)->op_type == OP_CONST
13710                     /* kid is now the repeat count.  */
13711                  && kid->op_next->op_type == OP_REPEAT
13712                  && kid->op_next->op_private & OPpREPEAT_DOLIST
13713                  && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
13714                  && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0)
13715                 {
13716                     o = kid->op_next; /* repeat */
13717                     assert(oldop);
13718                     oldop->op_next = o;
13719                     op_free(cBINOPo->op_first);
13720                     op_free(cBINOPo->op_last );
13721                     o->op_flags &=~ OPf_KIDS;
13722                     /* stub is a baseop; repeat is a binop */
13723                     STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
13724                     OpTYPE_set(o, OP_STUB);
13725                     o->op_private = 0;
13726                     break;
13727                 }
13728             }
13729
13730             /* Convert a series of PAD ops for my vars plus support into a
13731              * single padrange op. Basically
13732              *
13733              *    pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
13734              *
13735              * becomes, depending on circumstances, one of
13736              *
13737              *    padrange  ----------------------------------> (list) -> rest
13738              *    padrange  --------------------------------------------> rest
13739              *
13740              * where all the pad indexes are sequential and of the same type
13741              * (INTRO or not).
13742              * We convert the pushmark into a padrange op, then skip
13743              * any other pad ops, and possibly some trailing ops.
13744              * Note that we don't null() the skipped ops, to make it
13745              * easier for Deparse to undo this optimisation (and none of
13746              * the skipped ops are holding any resourses). It also makes
13747              * it easier for find_uninit_var(), as it can just ignore
13748              * padrange, and examine the original pad ops.
13749              */
13750         {
13751             OP *p;
13752             OP *followop = NULL; /* the op that will follow the padrange op */
13753             U8 count = 0;
13754             U8 intro = 0;
13755             PADOFFSET base = 0; /* init only to stop compiler whining */
13756             bool gvoid = 0;     /* init only to stop compiler whining */
13757             bool defav = 0;  /* seen (...) = @_ */
13758             bool reuse = 0;  /* reuse an existing padrange op */
13759
13760             /* look for a pushmark -> gv[_] -> rv2av */
13761
13762             {
13763                 OP *rv2av, *q;
13764                 p = o->op_next;
13765                 if (   p->op_type == OP_GV
13766                     && cGVOPx_gv(p) == PL_defgv
13767                     && (rv2av = p->op_next)
13768                     && rv2av->op_type == OP_RV2AV
13769                     && !(rv2av->op_flags & OPf_REF)
13770                     && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
13771                     && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
13772                 ) {
13773                     q = rv2av->op_next;
13774                     if (q->op_type == OP_NULL)
13775                         q = q->op_next;
13776                     if (q->op_type == OP_PUSHMARK) {
13777                         defav = 1;
13778                         p = q;
13779                     }
13780                 }
13781             }
13782             if (!defav) {
13783                 p = o;
13784             }
13785
13786             /* scan for PAD ops */
13787
13788             for (p = p->op_next; p; p = p->op_next) {
13789                 if (p->op_type == OP_NULL)
13790                     continue;
13791
13792                 if ((     p->op_type != OP_PADSV
13793                        && p->op_type != OP_PADAV
13794                        && p->op_type != OP_PADHV
13795                     )
13796                       /* any private flag other than INTRO? e.g. STATE */
13797                    || (p->op_private & ~OPpLVAL_INTRO)
13798                 )
13799                     break;
13800
13801                 /* let $a[N] potentially be optimised into AELEMFAST_LEX
13802                  * instead */
13803                 if (   p->op_type == OP_PADAV
13804                     && p->op_next
13805                     && p->op_next->op_type == OP_CONST
13806                     && p->op_next->op_next
13807                     && p->op_next->op_next->op_type == OP_AELEM
13808                 )
13809                     break;
13810
13811                 /* for 1st padop, note what type it is and the range
13812                  * start; for the others, check that it's the same type
13813                  * and that the targs are contiguous */
13814                 if (count == 0) {
13815                     intro = (p->op_private & OPpLVAL_INTRO);
13816                     base = p->op_targ;
13817                     gvoid = OP_GIMME(p,0) == G_VOID;
13818                 }
13819                 else {
13820                     if ((p->op_private & OPpLVAL_INTRO) != intro)
13821                         break;
13822                     /* Note that you'd normally  expect targs to be
13823                      * contiguous in my($a,$b,$c), but that's not the case
13824                      * when external modules start doing things, e.g.
13825                      * Function::Parameters */
13826                     if (p->op_targ != base + count)
13827                         break;
13828                     assert(p->op_targ == base + count);
13829                     /* Either all the padops or none of the padops should
13830                        be in void context.  Since we only do the optimisa-
13831                        tion for av/hv when the aggregate itself is pushed
13832                        on to the stack (one item), there is no need to dis-
13833                        tinguish list from scalar context.  */
13834                     if (gvoid != (OP_GIMME(p,0) == G_VOID))
13835                         break;
13836                 }
13837
13838                 /* for AV, HV, only when we're not flattening */
13839                 if (   p->op_type != OP_PADSV
13840                     && !gvoid
13841                     && !(p->op_flags & OPf_REF)
13842                 )
13843                     break;
13844
13845                 if (count >= OPpPADRANGE_COUNTMASK)
13846                     break;
13847
13848                 /* there's a biggest base we can fit into a
13849                  * SAVEt_CLEARPADRANGE in pp_padrange.
13850                  * (The sizeof() stuff will be constant-folded, and is
13851                  * intended to avoid getting "comparison is always false"
13852                  * compiler warnings. See the comments above
13853                  * MEM_WRAP_CHECK for more explanation on why we do this
13854                  * in a weird way to avoid compiler warnings.)
13855                  */
13856                 if (   intro
13857                     && (8*sizeof(base) >
13858                         8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
13859                         ? base
13860                         : (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
13861                         ) >
13862                         (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
13863                 )
13864                     break;
13865
13866                 /* Success! We've got another valid pad op to optimise away */
13867                 count++;
13868                 followop = p->op_next;
13869             }
13870
13871             if (count < 1 || (count == 1 && !defav))
13872                 break;
13873
13874             /* pp_padrange in specifically compile-time void context
13875              * skips pushing a mark and lexicals; in all other contexts
13876              * (including unknown till runtime) it pushes a mark and the
13877              * lexicals. We must be very careful then, that the ops we
13878              * optimise away would have exactly the same effect as the
13879              * padrange.
13880              * In particular in void context, we can only optimise to
13881              * a padrange if we see the complete sequence
13882              *     pushmark, pad*v, ...., list
13883              * which has the net effect of leaving the markstack as it
13884              * was.  Not pushing onto the stack (whereas padsv does touch
13885              * the stack) makes no difference in void context.
13886              */
13887             assert(followop);
13888             if (gvoid) {
13889                 if (followop->op_type == OP_LIST
13890                         && OP_GIMME(followop,0) == G_VOID
13891                    )
13892                 {
13893                     followop = followop->op_next; /* skip OP_LIST */
13894
13895                     /* consolidate two successive my(...);'s */
13896
13897                     if (   oldoldop
13898                         && oldoldop->op_type == OP_PADRANGE
13899                         && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
13900                         && (oldoldop->op_private & OPpLVAL_INTRO) == intro
13901                         && !(oldoldop->op_flags & OPf_SPECIAL)
13902                     ) {
13903                         U8 old_count;
13904                         assert(oldoldop->op_next == oldop);
13905                         assert(   oldop->op_type == OP_NEXTSTATE
13906                                || oldop->op_type == OP_DBSTATE);
13907                         assert(oldop->op_next == o);
13908
13909                         old_count
13910                             = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
13911
13912                        /* Do not assume pad offsets for $c and $d are con-
13913                           tiguous in
13914                             my ($a,$b,$c);
13915                             my ($d,$e,$f);
13916                         */
13917                         if (  oldoldop->op_targ + old_count == base
13918                            && old_count < OPpPADRANGE_COUNTMASK - count) {
13919                             base = oldoldop->op_targ;
13920                             count += old_count;
13921                             reuse = 1;
13922                         }
13923                     }
13924
13925                     /* if there's any immediately following singleton
13926                      * my var's; then swallow them and the associated
13927                      * nextstates; i.e.
13928                      *    my ($a,$b); my $c; my $d;
13929                      * is treated as
13930                      *    my ($a,$b,$c,$d);
13931                      */
13932
13933                     while (    ((p = followop->op_next))
13934                             && (  p->op_type == OP_PADSV
13935                                || p->op_type == OP_PADAV
13936                                || p->op_type == OP_PADHV)
13937                             && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
13938                             && (p->op_private & OPpLVAL_INTRO) == intro
13939                             && !(p->op_private & ~OPpLVAL_INTRO)
13940                             && p->op_next
13941                             && (   p->op_next->op_type == OP_NEXTSTATE
13942                                 || p->op_next->op_type == OP_DBSTATE)
13943                             && count < OPpPADRANGE_COUNTMASK
13944                             && base + count == p->op_targ
13945                     ) {
13946                         count++;
13947                         followop = p->op_next;
13948                     }
13949                 }
13950                 else
13951                     break;
13952             }
13953
13954             if (reuse) {
13955                 assert(oldoldop->op_type == OP_PADRANGE);
13956                 oldoldop->op_next = followop;
13957                 oldoldop->op_private = (intro | count);
13958                 o = oldoldop;
13959                 oldop = NULL;
13960                 oldoldop = NULL;
13961             }
13962             else {
13963                 /* Convert the pushmark into a padrange.
13964                  * To make Deparse easier, we guarantee that a padrange was
13965                  * *always* formerly a pushmark */
13966                 assert(o->op_type == OP_PUSHMARK);
13967                 o->op_next = followop;
13968                 OpTYPE_set(o, OP_PADRANGE);
13969                 o->op_targ = base;
13970                 /* bit 7: INTRO; bit 6..0: count */
13971                 o->op_private = (intro | count);
13972                 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
13973                               | gvoid * OPf_WANT_VOID
13974                               | (defav ? OPf_SPECIAL : 0));
13975             }
13976             break;
13977         }
13978
13979         case OP_PADAV:
13980         case OP_PADSV:
13981         case OP_PADHV:
13982         /* Skip over state($x) in void context.  */
13983         if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
13984          && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
13985         {
13986             oldop->op_next = o->op_next;
13987             goto redo_nextstate;
13988         }
13989         if (o->op_type != OP_PADAV)
13990             break;
13991         /* FALLTHROUGH */
13992         case OP_GV:
13993             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
13994                 OP* const pop = (o->op_type == OP_PADAV) ?
13995                             o->op_next : o->op_next->op_next;
13996                 IV i;
13997                 if (pop && pop->op_type == OP_CONST &&
13998                     ((PL_op = pop->op_next)) &&
13999                     pop->op_next->op_type == OP_AELEM &&
14000                     !(pop->op_next->op_private &
14001                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
14002                     (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
14003                 {
14004                     GV *gv;
14005                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
14006                         no_bareword_allowed(pop);
14007                     if (o->op_type == OP_GV)
14008                         op_null(o->op_next);
14009                     op_null(pop->op_next);
14010                     op_null(pop);
14011                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
14012                     o->op_next = pop->op_next->op_next;
14013                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
14014                     o->op_private = (U8)i;
14015                     if (o->op_type == OP_GV) {
14016                         gv = cGVOPo_gv;
14017                         GvAVn(gv);
14018                         o->op_type = OP_AELEMFAST;
14019                     }
14020                     else
14021                         o->op_type = OP_AELEMFAST_LEX;
14022                 }
14023                 if (o->op_type != OP_GV)
14024                     break;
14025             }
14026
14027             /* Remove $foo from the op_next chain in void context.  */
14028             if (oldop
14029              && (  o->op_next->op_type == OP_RV2SV
14030                 || o->op_next->op_type == OP_RV2AV
14031                 || o->op_next->op_type == OP_RV2HV  )
14032              && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
14033              && !(o->op_next->op_private & OPpLVAL_INTRO))
14034             {
14035                 oldop->op_next = o->op_next->op_next;
14036                 /* Reprocess the previous op if it is a nextstate, to
14037                    allow double-nextstate optimisation.  */
14038               redo_nextstate:
14039                 if (oldop->op_type == OP_NEXTSTATE) {
14040                     oldop->op_opt = 0;
14041                     o = oldop;
14042                     oldop = oldoldop;
14043                     oldoldop = NULL;
14044                     goto redo;
14045                 }
14046                 o = oldop->op_next;
14047                 goto redo;
14048             }
14049             else if (o->op_next->op_type == OP_RV2SV) {
14050                 if (!(o->op_next->op_private & OPpDEREF)) {
14051                     op_null(o->op_next);
14052                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
14053                                                                | OPpOUR_INTRO);
14054                     o->op_next = o->op_next->op_next;
14055                     OpTYPE_set(o, OP_GVSV);
14056                 }
14057             }
14058             else if (o->op_next->op_type == OP_READLINE
14059                     && o->op_next->op_next->op_type == OP_CONCAT
14060                     && (o->op_next->op_next->op_flags & OPf_STACKED))
14061             {
14062                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
14063                 OpTYPE_set(o, OP_RCATLINE);
14064                 o->op_flags |= OPf_STACKED;
14065                 op_null(o->op_next->op_next);
14066                 op_null(o->op_next);
14067             }
14068
14069             break;
14070
14071 #define HV_OR_SCALARHV(op)                                   \
14072     (  (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \
14073        ? (op)                                                  \
14074        : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \
14075        && (  cUNOPx(op)->op_first->op_type == OP_PADHV          \
14076           || cUNOPx(op)->op_first->op_type == OP_RV2HV)          \
14077          ? cUNOPx(op)->op_first                                   \
14078          : NULL)
14079
14080         case OP_NOT:
14081             if ((fop = HV_OR_SCALARHV(cUNOP->op_first)))
14082                 fop->op_private |= OPpTRUEBOOL;
14083             break;
14084
14085         case OP_AND:
14086         case OP_OR:
14087         case OP_DOR:
14088             fop = cLOGOP->op_first;
14089             sop = OpSIBLING(fop);
14090             while (cLOGOP->op_other->op_type == OP_NULL)
14091                 cLOGOP->op_other = cLOGOP->op_other->op_next;
14092             while (o->op_next && (   o->op_type == o->op_next->op_type
14093                                   || o->op_next->op_type == OP_NULL))
14094                 o->op_next = o->op_next->op_next;
14095
14096             /* If we're an OR and our next is an AND in void context, we'll
14097                follow its op_other on short circuit, same for reverse.
14098                We can't do this with OP_DOR since if it's true, its return
14099                value is the underlying value which must be evaluated
14100                by the next op. */
14101             if (o->op_next &&
14102                 (
14103                     (IS_AND_OP(o) && IS_OR_OP(o->op_next))
14104                  || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
14105                 )
14106                 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
14107             ) {
14108                 o->op_next = ((LOGOP*)o->op_next)->op_other;
14109             }
14110             DEFER(cLOGOP->op_other);
14111
14112             o->op_opt = 1;
14113             fop = HV_OR_SCALARHV(fop);
14114             if (sop) sop = HV_OR_SCALARHV(sop);
14115             if (fop || sop
14116             ){
14117                 OP * nop = o;
14118                 OP * lop = o;
14119                 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
14120                     while (nop && nop->op_next) {
14121                         switch (nop->op_next->op_type) {
14122                             case OP_NOT:
14123                             case OP_AND:
14124                             case OP_OR:
14125                             case OP_DOR:
14126                                 lop = nop = nop->op_next;
14127                                 break;
14128                             case OP_NULL:
14129                                 nop = nop->op_next;
14130                                 break;
14131                             default:
14132                                 nop = NULL;
14133                                 break;
14134                         }
14135                     }
14136                 }
14137                 if (fop) {
14138                     if (  (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
14139                       || o->op_type == OP_AND  )
14140                         fop->op_private |= OPpTRUEBOOL;
14141                     else if (!(lop->op_flags & OPf_WANT))
14142                         fop->op_private |= OPpMAYBE_TRUEBOOL;
14143                 }
14144                 if (  (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
14145                    && sop)
14146                     sop->op_private |= OPpTRUEBOOL;
14147             }
14148
14149
14150             break;
14151
14152         case OP_COND_EXPR:
14153             if ((fop = HV_OR_SCALARHV(cLOGOP->op_first)))
14154                 fop->op_private |= OPpTRUEBOOL;
14155 #undef HV_OR_SCALARHV
14156             /* GERONIMO! */ /* FALLTHROUGH */
14157
14158         case OP_MAPWHILE:
14159         case OP_GREPWHILE:
14160         case OP_ANDASSIGN:
14161         case OP_ORASSIGN:
14162         case OP_DORASSIGN:
14163         case OP_RANGE:
14164         case OP_ONCE:
14165             while (cLOGOP->op_other->op_type == OP_NULL)
14166                 cLOGOP->op_other = cLOGOP->op_other->op_next;
14167             DEFER(cLOGOP->op_other);
14168             break;
14169
14170         case OP_ENTERLOOP:
14171         case OP_ENTERITER:
14172             while (cLOOP->op_redoop->op_type == OP_NULL)
14173                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
14174             while (cLOOP->op_nextop->op_type == OP_NULL)
14175                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
14176             while (cLOOP->op_lastop->op_type == OP_NULL)
14177                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
14178             /* a while(1) loop doesn't have an op_next that escapes the
14179              * loop, so we have to explicitly follow the op_lastop to
14180              * process the rest of the code */
14181             DEFER(cLOOP->op_lastop);
14182             break;
14183
14184         case OP_ENTERTRY:
14185             assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
14186             DEFER(cLOGOPo->op_other);
14187             break;
14188
14189         case OP_SUBST:
14190             assert(!(cPMOP->op_pmflags & PMf_ONCE));
14191             while (cPMOP->op_pmstashstartu.op_pmreplstart &&
14192                    cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
14193                 cPMOP->op_pmstashstartu.op_pmreplstart
14194                     = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
14195             DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
14196             break;
14197
14198         case OP_SORT: {
14199             OP *oright;
14200
14201             if (o->op_flags & OPf_SPECIAL) {
14202                 /* first arg is a code block */
14203                 OP * const nullop = OpSIBLING(cLISTOP->op_first);
14204                 OP * kid          = cUNOPx(nullop)->op_first;
14205
14206                 assert(nullop->op_type == OP_NULL);
14207                 assert(kid->op_type == OP_SCOPE
14208                  || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
14209                 /* since OP_SORT doesn't have a handy op_other-style
14210                  * field that can point directly to the start of the code
14211                  * block, store it in the otherwise-unused op_next field
14212                  * of the top-level OP_NULL. This will be quicker at
14213                  * run-time, and it will also allow us to remove leading
14214                  * OP_NULLs by just messing with op_nexts without
14215                  * altering the basic op_first/op_sibling layout. */
14216                 kid = kLISTOP->op_first;
14217                 assert(
14218                       (kid->op_type == OP_NULL
14219                       && (  kid->op_targ == OP_NEXTSTATE
14220                          || kid->op_targ == OP_DBSTATE  ))
14221                     || kid->op_type == OP_STUB
14222                     || kid->op_type == OP_ENTER);
14223                 nullop->op_next = kLISTOP->op_next;
14224                 DEFER(nullop->op_next);
14225             }
14226
14227             /* check that RHS of sort is a single plain array */
14228             oright = cUNOPo->op_first;
14229             if (!oright || oright->op_type != OP_PUSHMARK)
14230                 break;
14231
14232             if (o->op_private & OPpSORT_INPLACE)
14233                 break;
14234
14235             /* reverse sort ... can be optimised.  */
14236             if (!OpHAS_SIBLING(cUNOPo)) {
14237                 /* Nothing follows us on the list. */
14238                 OP * const reverse = o->op_next;
14239
14240                 if (reverse->op_type == OP_REVERSE &&
14241                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
14242                     OP * const pushmark = cUNOPx(reverse)->op_first;
14243                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
14244                         && (OpSIBLING(cUNOPx(pushmark)) == o)) {
14245                         /* reverse -> pushmark -> sort */
14246                         o->op_private |= OPpSORT_REVERSE;
14247                         op_null(reverse);
14248                         pushmark->op_next = oright->op_next;
14249                         op_null(oright);
14250                     }
14251                 }
14252             }
14253
14254             break;
14255         }
14256
14257         case OP_REVERSE: {
14258             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
14259             OP *gvop = NULL;
14260             LISTOP *enter, *exlist;
14261
14262             if (o->op_private & OPpSORT_INPLACE)
14263                 break;
14264
14265             enter = (LISTOP *) o->op_next;
14266             if (!enter)
14267                 break;
14268             if (enter->op_type == OP_NULL) {
14269                 enter = (LISTOP *) enter->op_next;
14270                 if (!enter)
14271                     break;
14272             }
14273             /* for $a (...) will have OP_GV then OP_RV2GV here.
14274                for (...) just has an OP_GV.  */
14275             if (enter->op_type == OP_GV) {
14276                 gvop = (OP *) enter;
14277                 enter = (LISTOP *) enter->op_next;
14278                 if (!enter)
14279                     break;
14280                 if (enter->op_type == OP_RV2GV) {
14281                   enter = (LISTOP *) enter->op_next;
14282                   if (!enter)
14283                     break;
14284                 }
14285             }
14286
14287             if (enter->op_type != OP_ENTERITER)
14288                 break;
14289
14290             iter = enter->op_next;
14291             if (!iter || iter->op_type != OP_ITER)
14292                 break;
14293
14294             expushmark = enter->op_first;
14295             if (!expushmark || expushmark->op_type != OP_NULL
14296                 || expushmark->op_targ != OP_PUSHMARK)
14297                 break;
14298
14299             exlist = (LISTOP *) OpSIBLING(expushmark);
14300             if (!exlist || exlist->op_type != OP_NULL
14301                 || exlist->op_targ != OP_LIST)
14302                 break;
14303
14304             if (exlist->op_last != o) {
14305                 /* Mmm. Was expecting to point back to this op.  */
14306                 break;
14307             }
14308             theirmark = exlist->op_first;
14309             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
14310                 break;
14311
14312             if (OpSIBLING(theirmark) != o) {
14313                 /* There's something between the mark and the reverse, eg
14314                    for (1, reverse (...))
14315                    so no go.  */
14316                 break;
14317             }
14318
14319             ourmark = ((LISTOP *)o)->op_first;
14320             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
14321                 break;
14322
14323             ourlast = ((LISTOP *)o)->op_last;
14324             if (!ourlast || ourlast->op_next != o)
14325                 break;
14326
14327             rv2av = OpSIBLING(ourmark);
14328             if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
14329                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
14330                 /* We're just reversing a single array.  */
14331                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
14332                 enter->op_flags |= OPf_STACKED;
14333             }
14334
14335             /* We don't have control over who points to theirmark, so sacrifice
14336                ours.  */
14337             theirmark->op_next = ourmark->op_next;
14338             theirmark->op_flags = ourmark->op_flags;
14339             ourlast->op_next = gvop ? gvop : (OP *) enter;
14340             op_null(ourmark);
14341             op_null(o);
14342             enter->op_private |= OPpITER_REVERSED;
14343             iter->op_private |= OPpITER_REVERSED;
14344
14345             oldoldop = NULL;
14346             oldop    = ourlast;
14347             o        = oldop->op_next;
14348             goto redo;
14349
14350             break;
14351         }
14352
14353         case OP_QR:
14354         case OP_MATCH:
14355             if (!(cPMOP->op_pmflags & PMf_ONCE)) {
14356                 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
14357             }
14358             break;
14359
14360         case OP_RUNCV:
14361             if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
14362              && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
14363             {
14364                 SV *sv;
14365                 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
14366                 else {
14367                     sv = newRV((SV *)PL_compcv);
14368                     sv_rvweaken(sv);
14369                     SvREADONLY_on(sv);
14370                 }
14371                 OpTYPE_set(o, OP_CONST);
14372                 o->op_flags |= OPf_SPECIAL;
14373                 cSVOPo->op_sv = sv;
14374             }
14375             break;
14376
14377         case OP_SASSIGN:
14378             if (OP_GIMME(o,0) == G_VOID
14379              || (  o->op_next->op_type == OP_LINESEQ
14380                 && (  o->op_next->op_next->op_type == OP_LEAVESUB
14381                    || (  o->op_next->op_next->op_type == OP_RETURN
14382                       && !CvLVALUE(PL_compcv)))))
14383             {
14384                 OP *right = cBINOP->op_first;
14385                 if (right) {
14386                     /*   sassign
14387                     *      RIGHT
14388                     *      substr
14389                     *         pushmark
14390                     *         arg1
14391                     *         arg2
14392                     *         ...
14393                     * becomes
14394                     *
14395                     *  ex-sassign
14396                     *     substr
14397                     *        pushmark
14398                     *        RIGHT
14399                     *        arg1
14400                     *        arg2
14401                     *        ...
14402                     */
14403                     OP *left = OpSIBLING(right);
14404                     if (left->op_type == OP_SUBSTR
14405                          && (left->op_private & 7) < 4) {
14406                         op_null(o);
14407                         /* cut out right */
14408                         op_sibling_splice(o, NULL, 1, NULL);
14409                         /* and insert it as second child of OP_SUBSTR */
14410                         op_sibling_splice(left, cBINOPx(left)->op_first, 0,
14411                                     right);
14412                         left->op_private |= OPpSUBSTR_REPL_FIRST;
14413                         left->op_flags =
14414                             (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
14415                     }
14416                 }
14417             }
14418             break;
14419
14420         case OP_AASSIGN: {
14421             int l, r, lr, lscalars, rscalars;
14422
14423             /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
14424                Note that we do this now rather than in newASSIGNOP(),
14425                since only by now are aliased lexicals flagged as such
14426
14427                See the essay "Common vars in list assignment" above for
14428                the full details of the rationale behind all the conditions
14429                below.
14430
14431                PL_generation sorcery:
14432                To detect whether there are common vars, the global var
14433                PL_generation is incremented for each assign op we scan.
14434                Then we run through all the lexical variables on the LHS,
14435                of the assignment, setting a spare slot in each of them to
14436                PL_generation.  Then we scan the RHS, and if any lexicals
14437                already have that value, we know we've got commonality.
14438                Also, if the generation number is already set to
14439                PERL_INT_MAX, then the variable is involved in aliasing, so
14440                we also have potential commonality in that case.
14441              */
14442
14443             PL_generation++;
14444             /* scan LHS */
14445             lscalars = 0;
14446             l = S_aassign_scan(aTHX_ cLISTOPo->op_last,  FALSE, 1, &lscalars);
14447             /* scan RHS */
14448             rscalars = 0;
14449             r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, 1, &rscalars);
14450             lr = (l|r);
14451
14452
14453             /* After looking for things which are *always* safe, this main
14454              * if/else chain selects primarily based on the type of the
14455              * LHS, gradually working its way down from the more dangerous
14456              * to the more restrictive and thus safer cases */
14457
14458             if (   !l                      /* () = ....; */
14459                 || !r                      /* .... = (); */
14460                 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
14461                 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
14462                 || (lscalars < 2)          /* ($x, undef) = ... */
14463             ) {
14464                 NOOP; /* always safe */
14465             }
14466             else if (l & AAS_DANGEROUS) {
14467                 /* always dangerous */
14468                 o->op_private |= OPpASSIGN_COMMON_SCALAR;
14469                 o->op_private |= OPpASSIGN_COMMON_AGG;
14470             }
14471             else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
14472                 /* package vars are always dangerous - too many
14473                  * aliasing possibilities */
14474                 if (l & AAS_PKG_SCALAR)
14475                     o->op_private |= OPpASSIGN_COMMON_SCALAR;
14476                 if (l & AAS_PKG_AGG)
14477                     o->op_private |= OPpASSIGN_COMMON_AGG;
14478             }
14479             else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
14480                           |AAS_LEX_SCALAR|AAS_LEX_AGG))
14481             {
14482                 /* LHS contains only lexicals and safe ops */
14483
14484                 if (l & (AAS_MY_AGG|AAS_LEX_AGG))
14485                     o->op_private |= OPpASSIGN_COMMON_AGG;
14486
14487                 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
14488                     if (lr & AAS_LEX_SCALAR_COMM)
14489                         o->op_private |= OPpASSIGN_COMMON_SCALAR;
14490                     else if (   !(l & AAS_LEX_SCALAR)
14491                              && (r & AAS_DEFAV))
14492                     {
14493                         /* falsely mark
14494                          *    my (...) = @_
14495                          * as scalar-safe for performance reasons.
14496                          * (it will still have been marked _AGG if necessary */
14497                         NOOP;
14498                     }
14499                     else if (r  & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
14500                         o->op_private |= OPpASSIGN_COMMON_RC1;
14501                 }
14502             }
14503
14504             /* ... = ($x)
14505              * may have to handle aggregate on LHS, but we can't
14506              * have common scalars. */
14507             if (rscalars < 2)
14508                 o->op_private &=
14509                         ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
14510
14511             break;
14512         }
14513
14514         case OP_CUSTOM: {
14515             Perl_cpeep_t cpeep =
14516                 XopENTRYCUSTOM(o, xop_peep);
14517             if (cpeep)
14518                 cpeep(aTHX_ o, oldop);
14519             break;
14520         }
14521
14522         }
14523         /* did we just null the current op? If so, re-process it to handle
14524          * eliding "empty" ops from the chain */
14525         if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
14526             o->op_opt = 0;
14527             o = oldop;
14528         }
14529         else {
14530             oldoldop = oldop;
14531             oldop = o;
14532         }
14533     }
14534     LEAVE;
14535 }
14536
14537 void
14538 Perl_peep(pTHX_ OP *o)
14539 {
14540     CALL_RPEEP(o);
14541 }
14542
14543 /*
14544 =head1 Custom Operators
14545
14546 =for apidoc Ao||custom_op_xop
14547 Return the XOP structure for a given custom op.  This macro should be
14548 considered internal to C<OP_NAME> and the other access macros: use them instead.
14549 This macro does call a function.  Prior
14550 to 5.19.6, this was implemented as a
14551 function.
14552
14553 =cut
14554 */
14555
14556 XOPRETANY
14557 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
14558 {
14559     SV *keysv;
14560     HE *he = NULL;
14561     XOP *xop;
14562
14563     static const XOP xop_null = { 0, 0, 0, 0, 0 };
14564
14565     PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
14566     assert(o->op_type == OP_CUSTOM);
14567
14568     /* This is wrong. It assumes a function pointer can be cast to IV,
14569      * which isn't guaranteed, but this is what the old custom OP code
14570      * did. In principle it should be safer to Copy the bytes of the
14571      * pointer into a PV: since the new interface is hidden behind
14572      * functions, this can be changed later if necessary.  */
14573     /* Change custom_op_xop if this ever happens */
14574     keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
14575
14576     if (PL_custom_ops)
14577         he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
14578
14579     /* assume noone will have just registered a desc */
14580     if (!he && PL_custom_op_names &&
14581         (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
14582     ) {
14583         const char *pv;
14584         STRLEN l;
14585
14586         /* XXX does all this need to be shared mem? */
14587         Newxz(xop, 1, XOP);
14588         pv = SvPV(HeVAL(he), l);
14589         XopENTRY_set(xop, xop_name, savepvn(pv, l));
14590         if (PL_custom_op_descs &&
14591             (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
14592         ) {
14593             pv = SvPV(HeVAL(he), l);
14594             XopENTRY_set(xop, xop_desc, savepvn(pv, l));
14595         }
14596         Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
14597     }
14598     else {
14599         if (!he)
14600             xop = (XOP *)&xop_null;
14601         else
14602             xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
14603     }
14604     {
14605         XOPRETANY any;
14606         if(field == XOPe_xop_ptr) {
14607             any.xop_ptr = xop;
14608         } else {
14609             const U32 flags = XopFLAGS(xop);
14610             if(flags & field) {
14611                 switch(field) {
14612                 case XOPe_xop_name:
14613                     any.xop_name = xop->xop_name;
14614                     break;
14615                 case XOPe_xop_desc:
14616                     any.xop_desc = xop->xop_desc;
14617                     break;
14618                 case XOPe_xop_class:
14619                     any.xop_class = xop->xop_class;
14620                     break;
14621                 case XOPe_xop_peep:
14622                     any.xop_peep = xop->xop_peep;
14623                     break;
14624                 default:
14625                     NOT_REACHED; /* NOTREACHED */
14626                     break;
14627                 }
14628             } else {
14629                 switch(field) {
14630                 case XOPe_xop_name:
14631                     any.xop_name = XOPd_xop_name;
14632                     break;
14633                 case XOPe_xop_desc:
14634                     any.xop_desc = XOPd_xop_desc;
14635                     break;
14636                 case XOPe_xop_class:
14637                     any.xop_class = XOPd_xop_class;
14638                     break;
14639                 case XOPe_xop_peep:
14640                     any.xop_peep = XOPd_xop_peep;
14641                     break;
14642                 default:
14643                     NOT_REACHED; /* NOTREACHED */
14644                     break;
14645                 }
14646             }
14647         }
14648         /* On some platforms (HP-UX, IA64) gcc emits a warning for this function:
14649          * op.c: In function 'Perl_custom_op_get_field':
14650          * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
14651          * This is because on those platforms (with -DEBUGGING) NOT_REACHED
14652          * expands to assert(0), which expands to ((0) ? (void)0 :
14653          * __assert(...)), and gcc doesn't know that __assert can never return. */
14654         return any;
14655     }
14656 }
14657
14658 /*
14659 =for apidoc Ao||custom_op_register
14660 Register a custom op.  See L<perlguts/"Custom Operators">.
14661
14662 =cut
14663 */
14664
14665 void
14666 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
14667 {
14668     SV *keysv;
14669
14670     PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
14671
14672     /* see the comment in custom_op_xop */
14673     keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
14674
14675     if (!PL_custom_ops)
14676         PL_custom_ops = newHV();
14677
14678     if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
14679         Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
14680 }
14681
14682 /*
14683
14684 =for apidoc core_prototype
14685
14686 This function assigns the prototype of the named core function to C<sv>, or
14687 to a new mortal SV if C<sv> is C<NULL>.  It returns the modified C<sv>, or
14688 C<NULL> if the core function has no prototype.  C<code> is a code as returned
14689 by C<keyword()>.  It must not be equal to 0.
14690
14691 =cut
14692 */
14693
14694 SV *
14695 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
14696                           int * const opnum)
14697 {
14698     int i = 0, n = 0, seen_question = 0, defgv = 0;
14699     I32 oa;
14700 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
14701     char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
14702     bool nullret = FALSE;
14703
14704     PERL_ARGS_ASSERT_CORE_PROTOTYPE;
14705
14706     assert (code);
14707
14708     if (!sv) sv = sv_newmortal();
14709
14710 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
14711
14712     switch (code < 0 ? -code : code) {
14713     case KEY_and   : case KEY_chop: case KEY_chomp:
14714     case KEY_cmp   : case KEY_defined: case KEY_delete: case KEY_exec  :
14715     case KEY_exists: case KEY_eq     : case KEY_ge    : case KEY_goto  :
14716     case KEY_grep  : case KEY_gt     : case KEY_last  : case KEY_le    :
14717     case KEY_lt    : case KEY_map    : case KEY_ne    : case KEY_next  :
14718     case KEY_or    : case KEY_print  : case KEY_printf: case KEY_qr    :
14719     case KEY_redo  : case KEY_require: case KEY_return: case KEY_say   :
14720     case KEY_select: case KEY_sort   : case KEY_split : case KEY_system:
14721     case KEY_x     : case KEY_xor    :
14722         if (!opnum) return NULL; nullret = TRUE; goto findopnum;
14723     case KEY_glob:    retsetpvs("_;", OP_GLOB);
14724     case KEY_keys:    retsetpvs("\\[%@]", OP_KEYS);
14725     case KEY_values:  retsetpvs("\\[%@]", OP_VALUES);
14726     case KEY_each:    retsetpvs("\\[%@]", OP_EACH);
14727     case KEY_pos:     retsetpvs(";\\[$*]", OP_POS);
14728     case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
14729         retsetpvs("", 0);
14730     case KEY_evalbytes:
14731         name = "entereval"; break;
14732     case KEY_readpipe:
14733         name = "backtick";
14734     }
14735
14736 #undef retsetpvs
14737
14738   findopnum:
14739     while (i < MAXO) {  /* The slow way. */
14740         if (strEQ(name, PL_op_name[i])
14741             || strEQ(name, PL_op_desc[i]))
14742         {
14743             if (nullret) { assert(opnum); *opnum = i; return NULL; }
14744             goto found;
14745         }
14746         i++;
14747     }
14748     return NULL;
14749   found:
14750     defgv = PL_opargs[i] & OA_DEFGV;
14751     oa = PL_opargs[i] >> OASHIFT;
14752     while (oa) {
14753         if (oa & OA_OPTIONAL && !seen_question && (
14754               !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
14755         )) {
14756             seen_question = 1;
14757             str[n++] = ';';
14758         }
14759         if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
14760             && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
14761             /* But globs are already references (kinda) */
14762             && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
14763         ) {
14764             str[n++] = '\\';
14765         }
14766         if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
14767          && !scalar_mod_type(NULL, i)) {
14768             str[n++] = '[';
14769             str[n++] = '$';
14770             str[n++] = '@';
14771             str[n++] = '%';
14772             if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
14773             str[n++] = '*';
14774             str[n++] = ']';
14775         }
14776         else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
14777         if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
14778             str[n-1] = '_'; defgv = 0;
14779         }
14780         oa = oa >> 4;
14781     }
14782     if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
14783     str[n++] = '\0';
14784     sv_setpvn(sv, str, n - 1);
14785     if (opnum) *opnum = i;
14786     return sv;
14787 }
14788
14789 OP *
14790 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
14791                       const int opnum)
14792 {
14793     OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
14794     OP *o;
14795
14796     PERL_ARGS_ASSERT_CORESUB_OP;
14797
14798     switch(opnum) {
14799     case 0:
14800         return op_append_elem(OP_LINESEQ,
14801                        argop,
14802                        newSLICEOP(0,
14803                                   newSVOP(OP_CONST, 0, newSViv(-code % 3)),
14804                                   newOP(OP_CALLER,0)
14805                        )
14806                );
14807     case OP_EACH:
14808     case OP_KEYS:
14809     case OP_VALUES:
14810         o = newUNOP(OP_AVHVSWITCH,0,argop);
14811         o->op_private = opnum-OP_EACH;
14812         return o;
14813     case OP_SELECT: /* which represents OP_SSELECT as well */
14814         if (code)
14815             return newCONDOP(
14816                          0,
14817                          newBINOP(OP_GT, 0,
14818                                   newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
14819                                   newSVOP(OP_CONST, 0, newSVuv(1))
14820                                  ),
14821                          coresub_op(newSVuv((UV)OP_SSELECT), 0,
14822                                     OP_SSELECT),
14823                          coresub_op(coreargssv, 0, OP_SELECT)
14824                    );
14825         /* FALLTHROUGH */
14826     default:
14827         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
14828         case OA_BASEOP:
14829             return op_append_elem(
14830                         OP_LINESEQ, argop,
14831                         newOP(opnum,
14832                               opnum == OP_WANTARRAY || opnum == OP_RUNCV
14833                                 ? OPpOFFBYONE << 8 : 0)
14834                    );
14835         case OA_BASEOP_OR_UNOP:
14836             if (opnum == OP_ENTEREVAL) {
14837                 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
14838                 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
14839             }
14840             else o = newUNOP(opnum,0,argop);
14841             if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
14842             else {
14843           onearg:
14844               if (is_handle_constructor(o, 1))
14845                 argop->op_private |= OPpCOREARGS_DEREF1;
14846               if (scalar_mod_type(NULL, opnum))
14847                 argop->op_private |= OPpCOREARGS_SCALARMOD;
14848             }
14849             return o;
14850         default:
14851             o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
14852             if (is_handle_constructor(o, 2))
14853                 argop->op_private |= OPpCOREARGS_DEREF2;
14854             if (opnum == OP_SUBSTR) {
14855                 o->op_private |= OPpMAYBE_LVSUB;
14856                 return o;
14857             }
14858             else goto onearg;
14859         }
14860     }
14861 }
14862
14863 void
14864 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
14865                                SV * const *new_const_svp)
14866 {
14867     const char *hvname;
14868     bool is_const = !!CvCONST(old_cv);
14869     SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
14870
14871     PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
14872
14873     if (is_const && new_const_svp && old_const_sv == *new_const_svp)
14874         return;
14875         /* They are 2 constant subroutines generated from
14876            the same constant. This probably means that
14877            they are really the "same" proxy subroutine
14878            instantiated in 2 places. Most likely this is
14879            when a constant is exported twice.  Don't warn.
14880         */
14881     if (
14882         (ckWARN(WARN_REDEFINE)
14883          && !(
14884                 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
14885              && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
14886              && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
14887                  strEQ(hvname, "autouse"))
14888              )
14889         )
14890      || (is_const
14891          && ckWARN_d(WARN_REDEFINE)
14892          && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
14893         )
14894     )
14895         Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
14896                           is_const
14897                             ? "Constant subroutine %"SVf" redefined"
14898                             : "Subroutine %"SVf" redefined",
14899                           SVfARG(name));
14900 }
14901
14902 /*
14903 =head1 Hook manipulation
14904
14905 These functions provide convenient and thread-safe means of manipulating
14906 hook variables.
14907
14908 =cut
14909 */
14910
14911 /*
14912 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
14913
14914 Puts a C function into the chain of check functions for a specified op
14915 type.  This is the preferred way to manipulate the L</PL_check> array.
14916 C<opcode> specifies which type of op is to be affected.  C<new_checker>
14917 is a pointer to the C function that is to be added to that opcode's
14918 check chain, and C<old_checker_p> points to the storage location where a
14919 pointer to the next function in the chain will be stored.  The value of
14920 C<new_pointer> is written into the L</PL_check> array, while the value
14921 previously stored there is written to C<*old_checker_p>.
14922
14923 The function should be defined like this:
14924
14925     static OP *new_checker(pTHX_ OP *op) { ... }
14926
14927 It is intended to be called in this manner:
14928
14929     new_checker(aTHX_ op)
14930
14931 C<old_checker_p> should be defined like this:
14932
14933     static Perl_check_t old_checker_p;
14934
14935 L</PL_check> is global to an entire process, and a module wishing to
14936 hook op checking may find itself invoked more than once per process,
14937 typically in different threads.  To handle that situation, this function
14938 is idempotent.  The location C<*old_checker_p> must initially (once
14939 per process) contain a null pointer.  A C variable of static duration
14940 (declared at file scope, typically also marked C<static> to give
14941 it internal linkage) will be implicitly initialised appropriately,
14942 if it does not have an explicit initialiser.  This function will only
14943 actually modify the check chain if it finds C<*old_checker_p> to be null.
14944 This function is also thread safe on the small scale.  It uses appropriate
14945 locking to avoid race conditions in accessing L</PL_check>.
14946
14947 When this function is called, the function referenced by C<new_checker>
14948 must be ready to be called, except for C<*old_checker_p> being unfilled.
14949 In a threading situation, C<new_checker> may be called immediately,
14950 even before this function has returned.  C<*old_checker_p> will always
14951 be appropriately set before C<new_checker> is called.  If C<new_checker>
14952 decides not to do anything special with an op that it is given (which
14953 is the usual case for most uses of op check hooking), it must chain the
14954 check function referenced by C<*old_checker_p>.
14955
14956 If you want to influence compilation of calls to a specific subroutine,
14957 then use L</cv_set_call_checker> rather than hooking checking of all
14958 C<entersub> ops.
14959
14960 =cut
14961 */
14962
14963 void
14964 Perl_wrap_op_checker(pTHX_ Optype opcode,
14965     Perl_check_t new_checker, Perl_check_t *old_checker_p)
14966 {
14967     dVAR;
14968
14969     PERL_UNUSED_CONTEXT;
14970     PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
14971     if (*old_checker_p) return;
14972     OP_CHECK_MUTEX_LOCK;
14973     if (!*old_checker_p) {
14974         *old_checker_p = PL_check[opcode];
14975         PL_check[opcode] = new_checker;
14976     }
14977     OP_CHECK_MUTEX_UNLOCK;
14978 }
14979
14980 #include "XSUB.h"
14981
14982 /* Efficient sub that returns a constant scalar value. */
14983 static void
14984 const_sv_xsub(pTHX_ CV* cv)
14985 {
14986     dXSARGS;
14987     SV *const sv = MUTABLE_SV(XSANY.any_ptr);
14988     PERL_UNUSED_ARG(items);
14989     if (!sv) {
14990         XSRETURN(0);
14991     }
14992     EXTEND(sp, 1);
14993     ST(0) = sv;
14994     XSRETURN(1);
14995 }
14996
14997 static void
14998 const_av_xsub(pTHX_ CV* cv)
14999 {
15000     dXSARGS;
15001     AV * const av = MUTABLE_AV(XSANY.any_ptr);
15002     SP -= items;
15003     assert(av);
15004 #ifndef DEBUGGING
15005     if (!av) {
15006         XSRETURN(0);
15007     }
15008 #endif
15009     if (SvRMAGICAL(av))
15010         Perl_croak(aTHX_ "Magical list constants are not supported");
15011     if (GIMME_V != G_ARRAY) {
15012         EXTEND(SP, 1);
15013         ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
15014         XSRETURN(1);
15015     }
15016     EXTEND(SP, AvFILLp(av)+1);
15017     Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
15018     XSRETURN(AvFILLp(av)+1);
15019 }
15020
15021 /*
15022  * ex: set ts=8 sts=4 sw=4 et:
15023  */