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         if (PL_op == o)
 857             PL_op = NULL;
 858     } while ( (o = POP_DEFERRED_OP()) );
 859
 860     Safefree(defer_stack);
 861 }
 862
 863 /* S_op_clear_gv(): free a GV attached to an OP */
 864
 865 STATIC
 866 #ifdef USE_ITHREADS
 867 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
 868 #else
 869 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
 870 #endif
 871 {
 872
 873     GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
 874             || o->op_type == OP_MULTIDEREF)
 875 #ifdef USE_ITHREADS
 876                 && PL_curpad
 877                 ? ((GV*)PAD_SVl(*ixp)) : NULL;
 878 #else
 879                 ? (GV*)(*svp) : NULL;
 880 #endif
 881     /* It's possible during global destruction that the GV is freed
 882        before the optree. Whilst the SvREFCNT_inc is happy to bump from
 883        0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
 884        will trigger an assertion failure, because the entry to sv_clear
 885        checks that the scalar is not already freed.  A check of for
 886        !SvIS_FREED(gv) turns out to be invalid, because during global
 887        destruction the reference count can be forced down to zero
 888        (with SVf_BREAK set).  In which case raising to 1 and then
 889        dropping to 0 triggers cleanup before it should happen.  I
 890        *think* that this might actually be a general, systematic,
 891        weakness of the whole idea of SVf_BREAK, in that code *is*
 892        allowed to raise and lower references during global destruction,
 893        so any *valid* code that happens to do this during global
 894        destruction might well trigger premature cleanup.  */
 895     bool still_valid = gv && SvREFCNT(gv);
 896
 897     if (still_valid)
 898         SvREFCNT_inc_simple_void(gv);
 899 #ifdef USE_ITHREADS
 900     if (*ixp > 0) {
 901         pad_swipe(*ixp, TRUE);
 902         *ixp = 0;
 903     }
 904 #else
 905     SvREFCNT_dec(*svp);
 906     *svp = NULL;
 907 #endif
 908     if (still_valid) {
 909         int try_downgrade = SvREFCNT(gv) == 2;
 910         SvREFCNT_dec_NN(gv);
 911         if (try_downgrade)
 912             gv_try_downgrade(gv);
 913     }
 914 }
 915
 916
 917 void
 918 Perl_op_clear(pTHX_ OP *o)
 919 {
 920
 921     dVAR;
 922
 923     PERL_ARGS_ASSERT_OP_CLEAR;
 924
 925     switch (o->op_type) {
 926     case OP_NULL:       /* Was holding old type, if any. */
 927         /* FALLTHROUGH */
 928     case OP_ENTERTRY:
 929     case OP_ENTEREVAL:  /* Was holding hints. */
 930     case OP_ARGDEFELEM: /* Was holding signature index. */
 931         o->op_targ = 0;
 932         break;
 933     default:
 934         if (!(o->op_flags & OPf_REF)
 935             || (PL_check[o->op_type] != Perl_ck_ftst))
 936             break;
 937         /* FALLTHROUGH */
 938     case OP_GVSV:
 939     case OP_GV:
 940     case OP_AELEMFAST:
 941 #ifdef USE_ITHREADS
 942             S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
 943 #else
 944             S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
 945 #endif
 946         break;
 947     case OP_METHOD_REDIR:
 948     case OP_METHOD_REDIR_SUPER:
 949 #ifdef USE_ITHREADS
 950         if (cMETHOPx(o)->op_rclass_targ) {
 951             pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
 952             cMETHOPx(o)->op_rclass_targ = 0;
 953         }
 954 #else
 955         SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
 956         cMETHOPx(o)->op_rclass_sv = NULL;
 957 #endif
 958     case OP_METHOD_NAMED:
 959     case OP_METHOD_SUPER:
 960         SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
 961         cMETHOPx(o)->op_u.op_meth_sv = NULL;
 962 #ifdef USE_ITHREADS
 963         if (o->op_targ) {
 964             pad_swipe(o->op_targ, 1);
 965             o->op_targ = 0;
 966         }
 967 #endif
 968         break;
 969     case OP_CONST:
 970     case OP_HINTSEVAL:
 971         SvREFCNT_dec(cSVOPo->op_sv);
 972         cSVOPo->op_sv = NULL;
 973 #ifdef USE_ITHREADS
 974         /** Bug #15654
 975           Even if op_clear does a pad_free for the target of the op,
 976           pad_free doesn't actually remove the sv that exists in the pad;
 977           instead it lives on. This results in that it could be reused as
 978           a target later on when the pad was reallocated.
 979         **/
 980         if(o->op_targ) {
 981           pad_swipe(o->op_targ,1);
 982           o->op_targ = 0;
 983         }
 984 #endif
 985         break;
 986     case OP_DUMP:
 987     case OP_GOTO:
 988     case OP_NEXT:
 989     case OP_LAST:
 990     case OP_REDO:
 991         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
 992             break;
 993         /* FALLTHROUGH */
 994     case OP_TRANS:
 995     case OP_TRANSR:
 996         if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
 997             assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
 998 #ifdef USE_ITHREADS
 999             if (cPADOPo->op_padix > 0) {
1000                 pad_swipe(cPADOPo->op_padix, TRUE);
1001                 cPADOPo->op_padix = 0;
1002             }
1003 #else
1004             SvREFCNT_dec(cSVOPo->op_sv);
1005             cSVOPo->op_sv = NULL;
1006 #endif
1007         }
1008         else {
1009             PerlMemShared_free(cPVOPo->op_pv);
1010             cPVOPo->op_pv = NULL;
1011         }
1012         break;
1013     case OP_SUBST:
1014         op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
1015         goto clear_pmop;
1016
1017     case OP_SPLIT:
1018         if (     (o->op_private & OPpSPLIT_ASSIGN) /* @array  = split */
1019             && !(o->op_flags & OPf_STACKED))       /* @{expr} = split */
1020         {
1021             if (o->op_private & OPpSPLIT_LEX)
1022                 pad_free(cPMOPo->op_pmreplrootu.op_pmtargetoff);
1023             else
1024 #ifdef USE_ITHREADS
1025                 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
1026 #else
1027                 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
1028 #endif
1029         }
1030         /* FALLTHROUGH */
1031     case OP_MATCH:
1032     case OP_QR:
1033     clear_pmop:
1034         if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
1035             op_free(cPMOPo->op_code_list);
1036         cPMOPo->op_code_list = NULL;
1037         forget_pmop(cPMOPo);
1038         cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
1039         /* we use the same protection as the "SAFE" version of the PM_ macros
1040          * here since sv_clean_all might release some PMOPs
1041          * after PL_regex_padav has been cleared
1042          * and the clearing of PL_regex_padav needs to
1043          * happen before sv_clean_all
1044          */
1045 #ifdef USE_ITHREADS
1046         if(PL_regex_pad) {        /* We could be in destruction */
1047             const IV offset = (cPMOPo)->op_pmoffset;
1048             ReREFCNT_dec(PM_GETRE(cPMOPo));
1049             PL_regex_pad[offset] = &PL_sv_undef;
1050             sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
1051                            sizeof(offset));
1052         }
1053 #else
1054         ReREFCNT_dec(PM_GETRE(cPMOPo));
1055         PM_SETRE(cPMOPo, NULL);
1056 #endif
1057
1058         break;
1059
1060     case OP_ARGCHECK:
1061         PerlMemShared_free(cUNOP_AUXo->op_aux);
1062         break;
1063
1064     case OP_MULTIDEREF:
1065         {
1066             UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1067             UV actions = items->uv;
1068             bool last = 0;
1069             bool is_hash = FALSE;
1070
1071             while (!last) {
1072                 switch (actions & MDEREF_ACTION_MASK) {
1073
1074                 case MDEREF_reload:
1075                     actions = (++items)->uv;
1076                     continue;
1077
1078                 case MDEREF_HV_padhv_helem:
1079                     is_hash = TRUE;
1080                 case MDEREF_AV_padav_aelem:
1081                     pad_free((++items)->pad_offset);
1082                     goto do_elem;
1083
1084                 case MDEREF_HV_gvhv_helem:
1085                     is_hash = TRUE;
1086                 case MDEREF_AV_gvav_aelem:
1087 #ifdef USE_ITHREADS
1088                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1089 #else
1090                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1091 #endif
1092                     goto do_elem;
1093
1094                 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1095                     is_hash = TRUE;
1096                 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1097 #ifdef USE_ITHREADS
1098                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1099 #else
1100                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1101 #endif
1102                     goto do_vivify_rv2xv_elem;
1103
1104                 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1105                     is_hash = TRUE;
1106                 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1107                     pad_free((++items)->pad_offset);
1108                     goto do_vivify_rv2xv_elem;
1109
1110                 case MDEREF_HV_pop_rv2hv_helem:
1111                 case MDEREF_HV_vivify_rv2hv_helem:
1112                     is_hash = TRUE;
1113                 do_vivify_rv2xv_elem:
1114                 case MDEREF_AV_pop_rv2av_aelem:
1115                 case MDEREF_AV_vivify_rv2av_aelem:
1116                 do_elem:
1117                     switch (actions & MDEREF_INDEX_MASK) {
1118                     case MDEREF_INDEX_none:
1119                         last = 1;
1120                         break;
1121                     case MDEREF_INDEX_const:
1122                         if (is_hash) {
1123 #ifdef USE_ITHREADS
1124                             /* see RT #15654 */
1125                             pad_swipe((++items)->pad_offset, 1);
1126 #else
1127                             SvREFCNT_dec((++items)->sv);
1128 #endif
1129                         }
1130                         else
1131                             items++;
1132                         break;
1133                     case MDEREF_INDEX_padsv:
1134                         pad_free((++items)->pad_offset);
1135                         break;
1136                     case MDEREF_INDEX_gvsv:
1137 #ifdef USE_ITHREADS
1138                         S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1139 #else
1140                         S_op_clear_gv(aTHX_ o, &((++items)->sv));
1141 #endif
1142                         break;
1143                     }
1144
1145                     if (actions & MDEREF_FLAG_last)
1146                         last = 1;
1147                     is_hash = FALSE;
1148
1149                     break;
1150
1151                 default:
1152                     assert(0);
1153                     last = 1;
1154                     break;
1155
1156                 } /* switch */
1157
1158                 actions >>= MDEREF_SHIFT;
1159             } /* while */
1160
1161             /* start of malloc is at op_aux[-1], where the length is
1162              * stored */
1163             PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1164         }
1165         break;
1166     }
1167
1168     if (o->op_targ > 0) {
1169         pad_free(o->op_targ);
1170         o->op_targ = 0;
1171     }
1172 }
1173
1174 STATIC void
1175 S_cop_free(pTHX_ COP* cop)
1176 {
1177     PERL_ARGS_ASSERT_COP_FREE;
1178
1179     CopFILE_free(cop);
1180     if (! specialWARN(cop->cop_warnings))
1181         PerlMemShared_free(cop->cop_warnings);
1182     cophh_free(CopHINTHASH_get(cop));
1183     if (PL_curcop == cop)
1184        PL_curcop = NULL;
1185 }
1186
1187 STATIC void
1188 S_forget_pmop(pTHX_ PMOP *const o
1189               )
1190 {
1191     HV * const pmstash = PmopSTASH(o);
1192
1193     PERL_ARGS_ASSERT_FORGET_PMOP;
1194
1195     if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1196         MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1197         if (mg) {
1198             PMOP **const array = (PMOP**) mg->mg_ptr;
1199             U32 count = mg->mg_len / sizeof(PMOP**);
1200             U32 i = count;
1201
1202             while (i--) {
1203                 if (array[i] == o) {
1204                     /* Found it. Move the entry at the end to overwrite it.  */
1205                     array[i] = array[--count];
1206                     mg->mg_len = count * sizeof(PMOP**);
1207                     /* Could realloc smaller at this point always, but probably
1208                        not worth it. Probably worth free()ing if we're the
1209                        last.  */
1210                     if(!count) {
1211                         Safefree(mg->mg_ptr);
1212                         mg->mg_ptr = NULL;
1213                     }
1214                     break;
1215                 }
1216             }
1217         }
1218     }
1219     if (PL_curpm == o)
1220         PL_curpm = NULL;
1221 }
1222
1223 STATIC void
1224 S_find_and_forget_pmops(pTHX_ OP *o)
1225 {
1226     PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1227
1228     if (o->op_flags & OPf_KIDS) {
1229         OP *kid = cUNOPo->op_first;
1230         while (kid) {
1231             switch (kid->op_type) {
1232             case OP_SUBST:
1233             case OP_SPLIT:
1234             case OP_MATCH:
1235             case OP_QR:
1236                 forget_pmop((PMOP*)kid);
1237             }
1238             find_and_forget_pmops(kid);
1239             kid = OpSIBLING(kid);
1240         }
1241     }
1242 }
1243
1244 /*
1245 =for apidoc Am|void|op_null|OP *o
1246
1247 Neutralizes an op when it is no longer needed, but is still linked to from
1248 other ops.
1249
1250 =cut
1251 */
1252
1253 void
1254 Perl_op_null(pTHX_ OP *o)
1255 {
1256     dVAR;
1257
1258     PERL_ARGS_ASSERT_OP_NULL;
1259
1260     if (o->op_type == OP_NULL)
1261         return;
1262     op_clear(o);
1263     o->op_targ = o->op_type;
1264     OpTYPE_set(o, OP_NULL);
1265 }
1266
1267 void
1268 Perl_op_refcnt_lock(pTHX)
1269   PERL_TSA_ACQUIRE(PL_op_mutex)
1270 {
1271 #ifdef USE_ITHREADS
1272     dVAR;
1273 #endif
1274     PERL_UNUSED_CONTEXT;
1275     OP_REFCNT_LOCK;
1276 }
1277
1278 void
1279 Perl_op_refcnt_unlock(pTHX)
1280   PERL_TSA_RELEASE(PL_op_mutex)
1281 {
1282 #ifdef USE_ITHREADS
1283     dVAR;
1284 #endif
1285     PERL_UNUSED_CONTEXT;
1286     OP_REFCNT_UNLOCK;
1287 }
1288
1289
1290 /*
1291 =for apidoc op_sibling_splice
1292
1293 A general function for editing the structure of an existing chain of
1294 op_sibling nodes.  By analogy with the perl-level C<splice()> function, allows
1295 you to delete zero or more sequential nodes, replacing them with zero or
1296 more different nodes.  Performs the necessary op_first/op_last
1297 housekeeping on the parent node and op_sibling manipulation on the
1298 children.  The last deleted node will be marked as as the last node by
1299 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1300
1301 Note that op_next is not manipulated, and nodes are not freed; that is the
1302 responsibility of the caller.  It also won't create a new list op for an
1303 empty list etc; use higher-level functions like op_append_elem() for that.
1304
1305 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1306 the splicing doesn't affect the first or last op in the chain.
1307
1308 C<start> is the node preceding the first node to be spliced.  Node(s)
1309 following it will be deleted, and ops will be inserted after it.  If it is
1310 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1311 beginning.
1312
1313 C<del_count> is the number of nodes to delete.  If zero, no nodes are deleted.
1314 If -1 or greater than or equal to the number of remaining kids, all
1315 remaining kids are deleted.
1316
1317 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1318 If C<NULL>, no nodes are inserted.
1319
1320 The head of the chain of deleted ops is returned, or C<NULL> if no ops were
1321 deleted.
1322
1323 For example:
1324
1325     action                    before      after         returns
1326     ------                    -----       -----         -------
1327
1328                               P           P
1329     splice(P, A, 2, X-Y-Z)    |           |             B-C
1330                               A-B-C-D     A-X-Y-Z-D
1331
1332                               P           P
1333     splice(P, NULL, 1, X-Y)   |           |             A
1334                               A-B-C-D     X-Y-B-C-D
1335
1336                               P           P
1337     splice(P, NULL, 3, NULL)  |           |             A-B-C
1338                               A-B-C-D     D
1339
1340                               P           P
1341     splice(P, B, 0, X-Y)      |           |             NULL
1342                               A-B-C-D     A-B-X-Y-C-D
1343
1344
1345 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1346 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
1347
1348 =cut
1349 */
1350
1351 OP *
1352 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1353 {
1354     OP *first;
1355     OP *rest;
1356     OP *last_del = NULL;
1357     OP *last_ins = NULL;
1358
1359     if (start)
1360         first = OpSIBLING(start);
1361     else if (!parent)
1362         goto no_parent;
1363     else
1364         first = cLISTOPx(parent)->op_first;
1365
1366     assert(del_count >= -1);
1367
1368     if (del_count && first) {
1369         last_del = first;
1370         while (--del_count && OpHAS_SIBLING(last_del))
1371             last_del = OpSIBLING(last_del);
1372         rest = OpSIBLING(last_del);
1373         OpLASTSIB_set(last_del, NULL);
1374     }
1375     else
1376         rest = first;
1377
1378     if (insert) {
1379         last_ins = insert;
1380         while (OpHAS_SIBLING(last_ins))
1381             last_ins = OpSIBLING(last_ins);
1382         OpMAYBESIB_set(last_ins, rest, NULL);
1383     }
1384     else
1385         insert = rest;
1386
1387     if (start) {
1388         OpMAYBESIB_set(start, insert, NULL);
1389     }
1390     else {
1391         if (!parent)
1392             goto no_parent;
1393         cLISTOPx(parent)->op_first = insert;
1394         if (insert)
1395             parent->op_flags |= OPf_KIDS;
1396         else
1397             parent->op_flags &= ~OPf_KIDS;
1398     }
1399
1400     if (!rest) {
1401         /* update op_last etc */
1402         U32 type;
1403         OP *lastop;
1404
1405         if (!parent)
1406             goto no_parent;
1407
1408         /* ought to use OP_CLASS(parent) here, but that can't handle
1409          * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1410          * either */
1411         type = parent->op_type;
1412         if (type == OP_CUSTOM) {
1413             dTHX;
1414             type = XopENTRYCUSTOM(parent, xop_class);
1415         }
1416         else {
1417             if (type == OP_NULL)
1418                 type = parent->op_targ;
1419             type = PL_opargs[type] & OA_CLASS_MASK;
1420         }
1421
1422         lastop = last_ins ? last_ins : start ? start : NULL;
1423         if (   type == OA_BINOP
1424             || type == OA_LISTOP
1425             || type == OA_PMOP
1426             || type == OA_LOOP
1427         )
1428             cLISTOPx(parent)->op_last = lastop;
1429
1430         if (lastop)
1431             OpLASTSIB_set(lastop, parent);
1432     }
1433     return last_del ? first : NULL;
1434
1435   no_parent:
1436     Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1437 }
1438
1439
1440 #ifdef PERL_OP_PARENT
1441
1442 /*
1443 =for apidoc op_parent
1444
1445 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1446 This function is only available on perls built with C<-DPERL_OP_PARENT>.
1447
1448 =cut
1449 */
1450
1451 OP *
1452 Perl_op_parent(OP *o)
1453 {
1454     PERL_ARGS_ASSERT_OP_PARENT;
1455     while (OpHAS_SIBLING(o))
1456         o = OpSIBLING(o);
1457     return o->op_sibparent;
1458 }
1459
1460 #endif
1461
1462
1463 /* replace the sibling following start with a new UNOP, which becomes
1464  * the parent of the original sibling; e.g.
1465  *
1466  *  op_sibling_newUNOP(P, A, unop-args...)
1467  *
1468  *  P              P
1469  *  |      becomes |
1470  *  A-B-C          A-U-C
1471  *                   |
1472  *                   B
1473  *
1474  * where U is the new UNOP.
1475  *
1476  * parent and start args are the same as for op_sibling_splice();
1477  * type and flags args are as newUNOP().
1478  *
1479  * Returns the new UNOP.
1480  */
1481
1482 STATIC OP *
1483 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1484 {
1485     OP *kid, *newop;
1486
1487     kid = op_sibling_splice(parent, start, 1, NULL);
1488     newop = newUNOP(type, flags, kid);
1489     op_sibling_splice(parent, start, 0, newop);
1490     return newop;
1491 }
1492
1493
1494 /* lowest-level newLOGOP-style function - just allocates and populates
1495  * the struct. Higher-level stuff should be done by S_new_logop() /
1496  * newLOGOP(). This function exists mainly to avoid op_first assignment
1497  * being spread throughout this file.
1498  */
1499
1500 LOGOP *
1501 Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1502 {
1503     dVAR;
1504     LOGOP *logop;
1505     OP *kid = first;
1506     NewOp(1101, logop, 1, LOGOP);
1507     OpTYPE_set(logop, type);
1508     logop->op_first = first;
1509     logop->op_other = other;
1510     logop->op_flags = OPf_KIDS;
1511     while (kid && OpHAS_SIBLING(kid))
1512         kid = OpSIBLING(kid);
1513     if (kid)
1514         OpLASTSIB_set(kid, (OP*)logop);
1515     return logop;
1516 }
1517
1518
1519 /* Contextualizers */
1520
1521 /*
1522 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1523
1524 Applies a syntactic context to an op tree representing an expression.
1525 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
1526 or C<G_VOID> to specify the context to apply.  The modified op tree
1527 is returned.
1528
1529 =cut
1530 */
1531
1532 OP *
1533 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1534 {
1535     PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1536     switch (context) {
1537         case G_SCALAR: return scalar(o);
1538         case G_ARRAY:  return list(o);
1539         case G_VOID:   return scalarvoid(o);
1540         default:
1541             Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1542                        (long) context);
1543     }
1544 }
1545
1546 /*
1547
1548 =for apidoc Am|OP*|op_linklist|OP *o
1549 This function is the implementation of the L</LINKLIST> macro.  It should
1550 not be called directly.
1551
1552 =cut
1553 */
1554
1555 OP *
1556 Perl_op_linklist(pTHX_ OP *o)
1557 {
1558     OP *first;
1559
1560     PERL_ARGS_ASSERT_OP_LINKLIST;
1561
1562     if (o->op_next)
1563         return o->op_next;
1564
1565     /* establish postfix order */
1566     first = cUNOPo->op_first;
1567     if (first) {
1568         OP *kid;
1569         o->op_next = LINKLIST(first);
1570         kid = first;
1571         for (;;) {
1572             OP *sibl = OpSIBLING(kid);
1573             if (sibl) {
1574                 kid->op_next = LINKLIST(sibl);
1575                 kid = sibl;
1576             } else {
1577                 kid->op_next = o;
1578                 break;
1579             }
1580         }
1581     }
1582     else
1583         o->op_next = o;
1584
1585     return o->op_next;
1586 }
1587
1588 static OP *
1589 S_scalarkids(pTHX_ OP *o)
1590 {
1591     if (o && o->op_flags & OPf_KIDS) {
1592         OP *kid;
1593         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1594             scalar(kid);
1595     }
1596     return o;
1597 }
1598
1599 STATIC OP *
1600 S_scalarboolean(pTHX_ OP *o)
1601 {
1602     PERL_ARGS_ASSERT_SCALARBOOLEAN;
1603
1604     if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1605          !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1606         (o->op_type == OP_NOT     && cUNOPo->op_first->op_type == OP_SASSIGN &&
1607          cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1608          !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
1609         if (ckWARN(WARN_SYNTAX)) {
1610             const line_t oldline = CopLINE(PL_curcop);
1611
1612             if (PL_parser && PL_parser->copline != NOLINE) {
1613                 /* This ensures that warnings are reported at the first line
1614                    of the conditional, not the last.  */
1615                 CopLINE_set(PL_curcop, PL_parser->copline);
1616             }
1617             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1618             CopLINE_set(PL_curcop, oldline);
1619         }
1620     }
1621     return scalar(o);
1622 }
1623
1624 static SV *
1625 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1626 {
1627     assert(o);
1628     assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1629            o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1630     {
1631         const char funny  = o->op_type == OP_PADAV
1632                          || o->op_type == OP_RV2AV ? '@' : '%';
1633         if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1634             GV *gv;
1635             if (cUNOPo->op_first->op_type != OP_GV
1636              || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1637                 return NULL;
1638             return varname(gv, funny, 0, NULL, 0, subscript_type);
1639         }
1640         return
1641             varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1642     }
1643 }
1644
1645 static SV *
1646 S_op_varname(pTHX_ const OP *o)
1647 {
1648     return S_op_varname_subscript(aTHX_ o, 1);
1649 }
1650
1651 static void
1652 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1653 { /* or not so pretty :-) */
1654     if (o->op_type == OP_CONST) {
1655         *retsv = cSVOPo_sv;
1656         if (SvPOK(*retsv)) {
1657             SV *sv = *retsv;
1658             *retsv = sv_newmortal();
1659             pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1660                       PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1661         }
1662         else if (!SvOK(*retsv))
1663             *retpv = "undef";
1664     }
1665     else *retpv = "...";
1666 }
1667
1668 static void
1669 S_scalar_slice_warning(pTHX_ const OP *o)
1670 {
1671     OP *kid;
1672     const char lbrack =
1673         o->op_type == OP_HSLICE ? '{' : '[';
1674     const char rbrack =
1675         o->op_type == OP_HSLICE ? '}' : ']';
1676     SV *name;
1677     SV *keysv = NULL; /* just to silence compiler warnings */
1678     const char *key = NULL;
1679
1680     if (!(o->op_private & OPpSLICEWARNING))
1681         return;
1682     if (PL_parser && PL_parser->error_count)
1683         /* This warning can be nonsensical when there is a syntax error. */
1684         return;
1685
1686     kid = cLISTOPo->op_first;
1687     kid = OpSIBLING(kid); /* get past pushmark */
1688     /* weed out false positives: any ops that can return lists */
1689     switch (kid->op_type) {
1690     case OP_BACKTICK:
1691     case OP_GLOB:
1692     case OP_READLINE:
1693     case OP_MATCH:
1694     case OP_RV2AV:
1695     case OP_EACH:
1696     case OP_VALUES:
1697     case OP_KEYS:
1698     case OP_SPLIT:
1699     case OP_LIST:
1700     case OP_SORT:
1701     case OP_REVERSE:
1702     case OP_ENTERSUB:
1703     case OP_CALLER:
1704     case OP_LSTAT:
1705     case OP_STAT:
1706     case OP_READDIR:
1707     case OP_SYSTEM:
1708     case OP_TMS:
1709     case OP_LOCALTIME:
1710     case OP_GMTIME:
1711     case OP_ENTEREVAL:
1712         return;
1713     }
1714
1715     /* Don't warn if we have a nulled list either. */
1716     if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1717         return;
1718
1719     assert(OpSIBLING(kid));
1720     name = S_op_varname(aTHX_ OpSIBLING(kid));
1721     if (!name) /* XS module fiddling with the op tree */
1722         return;
1723     S_op_pretty(aTHX_ kid, &keysv, &key);
1724     assert(SvPOK(name));
1725     sv_chop(name,SvPVX(name)+1);
1726     if (key)
1727        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1728         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1729                    "Scalar value @%" SVf "%c%s%c better written as $%" SVf
1730                    "%c%s%c",
1731                     SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1732                     lbrack, key, rbrack);
1733     else
1734        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1735         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1736                    "Scalar value @%" SVf "%c%" SVf "%c better written as $%"
1737                     SVf "%c%" SVf "%c",
1738                     SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1739                     SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1740 }
1741
1742 OP *
1743 Perl_scalar(pTHX_ OP *o)
1744 {
1745     OP *kid;
1746
1747     /* assumes no premature commitment */
1748     if (!o || (PL_parser && PL_parser->error_count)
1749          || (o->op_flags & OPf_WANT)
1750          || o->op_type == OP_RETURN)
1751     {
1752         return o;
1753     }
1754
1755     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1756
1757     switch (o->op_type) {
1758     case OP_REPEAT:
1759         scalar(cBINOPo->op_first);
1760         if (o->op_private & OPpREPEAT_DOLIST) {
1761             kid = cLISTOPx(cUNOPo->op_first)->op_first;
1762             assert(kid->op_type == OP_PUSHMARK);
1763             if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1764                 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1765                 o->op_private &=~ OPpREPEAT_DOLIST;
1766             }
1767         }
1768         break;
1769     case OP_OR:
1770     case OP_AND:
1771     case OP_COND_EXPR:
1772         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
1773             scalar(kid);
1774         break;
1775         /* FALLTHROUGH */
1776     case OP_SPLIT:
1777     case OP_MATCH:
1778     case OP_QR:
1779     case OP_SUBST:
1780     case OP_NULL:
1781     default:
1782         if (o->op_flags & OPf_KIDS) {
1783             for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1784                 scalar(kid);
1785         }
1786         break;
1787     case OP_LEAVE:
1788     case OP_LEAVETRY:
1789         kid = cLISTOPo->op_first;
1790         scalar(kid);
1791         kid = OpSIBLING(kid);
1792     do_kids:
1793         while (kid) {
1794             OP *sib = OpSIBLING(kid);
1795             if (sib && kid->op_type != OP_LEAVEWHEN
1796              && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
1797                 || (  sib->op_targ != OP_NEXTSTATE
1798                    && sib->op_targ != OP_DBSTATE  )))
1799                 scalarvoid(kid);
1800             else
1801                 scalar(kid);
1802             kid = sib;
1803         }
1804         PL_curcop = &PL_compiling;
1805         break;
1806     case OP_SCOPE:
1807     case OP_LINESEQ:
1808     case OP_LIST:
1809         kid = cLISTOPo->op_first;
1810         goto do_kids;
1811     case OP_SORT:
1812         Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1813         break;
1814     case OP_KVHSLICE:
1815     case OP_KVASLICE:
1816     {
1817         /* Warn about scalar context */
1818         const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1819         const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1820         SV *name;
1821         SV *keysv;
1822         const char *key = NULL;
1823
1824         /* This warning can be nonsensical when there is a syntax error. */
1825         if (PL_parser && PL_parser->error_count)
1826             break;
1827
1828         if (!ckWARN(WARN_SYNTAX)) break;
1829
1830         kid = cLISTOPo->op_first;
1831         kid = OpSIBLING(kid); /* get past pushmark */
1832         assert(OpSIBLING(kid));
1833         name = S_op_varname(aTHX_ OpSIBLING(kid));
1834         if (!name) /* XS module fiddling with the op tree */
1835             break;
1836         S_op_pretty(aTHX_ kid, &keysv, &key);
1837         assert(SvPOK(name));
1838         sv_chop(name,SvPVX(name)+1);
1839         if (key)
1840   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1841             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1842                        "%%%" SVf "%c%s%c in scalar context better written "
1843                        "as $%" SVf "%c%s%c",
1844                         SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1845                         lbrack, key, rbrack);
1846         else
1847   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1848             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1849                        "%%%" SVf "%c%" SVf "%c in scalar context better "
1850                        "written as $%" SVf "%c%" SVf "%c",
1851                         SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1852                         SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1853     }
1854     }
1855     return o;
1856 }
1857
1858 OP *
1859 Perl_scalarvoid(pTHX_ OP *arg)
1860 {
1861     dVAR;
1862     OP *kid;
1863     SV* sv;
1864     U8 want;
1865     SSize_t defer_stack_alloc = 0;
1866     SSize_t defer_ix = -1;
1867     OP **defer_stack = NULL;
1868     OP *o = arg;
1869
1870     PERL_ARGS_ASSERT_SCALARVOID;
1871
1872     do {
1873         SV *useless_sv = NULL;
1874         const char* useless = NULL;
1875
1876         if (o->op_type == OP_NEXTSTATE
1877             || o->op_type == OP_DBSTATE
1878             || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1879                                           || o->op_targ == OP_DBSTATE)))
1880             PL_curcop = (COP*)o;                /* for warning below */
1881
1882         /* assumes no premature commitment */
1883         want = o->op_flags & OPf_WANT;
1884         if ((want && want != OPf_WANT_SCALAR)
1885             || (PL_parser && PL_parser->error_count)
1886             || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1887         {
1888             continue;
1889         }
1890
1891         if ((o->op_private & OPpTARGET_MY)
1892             && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1893         {
1894             /* newASSIGNOP has already applied scalar context, which we
1895                leave, as if this op is inside SASSIGN.  */
1896             continue;
1897         }
1898
1899         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1900
1901         switch (o->op_type) {
1902         default:
1903             if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1904                 break;
1905             /* FALLTHROUGH */
1906         case OP_REPEAT:
1907             if (o->op_flags & OPf_STACKED)
1908                 break;
1909             if (o->op_type == OP_REPEAT)
1910                 scalar(cBINOPo->op_first);
1911             goto func_ops;
1912         case OP_SUBSTR:
1913             if (o->op_private == 4)
1914                 break;
1915             /* FALLTHROUGH */
1916         case OP_WANTARRAY:
1917         case OP_GV:
1918         case OP_SMARTMATCH:
1919         case OP_AV2ARYLEN:
1920         case OP_REF:
1921         case OP_REFGEN:
1922         case OP_SREFGEN:
1923         case OP_DEFINED:
1924         case OP_HEX:
1925         case OP_OCT:
1926         case OP_LENGTH:
1927         case OP_VEC:
1928         case OP_INDEX:
1929         case OP_RINDEX:
1930         case OP_SPRINTF:
1931         case OP_KVASLICE:
1932         case OP_KVHSLICE:
1933         case OP_UNPACK:
1934         case OP_PACK:
1935         case OP_JOIN:
1936         case OP_LSLICE:
1937         case OP_ANONLIST:
1938         case OP_ANONHASH:
1939         case OP_SORT:
1940         case OP_REVERSE:
1941         case OP_RANGE:
1942         case OP_FLIP:
1943         case OP_FLOP:
1944         case OP_CALLER:
1945         case OP_FILENO:
1946         case OP_EOF:
1947         case OP_TELL:
1948         case OP_GETSOCKNAME:
1949         case OP_GETPEERNAME:
1950         case OP_READLINK:
1951         case OP_TELLDIR:
1952         case OP_GETPPID:
1953         case OP_GETPGRP:
1954         case OP_GETPRIORITY:
1955         case OP_TIME:
1956         case OP_TMS:
1957         case OP_LOCALTIME:
1958         case OP_GMTIME:
1959         case OP_GHBYNAME:
1960         case OP_GHBYADDR:
1961         case OP_GHOSTENT:
1962         case OP_GNBYNAME:
1963         case OP_GNBYADDR:
1964         case OP_GNETENT:
1965         case OP_GPBYNAME:
1966         case OP_GPBYNUMBER:
1967         case OP_GPROTOENT:
1968         case OP_GSBYNAME:
1969         case OP_GSBYPORT:
1970         case OP_GSERVENT:
1971         case OP_GPWNAM:
1972         case OP_GPWUID:
1973         case OP_GGRNAM:
1974         case OP_GGRGID:
1975         case OP_GETLOGIN:
1976         case OP_PROTOTYPE:
1977         case OP_RUNCV:
1978         func_ops:
1979             useless = OP_DESC(o);
1980             break;
1981
1982         case OP_GVSV:
1983         case OP_PADSV:
1984         case OP_PADAV:
1985         case OP_PADHV:
1986         case OP_PADANY:
1987         case OP_AELEM:
1988         case OP_AELEMFAST:
1989         case OP_AELEMFAST_LEX:
1990         case OP_ASLICE:
1991         case OP_HELEM:
1992         case OP_HSLICE:
1993             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1994                 /* Otherwise it's "Useless use of grep iterator" */
1995                 useless = OP_DESC(o);
1996             break;
1997
1998         case OP_SPLIT:
1999             if (!(o->op_private & OPpSPLIT_ASSIGN))
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     assert(o->op_type != OP_FREED);
2500
2501     switch (o->op_type) {
2502     case OP_NEXTSTATE:
2503     case OP_DBSTATE:
2504         PL_curcop = ((COP*)o);          /* for warnings */
2505         break;
2506     case OP_EXEC:
2507         if (OpHAS_SIBLING(o)) {
2508             OP *sib = OpSIBLING(o);
2509             if ((  sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
2510                 && ckWARN(WARN_EXEC)
2511                 && OpHAS_SIBLING(sib))
2512             {
2513                     const OPCODE type = OpSIBLING(sib)->op_type;
2514                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
2515                         const line_t oldline = CopLINE(PL_curcop);
2516                         CopLINE_set(PL_curcop, CopLINE((COP*)sib));
2517                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
2518                             "Statement unlikely to be reached");
2519                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
2520                             "\t(Maybe you meant system() when you said exec()?)\n");
2521                         CopLINE_set(PL_curcop, oldline);
2522                     }
2523             }
2524         }
2525         break;
2526
2527     case OP_GV:
2528         if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
2529             GV * const gv = cGVOPo_gv;
2530             if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
2531                 /* XXX could check prototype here instead of just carping */
2532                 SV * const sv = sv_newmortal();
2533                 gv_efullname3(sv, gv, NULL);
2534                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
2535                     "%" SVf "() called too early to check prototype",
2536                     SVfARG(sv));
2537             }
2538         }
2539         break;
2540
2541     case OP_CONST:
2542         if (cSVOPo->op_private & OPpCONST_STRICT)
2543             no_bareword_allowed(o);
2544         /* FALLTHROUGH */
2545 #ifdef USE_ITHREADS
2546     case OP_HINTSEVAL:
2547         op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
2548 #endif
2549         break;
2550
2551 #ifdef USE_ITHREADS
2552     /* Relocate all the METHOP's SVs to the pad for thread safety. */
2553     case OP_METHOD_NAMED:
2554     case OP_METHOD_SUPER:
2555     case OP_METHOD_REDIR:
2556     case OP_METHOD_REDIR_SUPER:
2557         op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
2558         break;
2559 #endif
2560
2561     case OP_HELEM: {
2562         UNOP *rop;
2563         SVOP *key_op;
2564         OP *kid;
2565
2566         if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
2567             break;
2568
2569         rop = (UNOP*)((BINOP*)o)->op_first;
2570
2571         goto check_keys;
2572
2573     case OP_HSLICE:
2574         S_scalar_slice_warning(aTHX_ o);
2575         /* FALLTHROUGH */
2576
2577     case OP_KVHSLICE:
2578         kid = OpSIBLING(cLISTOPo->op_first);
2579         if (/* I bet there's always a pushmark... */
2580             OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
2581             && OP_TYPE_ISNT_NN(kid, OP_CONST))
2582         {
2583             break;
2584         }
2585
2586         key_op = (SVOP*)(kid->op_type == OP_CONST
2587                                 ? kid
2588                                 : OpSIBLING(kLISTOP->op_first));
2589
2590         rop = (UNOP*)((LISTOP*)o)->op_last;
2591
2592       check_keys:
2593         if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
2594             rop = NULL;
2595         S_check_hash_fields_and_hekify(aTHX_ rop, key_op);
2596         break;
2597     }
2598     case OP_ASLICE:
2599         S_scalar_slice_warning(aTHX_ o);
2600         break;
2601
2602     case OP_SUBST: {
2603         if (cPMOPo->op_pmreplrootu.op_pmreplroot)
2604             finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
2605         break;
2606     }
2607     default:
2608         break;
2609     }
2610
2611     if (o->op_flags & OPf_KIDS) {
2612         OP *kid;
2613
2614 #ifdef DEBUGGING
2615         /* check that op_last points to the last sibling, and that
2616          * the last op_sibling/op_sibparent field points back to the
2617          * parent, and that the only ops with KIDS are those which are
2618          * entitled to them */
2619         U32 type = o->op_type;
2620         U32 family;
2621         bool has_last;
2622
2623         if (type == OP_NULL) {
2624             type = o->op_targ;
2625             /* ck_glob creates a null UNOP with ex-type GLOB
2626              * (which is a list op. So pretend it wasn't a listop */
2627             if (type == OP_GLOB)
2628                 type = OP_NULL;
2629         }
2630         family = PL_opargs[type] & OA_CLASS_MASK;
2631
2632         has_last = (   family == OA_BINOP
2633                     || family == OA_LISTOP
2634                     || family == OA_PMOP
2635                     || family == OA_LOOP
2636                    );
2637         assert(  has_last /* has op_first and op_last, or ...
2638               ... has (or may have) op_first: */
2639               || family == OA_UNOP
2640               || family == OA_UNOP_AUX
2641               || family == OA_LOGOP
2642               || family == OA_BASEOP_OR_UNOP
2643               || family == OA_FILESTATOP
2644               || family == OA_LOOPEXOP
2645               || family == OA_METHOP
2646               || type == OP_CUSTOM
2647               || type == OP_NULL /* new_logop does this */
2648               );
2649
2650         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2651 #  ifdef PERL_OP_PARENT
2652             if (!OpHAS_SIBLING(kid)) {
2653                 if (has_last)
2654                     assert(kid == cLISTOPo->op_last);
2655                 assert(kid->op_sibparent == o);
2656             }
2657 #  else
2658             if (has_last && !OpHAS_SIBLING(kid))
2659                 assert(kid == cLISTOPo->op_last);
2660 #  endif
2661         }
2662 #endif
2663
2664         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
2665             finalize_op(kid);
2666     }
2667 }
2668
2669 /*
2670 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
2671
2672 Propagate lvalue ("modifiable") context to an op and its children.
2673 C<type> represents the context type, roughly based on the type of op that
2674 would do the modifying, although C<local()> is represented by C<OP_NULL>,
2675 because it has no op type of its own (it is signalled by a flag on
2676 the lvalue op).
2677
2678 This function detects things that can't be modified, such as C<$x+1>, and
2679 generates errors for them.  For example, C<$x+1 = 2> would cause it to be
2680 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
2681
2682 It also flags things that need to behave specially in an lvalue context,
2683 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
2684
2685 =cut
2686 */
2687
2688 static void
2689 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
2690 {
2691     CV *cv = PL_compcv;
2692     PadnameLVALUE_on(pn);
2693     while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
2694         cv = CvOUTSIDE(cv);
2695         /* RT #127786: cv can be NULL due to an eval within the DB package
2696          * called from an anon sub - anon subs don't have CvOUTSIDE() set
2697          * unless they contain an eval, but calling eval within DB
2698          * pretends the eval was done in the caller's scope.
2699          */
2700         if (!cv)
2701             break;
2702         assert(CvPADLIST(cv));
2703         pn =
2704            PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
2705         assert(PadnameLEN(pn));
2706         PadnameLVALUE_on(pn);
2707     }
2708 }
2709
2710 static bool
2711 S_vivifies(const OPCODE type)
2712 {
2713     switch(type) {
2714     case OP_RV2AV:     case   OP_ASLICE:
2715     case OP_RV2HV:     case OP_KVASLICE:
2716     case OP_RV2SV:     case   OP_HSLICE:
2717     case OP_AELEMFAST: case OP_KVHSLICE:
2718     case OP_HELEM:
2719     case OP_AELEM:
2720         return 1;
2721     }
2722     return 0;
2723 }
2724
2725 static void
2726 S_lvref(pTHX_ OP *o, I32 type)
2727 {
2728     dVAR;
2729     OP *kid;
2730     switch (o->op_type) {
2731     case OP_COND_EXPR:
2732         for (kid = OpSIBLING(cUNOPo->op_first); kid;
2733              kid = OpSIBLING(kid))
2734             S_lvref(aTHX_ kid, type);
2735         /* FALLTHROUGH */
2736     case OP_PUSHMARK:
2737         return;
2738     case OP_RV2AV:
2739         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2740         o->op_flags |= OPf_STACKED;
2741         if (o->op_flags & OPf_PARENS) {
2742             if (o->op_private & OPpLVAL_INTRO) {
2743                  yyerror(Perl_form(aTHX_ "Can't modify reference to "
2744                       "localized parenthesized array in list assignment"));
2745                 return;
2746             }
2747           slurpy:
2748             OpTYPE_set(o, OP_LVAVREF);
2749             o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
2750             o->op_flags |= OPf_MOD|OPf_REF;
2751             return;
2752         }
2753         o->op_private |= OPpLVREF_AV;
2754         goto checkgv;
2755     case OP_RV2CV:
2756         kid = cUNOPo->op_first;
2757         if (kid->op_type == OP_NULL)
2758             kid = cUNOPx(OpSIBLING(kUNOP->op_first))
2759                 ->op_first;
2760         o->op_private = OPpLVREF_CV;
2761         if (kid->op_type == OP_GV)
2762             o->op_flags |= OPf_STACKED;
2763         else if (kid->op_type == OP_PADCV) {
2764             o->op_targ = kid->op_targ;
2765             kid->op_targ = 0;
2766             op_free(cUNOPo->op_first);
2767             cUNOPo->op_first = NULL;
2768             o->op_flags &=~ OPf_KIDS;
2769         }
2770         else goto badref;
2771         break;
2772     case OP_RV2HV:
2773         if (o->op_flags & OPf_PARENS) {
2774           parenhash:
2775             yyerror(Perl_form(aTHX_ "Can't modify reference to "
2776                                  "parenthesized hash in list assignment"));
2777                 return;
2778         }
2779         o->op_private |= OPpLVREF_HV;
2780         /* FALLTHROUGH */
2781     case OP_RV2SV:
2782       checkgv:
2783         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2784         o->op_flags |= OPf_STACKED;
2785         break;
2786     case OP_PADHV:
2787         if (o->op_flags & OPf_PARENS) goto parenhash;
2788         o->op_private |= OPpLVREF_HV;
2789         /* FALLTHROUGH */
2790     case OP_PADSV:
2791         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2792         break;
2793     case OP_PADAV:
2794         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2795         if (o->op_flags & OPf_PARENS) goto slurpy;
2796         o->op_private |= OPpLVREF_AV;
2797         break;
2798     case OP_AELEM:
2799     case OP_HELEM:
2800         o->op_private |= OPpLVREF_ELEM;
2801         o->op_flags   |= OPf_STACKED;
2802         break;
2803     case OP_ASLICE:
2804     case OP_HSLICE:
2805         OpTYPE_set(o, OP_LVREFSLICE);
2806         o->op_private &= OPpLVAL_INTRO;
2807         return;
2808     case OP_NULL:
2809         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
2810             goto badref;
2811         else if (!(o->op_flags & OPf_KIDS))
2812             return;
2813         if (o->op_targ != OP_LIST) {
2814             S_lvref(aTHX_ cBINOPo->op_first, type);
2815             return;
2816         }
2817         /* FALLTHROUGH */
2818     case OP_LIST:
2819         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
2820             assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
2821             S_lvref(aTHX_ kid, type);
2822         }
2823         return;
2824     case OP_STUB:
2825         if (o->op_flags & OPf_PARENS)
2826             return;
2827         /* FALLTHROUGH */
2828     default:
2829       badref:
2830         /* diag_listed_as: Can't modify reference to %s in %s assignment */
2831         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
2832                      o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
2833                       ? "do block"
2834                       : OP_DESC(o),
2835                      PL_op_desc[type]));
2836         return;
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         if ((o->op_private & OPpSPLIT_ASSIGN)) {
3237             /* This is actually @array = split.  */
3238             PL_modcount = RETURN_UNLIMITED_NUMBER;
3239             break;
3240         }
3241         goto nomod;
3242
3243     case OP_SCALAR:
3244         op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
3245         goto nomod;
3246     }
3247
3248     /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
3249        their argument is a filehandle; thus \stat(".") should not set
3250        it. AMS 20011102 */
3251     if (type == OP_REFGEN &&
3252         PL_check[o->op_type] == Perl_ck_ftst)
3253         return o;
3254
3255     if (type != OP_LEAVESUBLV)
3256         o->op_flags |= OPf_MOD;
3257
3258     if (type == OP_AASSIGN || type == OP_SASSIGN)
3259         o->op_flags |= OPf_SPECIAL
3260                       |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF);
3261     else if (!type) { /* local() */
3262         switch (localize) {
3263         case 1:
3264             o->op_private |= OPpLVAL_INTRO;
3265             o->op_flags &= ~OPf_SPECIAL;
3266             PL_hints |= HINT_BLOCK_SCOPE;
3267             break;
3268         case 0:
3269             break;
3270         case -1:
3271             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
3272                            "Useless localization of %s", OP_DESC(o));
3273         }
3274     }
3275     else if (type != OP_GREPSTART && type != OP_ENTERSUB
3276              && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
3277         o->op_flags |= OPf_REF;
3278     return o;
3279 }
3280
3281 STATIC bool
3282 S_scalar_mod_type(const OP *o, I32 type)
3283 {
3284     switch (type) {
3285     case OP_POS:
3286     case OP_SASSIGN:
3287         if (o && o->op_type == OP_RV2GV)
3288             return FALSE;
3289         /* FALLTHROUGH */
3290     case OP_PREINC:
3291     case OP_PREDEC:
3292     case OP_POSTINC:
3293     case OP_POSTDEC:
3294     case OP_I_PREINC:
3295     case OP_I_PREDEC:
3296     case OP_I_POSTINC:
3297     case OP_I_POSTDEC:
3298     case OP_POW:
3299     case OP_MULTIPLY:
3300     case OP_DIVIDE:
3301     case OP_MODULO:
3302     case OP_REPEAT:
3303     case OP_ADD:
3304     case OP_SUBTRACT:
3305     case OP_I_MULTIPLY:
3306     case OP_I_DIVIDE:
3307     case OP_I_MODULO:
3308     case OP_I_ADD:
3309     case OP_I_SUBTRACT:
3310     case OP_LEFT_SHIFT:
3311     case OP_RIGHT_SHIFT:
3312     case OP_BIT_AND:
3313     case OP_BIT_XOR:
3314     case OP_BIT_OR:
3315     case OP_NBIT_AND:
3316     case OP_NBIT_XOR:
3317     case OP_NBIT_OR:
3318     case OP_SBIT_AND:
3319     case OP_SBIT_XOR:
3320     case OP_SBIT_OR:
3321     case OP_CONCAT:
3322     case OP_SUBST:
3323     case OP_TRANS:
3324     case OP_TRANSR:
3325     case OP_READ:
3326     case OP_SYSREAD:
3327     case OP_RECV:
3328     case OP_ANDASSIGN:
3329     case OP_ORASSIGN:
3330     case OP_DORASSIGN:
3331     case OP_VEC:
3332     case OP_SUBSTR:
3333         return TRUE;
3334     default:
3335         return FALSE;
3336     }
3337 }
3338
3339 STATIC bool
3340 S_is_handle_constructor(const OP *o, I32 numargs)
3341 {
3342     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
3343
3344     switch (o->op_type) {
3345     case OP_PIPE_OP:
3346     case OP_SOCKPAIR:
3347         if (numargs == 2)
3348             return TRUE;
3349         /* FALLTHROUGH */
3350     case OP_SYSOPEN:
3351     case OP_OPEN:
3352     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
3353     case OP_SOCKET:
3354     case OP_OPEN_DIR:
3355     case OP_ACCEPT:
3356         if (numargs == 1)
3357             return TRUE;
3358         /* FALLTHROUGH */
3359     default:
3360         return FALSE;
3361     }
3362 }
3363
3364 static OP *
3365 S_refkids(pTHX_ OP *o, I32 type)
3366 {
3367     if (o && o->op_flags & OPf_KIDS) {
3368         OP *kid;
3369         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3370             ref(kid, type);
3371     }
3372     return o;
3373 }
3374
3375 OP *
3376 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
3377 {
3378     dVAR;
3379     OP *kid;
3380
3381     PERL_ARGS_ASSERT_DOREF;
3382
3383     if (PL_parser && PL_parser->error_count)
3384         return o;
3385
3386     switch (o->op_type) {
3387     case OP_ENTERSUB:
3388         if ((type == OP_EXISTS || type == OP_DEFINED) &&
3389             !(o->op_flags & OPf_STACKED)) {
3390             OpTYPE_set(o, OP_RV2CV);             /* entersub => rv2cv */
3391             assert(cUNOPo->op_first->op_type == OP_NULL);
3392             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
3393             o->op_flags |= OPf_SPECIAL;
3394         }
3395         else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
3396             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3397                               : type == OP_RV2HV ? OPpDEREF_HV
3398                               : OPpDEREF_SV);
3399             o->op_flags |= OPf_MOD;
3400         }
3401
3402         break;
3403
3404     case OP_COND_EXPR:
3405         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
3406             doref(kid, type, set_op_ref);
3407         break;
3408     case OP_RV2SV:
3409         if (type == OP_DEFINED)
3410             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
3411         doref(cUNOPo->op_first, o->op_type, set_op_ref);
3412         /* FALLTHROUGH */
3413     case OP_PADSV:
3414         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3415             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3416                               : type == OP_RV2HV ? OPpDEREF_HV
3417                               : OPpDEREF_SV);
3418             o->op_flags |= OPf_MOD;
3419         }
3420         break;
3421
3422     case OP_RV2AV:
3423     case OP_RV2HV:
3424         if (set_op_ref)
3425             o->op_flags |= OPf_REF;
3426         /* FALLTHROUGH */
3427     case OP_RV2GV:
3428         if (type == OP_DEFINED)
3429             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
3430         doref(cUNOPo->op_first, o->op_type, set_op_ref);
3431         break;
3432
3433     case OP_PADAV:
3434     case OP_PADHV:
3435         if (set_op_ref)
3436             o->op_flags |= OPf_REF;
3437         break;
3438
3439     case OP_SCALAR:
3440     case OP_NULL:
3441         if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
3442             break;
3443         doref(cBINOPo->op_first, type, set_op_ref);
3444         break;
3445     case OP_AELEM:
3446     case OP_HELEM:
3447         doref(cBINOPo->op_first, o->op_type, set_op_ref);
3448         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3449             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3450                               : type == OP_RV2HV ? OPpDEREF_HV
3451                               : OPpDEREF_SV);
3452             o->op_flags |= OPf_MOD;
3453         }
3454         break;
3455
3456     case OP_SCOPE:
3457     case OP_LEAVE:
3458         set_op_ref = FALSE;
3459         /* FALLTHROUGH */
3460     case OP_ENTER:
3461     case OP_LIST:
3462         if (!(o->op_flags & OPf_KIDS))
3463             break;
3464         doref(cLISTOPo->op_last, type, set_op_ref);
3465         break;
3466     default:
3467         break;
3468     }
3469     return scalar(o);
3470
3471 }
3472
3473 STATIC OP *
3474 S_dup_attrlist(pTHX_ OP *o)
3475 {
3476     OP *rop;
3477
3478     PERL_ARGS_ASSERT_DUP_ATTRLIST;
3479
3480     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
3481      * where the first kid is OP_PUSHMARK and the remaining ones
3482      * are OP_CONST.  We need to push the OP_CONST values.
3483      */
3484     if (o->op_type == OP_CONST)
3485         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
3486     else {
3487         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
3488         rop = NULL;
3489         for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
3490             if (o->op_type == OP_CONST)
3491                 rop = op_append_elem(OP_LIST, rop,
3492                                   newSVOP(OP_CONST, o->op_flags,
3493                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
3494         }
3495     }
3496     return rop;
3497 }
3498
3499 STATIC void
3500 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
3501 {
3502     PERL_ARGS_ASSERT_APPLY_ATTRS;
3503     {
3504         SV * const stashsv = newSVhek(HvNAME_HEK(stash));
3505
3506         /* fake up C<use attributes $pkg,$rv,@attrs> */
3507
3508 #define ATTRSMODULE "attributes"
3509 #define ATTRSMODULE_PM "attributes.pm"
3510
3511         Perl_load_module(
3512           aTHX_ PERL_LOADMOD_IMPORT_OPS,
3513           newSVpvs(ATTRSMODULE),
3514           NULL,
3515           op_prepend_elem(OP_LIST,
3516                           newSVOP(OP_CONST, 0, stashsv),
3517                           op_prepend_elem(OP_LIST,
3518                                           newSVOP(OP_CONST, 0,
3519                                                   newRV(target)),
3520                                           dup_attrlist(attrs))));
3521     }
3522 }
3523
3524 STATIC void
3525 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
3526 {
3527     OP *pack, *imop, *arg;
3528     SV *meth, *stashsv, **svp;
3529
3530     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
3531
3532     if (!attrs)
3533         return;
3534
3535     assert(target->op_type == OP_PADSV ||
3536            target->op_type == OP_PADHV ||
3537            target->op_type == OP_PADAV);
3538
3539     /* Ensure that attributes.pm is loaded. */
3540     /* Don't force the C<use> if we don't need it. */
3541     svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
3542     if (svp && *svp != &PL_sv_undef)
3543         NOOP;   /* already in %INC */
3544     else
3545         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
3546                                newSVpvs(ATTRSMODULE), NULL);
3547
3548     /* Need package name for method call. */
3549     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
3550
3551     /* Build up the real arg-list. */
3552     stashsv = newSVhek(HvNAME_HEK(stash));
3553
3554     arg = newOP(OP_PADSV, 0);
3555     arg->op_targ = target->op_targ;
3556     arg = op_prepend_elem(OP_LIST,
3557                        newSVOP(OP_CONST, 0, stashsv),
3558                        op_prepend_elem(OP_LIST,
3559                                     newUNOP(OP_REFGEN, 0,
3560                                             arg),
3561                                     dup_attrlist(attrs)));
3562
3563     /* Fake up a method call to import */
3564     meth = newSVpvs_share("import");
3565     imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
3566                    op_append_elem(OP_LIST,
3567                                op_prepend_elem(OP_LIST, pack, arg),
3568                                newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
3569
3570     /* Combine the ops. */
3571     *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
3572 }
3573
3574 /*
3575 =notfor apidoc apply_attrs_string
3576
3577 Attempts to apply a list of attributes specified by the C<attrstr> and
3578 C<len> arguments to the subroutine identified by the C<cv> argument which
3579 is expected to be associated with the package identified by the C<stashpv>
3580 argument (see L<attributes>).  It gets this wrong, though, in that it
3581 does not correctly identify the boundaries of the individual attribute
3582 specifications within C<attrstr>.  This is not really intended for the
3583 public API, but has to be listed here for systems such as AIX which
3584 need an explicit export list for symbols.  (It's called from XS code
3585 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
3586 to respect attribute syntax properly would be welcome.
3587
3588 =cut
3589 */
3590
3591 void
3592 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
3593                         const char *attrstr, STRLEN len)
3594 {
3595     OP *attrs = NULL;
3596
3597     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
3598
3599     if (!len) {
3600         len = strlen(attrstr);
3601     }
3602
3603     while (len) {
3604         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
3605         if (len) {
3606             const char * const sstr = attrstr;
3607             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
3608             attrs = op_append_elem(OP_LIST, attrs,
3609                                 newSVOP(OP_CONST, 0,
3610                                         newSVpvn(sstr, attrstr-sstr)));
3611         }
3612     }
3613
3614     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3615                      newSVpvs(ATTRSMODULE),
3616                      NULL, op_prepend_elem(OP_LIST,
3617                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
3618                                   op_prepend_elem(OP_LIST,
3619                                                newSVOP(OP_CONST, 0,
3620                                                        newRV(MUTABLE_SV(cv))),
3621                                                attrs)));
3622 }
3623
3624 STATIC void
3625 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
3626 {
3627     OP *new_proto = NULL;
3628     STRLEN pvlen;
3629     char *pv;
3630     OP *o;
3631
3632     PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
3633
3634     if (!*attrs)
3635         return;
3636
3637     o = *attrs;
3638     if (o->op_type == OP_CONST) {
3639         pv = SvPV(cSVOPo_sv, pvlen);
3640         if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3641             SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3642             SV ** const tmpo = cSVOPx_svp(o);
3643             SvREFCNT_dec(cSVOPo_sv);
3644             *tmpo = tmpsv;
3645             new_proto = o;
3646             *attrs = NULL;
3647         }
3648     } else if (o->op_type == OP_LIST) {
3649         OP * lasto;
3650         assert(o->op_flags & OPf_KIDS);
3651         lasto = cLISTOPo->op_first;
3652         assert(lasto->op_type == OP_PUSHMARK);
3653         for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
3654             if (o->op_type == OP_CONST) {
3655                 pv = SvPV(cSVOPo_sv, pvlen);
3656                 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3657                     SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3658                     SV ** const tmpo = cSVOPx_svp(o);
3659                     SvREFCNT_dec(cSVOPo_sv);
3660                     *tmpo = tmpsv;
3661                     if (new_proto && ckWARN(WARN_MISC)) {
3662                         STRLEN new_len;
3663                         const char * newp = SvPV(cSVOPo_sv, new_len);
3664                         Perl_warner(aTHX_ packWARN(WARN_MISC),
3665                             "Attribute prototype(%" UTF8f ") discards earlier prototype attribute in same sub",
3666                             UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
3667                         op_free(new_proto);
3668                     }
3669                     else if (new_proto)
3670                         op_free(new_proto);
3671                     new_proto = o;
3672                     /* excise new_proto from the list */
3673                     op_sibling_splice(*attrs, lasto, 1, NULL);
3674                     o = lasto;
3675                     continue;
3676                 }
3677             }
3678             lasto = o;
3679         }
3680         /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
3681            would get pulled in with no real need */
3682         if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
3683             op_free(*attrs);
3684             *attrs = NULL;
3685         }
3686     }
3687
3688     if (new_proto) {
3689         SV *svname;
3690         if (isGV(name)) {
3691             svname = sv_newmortal();
3692             gv_efullname3(svname, name, NULL);
3693         }
3694         else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
3695             svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
3696         else
3697             svname = (SV *)name;
3698         if (ckWARN(WARN_ILLEGALPROTO))
3699             (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
3700         if (*proto && ckWARN(WARN_PROTOTYPE)) {
3701             STRLEN old_len, new_len;
3702             const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
3703             const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
3704
3705             Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3706                 "Prototype '%" UTF8f "' overridden by attribute 'prototype(%" UTF8f ")'"
3707                 " in %" SVf,
3708                 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
3709                 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
3710                 SVfARG(svname));
3711         }
3712         if (*proto)
3713             op_free(*proto);
3714         *proto = new_proto;
3715     }
3716 }
3717
3718 static void
3719 S_cant_declare(pTHX_ OP *o)
3720 {
3721     if (o->op_type == OP_NULL
3722      && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
3723         o = cUNOPo->op_first;
3724     yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
3725                              o->op_type == OP_NULL
3726                                && o->op_flags & OPf_SPECIAL
3727                                  ? "do block"
3728                                  : OP_DESC(o),
3729                              PL_parser->in_my == KEY_our   ? "our"   :
3730                              PL_parser->in_my == KEY_state ? "state" :
3731                                                              "my"));
3732 }
3733
3734 STATIC OP *
3735 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
3736 {
3737     I32 type;
3738     const bool stately = PL_parser && PL_parser->in_my == KEY_state;
3739
3740     PERL_ARGS_ASSERT_MY_KID;
3741
3742     if (!o || (PL_parser && PL_parser->error_count))
3743         return o;
3744
3745     type = o->op_type;
3746
3747     if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
3748         OP *kid;
3749         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3750             my_kid(kid, attrs, imopsp);
3751         return o;
3752     } else if (type == OP_UNDEF || type == OP_STUB) {
3753         return o;
3754     } else if (type == OP_RV2SV ||      /* "our" declaration */
3755                type == OP_RV2AV ||
3756                type == OP_RV2HV) {
3757         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
3758             S_cant_declare(aTHX_ o);
3759         } else if (attrs) {
3760             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
3761             assert(PL_parser);
3762             PL_parser->in_my = FALSE;
3763             PL_parser->in_my_stash = NULL;
3764             apply_attrs(GvSTASH(gv),
3765                         (type == OP_RV2SV ? GvSV(gv) :
3766                          type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
3767                          type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
3768                         attrs);
3769         }
3770         o->op_private |= OPpOUR_INTRO;
3771         return o;
3772     }
3773     else if (type == OP_REFGEN || type == OP_SREFGEN) {
3774         if (!FEATURE_MYREF_IS_ENABLED)
3775             Perl_croak(aTHX_ "The experimental declared_refs "
3776                              "feature is not enabled");
3777         Perl_ck_warner_d(aTHX_
3778              packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
3779             "Declaring references is experimental");
3780         /* Kid is a nulled OP_LIST, handled above.  */
3781         my_kid(cUNOPo->op_first, attrs, imopsp);
3782         return o;
3783     }
3784     else if (type != OP_PADSV &&
3785              type != OP_PADAV &&
3786              type != OP_PADHV &&
3787              type != OP_PUSHMARK)
3788     {
3789         S_cant_declare(aTHX_ o);
3790         return o;
3791     }
3792     else if (attrs && type != OP_PUSHMARK) {
3793         HV *stash;
3794
3795         assert(PL_parser);
3796         PL_parser->in_my = FALSE;
3797         PL_parser->in_my_stash = NULL;
3798
3799         /* check for C<my Dog $spot> when deciding package */
3800         stash = PAD_COMPNAME_TYPE(o->op_targ);
3801         if (!stash)
3802             stash = PL_curstash;
3803         apply_attrs_my(stash, o, attrs, imopsp);
3804     }
3805     o->op_flags |= OPf_MOD;
3806     o->op_private |= OPpLVAL_INTRO;
3807     if (stately)
3808         o->op_private |= OPpPAD_STATE;
3809     return o;
3810 }
3811
3812 OP *
3813 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
3814 {
3815     OP *rops;
3816     int maybe_scalar = 0;
3817
3818     PERL_ARGS_ASSERT_MY_ATTRS;
3819
3820 /* [perl #17376]: this appears to be premature, and results in code such as
3821    C< our(%x); > executing in list mode rather than void mode */
3822 #if 0
3823     if (o->op_flags & OPf_PARENS)
3824         list(o);
3825     else
3826         maybe_scalar = 1;
3827 #else
3828     maybe_scalar = 1;
3829 #endif
3830     if (attrs)
3831         SAVEFREEOP(attrs);
3832     rops = NULL;
3833     o = my_kid(o, attrs, &rops);
3834     if (rops) {
3835         if (maybe_scalar && o->op_type == OP_PADSV) {
3836             o = scalar(op_append_list(OP_LIST, rops, o));
3837             o->op_private |= OPpLVAL_INTRO;
3838         }
3839         else {
3840             /* The listop in rops might have a pushmark at the beginning,
3841                which will mess up list assignment. */
3842             LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
3843             if (rops->op_type == OP_LIST &&
3844                 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
3845             {
3846                 OP * const pushmark = lrops->op_first;
3847                 /* excise pushmark */
3848                 op_sibling_splice(rops, NULL, 1, NULL);
3849                 op_free(pushmark);
3850             }
3851             o = op_append_list(OP_LIST, o, rops);
3852         }
3853     }
3854     PL_parser->in_my = FALSE;
3855     PL_parser->in_my_stash = NULL;
3856     return o;
3857 }
3858
3859 OP *
3860 Perl_sawparens(pTHX_ OP *o)
3861 {
3862     PERL_UNUSED_CONTEXT;
3863     if (o)
3864         o->op_flags |= OPf_PARENS;
3865     return o;
3866 }
3867
3868 OP *
3869 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
3870 {
3871     OP *o;
3872     bool ismatchop = 0;
3873     const OPCODE ltype = left->op_type;
3874     const OPCODE rtype = right->op_type;
3875
3876     PERL_ARGS_ASSERT_BIND_MATCH;
3877
3878     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
3879           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
3880     {
3881       const char * const desc
3882           = PL_op_desc[(
3883                           rtype == OP_SUBST || rtype == OP_TRANS
3884                        || rtype == OP_TRANSR
3885                        )
3886                        ? (int)rtype : OP_MATCH];
3887       const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
3888       SV * const name =
3889         S_op_varname(aTHX_ left);
3890       if (name)
3891         Perl_warner(aTHX_ packWARN(WARN_MISC),
3892              "Applying %s to %" SVf " will act on scalar(%" SVf ")",
3893              desc, SVfARG(name), SVfARG(name));
3894       else {
3895         const char * const sample = (isary
3896              ? "@array" : "%hash");
3897         Perl_warner(aTHX_ packWARN(WARN_MISC),
3898              "Applying %s to %s will act on scalar(%s)",
3899              desc, sample, sample);
3900       }
3901     }
3902
3903     if (rtype == OP_CONST &&
3904         cSVOPx(right)->op_private & OPpCONST_BARE &&
3905         cSVOPx(right)->op_private & OPpCONST_STRICT)
3906     {
3907         no_bareword_allowed(right);
3908     }
3909
3910     /* !~ doesn't make sense with /r, so error on it for now */
3911     if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
3912         type == OP_NOT)
3913         /* diag_listed_as: Using !~ with %s doesn't make sense */
3914         yyerror("Using !~ with s///r doesn't make sense");
3915     if (rtype == OP_TRANSR && type == OP_NOT)
3916         /* diag_listed_as: Using !~ with %s doesn't make sense */
3917         yyerror("Using !~ with tr///r doesn't make sense");
3918
3919     ismatchop = (rtype == OP_MATCH ||
3920                  rtype == OP_SUBST ||
3921                  rtype == OP_TRANS || rtype == OP_TRANSR)
3922              && !(right->op_flags & OPf_SPECIAL);
3923     if (ismatchop && right->op_private & OPpTARGET_MY) {
3924         right->op_targ = 0;
3925         right->op_private &= ~OPpTARGET_MY;
3926     }
3927     if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
3928         if (left->op_type == OP_PADSV
3929          && !(left->op_private & OPpLVAL_INTRO))
3930         {
3931             right->op_targ = left->op_targ;
3932             op_free(left);
3933             o = right;
3934         }
3935         else {
3936             right->op_flags |= OPf_STACKED;
3937             if (rtype != OP_MATCH && rtype != OP_TRANSR &&
3938             ! (rtype == OP_TRANS &&
3939                right->op_private & OPpTRANS_IDENTICAL) &&
3940             ! (rtype == OP_SUBST &&
3941                (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3942                 left = op_lvalue(left, rtype);
3943             if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
3944                 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
3945             else
3946                 o = op_prepend_elem(rtype, scalar(left), right);
3947         }
3948         if (type == OP_NOT)
3949             return newUNOP(OP_NOT, 0, scalar(o));
3950         return o;
3951     }
3952     else
3953         return bind_match(type, left,
3954                 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
3955 }
3956
3957 OP *
3958 Perl_invert(pTHX_ OP *o)
3959 {
3960     if (!o)
3961         return NULL;
3962     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
3963 }
3964
3965 /*
3966 =for apidoc Amx|OP *|op_scope|OP *o
3967
3968 Wraps up an op tree with some additional ops so that at runtime a dynamic
3969 scope will be created.  The original ops run in the new dynamic scope,
3970 and then, provided that they exit normally, the scope will be unwound.
3971 The additional ops used to create and unwind the dynamic scope will
3972 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
3973 instead if the ops are simple enough to not need the full dynamic scope
3974 structure.
3975
3976 =cut
3977 */
3978
3979 OP *
3980 Perl_op_scope(pTHX_ OP *o)
3981 {
3982     dVAR;
3983     if (o) {
3984         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
3985             o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
3986             OpTYPE_set(o, OP_LEAVE);
3987         }
3988         else if (o->op_type == OP_LINESEQ) {
3989             OP *kid;
3990             OpTYPE_set(o, OP_SCOPE);
3991             kid = ((LISTOP*)o)->op_first;
3992             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
3993                 op_null(kid);
3994
3995                 /* The following deals with things like 'do {1 for 1}' */
3996                 kid = OpSIBLING(kid);
3997                 if (kid &&
3998                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
3999                     op_null(kid);
4000             }
4001         }
4002         else
4003             o = newLISTOP(OP_SCOPE, 0, o, NULL);
4004     }
4005     return o;
4006 }
4007
4008 OP *
4009 Perl_op_unscope(pTHX_ OP *o)
4010 {
4011     if (o && o->op_type == OP_LINESEQ) {
4012         OP *kid = cLISTOPo->op_first;
4013         for(; kid; kid = OpSIBLING(kid))
4014             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
4015                 op_null(kid);
4016     }
4017     return o;
4018 }
4019
4020 /*
4021 =for apidoc Am|int|block_start|int full
4022
4023 Handles compile-time scope entry.
4024 Arranges for hints to be restored on block
4025 exit and also handles pad sequence numbers to make lexical variables scope
4026 right.  Returns a savestack index for use with C<block_end>.
4027
4028 =cut
4029 */
4030
4031 int
4032 Perl_block_start(pTHX_ int full)
4033 {
4034     const int retval = PL_savestack_ix;
4035
4036     PL_compiling.cop_seq = PL_cop_seqmax;
4037     COP_SEQMAX_INC;
4038     pad_block_start(full);
4039     SAVEHINTS();
4040     PL_hints &= ~HINT_BLOCK_SCOPE;
4041     SAVECOMPILEWARNINGS();
4042     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
4043     SAVEI32(PL_compiling.cop_seq);
4044     PL_compiling.cop_seq = 0;
4045
4046     CALL_BLOCK_HOOKS(bhk_start, full);
4047
4048     return retval;
4049 }
4050
4051 /*
4052 =for apidoc Am|OP *|block_end|I32 floor|OP *seq
4053
4054 Handles compile-time scope exit.  C<floor>
4055 is the savestack index returned by
4056 C<block_start>, and C<seq> is the body of the block.  Returns the block,
4057 possibly modified.
4058
4059 =cut
4060 */
4061
4062 OP*
4063 Perl_block_end(pTHX_ I32 floor, OP *seq)
4064 {
4065     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
4066     OP* retval = scalarseq(seq);
4067     OP *o;
4068
4069     /* XXX Is the null PL_parser check necessary here? */
4070     assert(PL_parser); /* Let’s find out under debugging builds.  */
4071     if (PL_parser && PL_parser->parsed_sub) {
4072         o = newSTATEOP(0, NULL, NULL);
4073         op_null(o);
4074         retval = op_append_elem(OP_LINESEQ, retval, o);
4075     }
4076
4077     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
4078
4079     LEAVE_SCOPE(floor);
4080     if (needblockscope)
4081         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
4082     o = pad_leavemy();
4083
4084     if (o) {
4085         /* pad_leavemy has created a sequence of introcv ops for all my
4086            subs declared in the block.  We have to replicate that list with
4087            clonecv ops, to deal with this situation:
4088
4089                sub {
4090                    my sub s1;
4091                    my sub s2;
4092                    sub s1 { state sub foo { \&s2 } }
4093                }->()
4094
4095            Originally, I was going to have introcv clone the CV and turn
4096            off the stale flag.  Since &s1 is declared before &s2, the
4097            introcv op for &s1 is executed (on sub entry) before the one for
4098            &s2.  But the &foo sub inside &s1 (which is cloned when &s1 is
4099            cloned, since it is a state sub) closes over &s2 and expects
4100            to see it in its outer CV’s pad.  If the introcv op clones &s1,
4101            then &s2 is still marked stale.  Since &s1 is not active, and
4102            &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
4103            ble will not stay shared’ warning.  Because it is the same stub
4104            that will be used when the introcv op for &s2 is executed, clos-
4105            ing over it is safe.  Hence, we have to turn off the stale flag
4106            on all lexical subs in the block before we clone any of them.
4107            Hence, having introcv clone the sub cannot work.  So we create a
4108            list of ops like this:
4109
4110                lineseq
4111                   |
4112                   +-- introcv
4113                   |
4114                   +-- introcv
4115                   |
4116                   +-- introcv
4117                   |
4118                   .
4119                   .
4120                   .
4121                   |
4122                   +-- clonecv
4123                   |
4124                   +-- clonecv
4125                   |
4126                   +-- clonecv
4127                   |
4128                   .
4129                   .
4130                   .
4131          */
4132         OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
4133         OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
4134         for (;; kid = OpSIBLING(kid)) {
4135             OP *newkid = newOP(OP_CLONECV, 0);
4136             newkid->op_targ = kid->op_targ;
4137             o = op_append_elem(OP_LINESEQ, o, newkid);
4138             if (kid == last) break;
4139         }
4140         retval = op_prepend_elem(OP_LINESEQ, o, retval);
4141     }
4142
4143     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
4144
4145     return retval;
4146 }
4147
4148 /*
4149 =head1 Compile-time scope hooks
4150
4151 =for apidoc Aox||blockhook_register
4152
4153 Register a set of hooks to be called when the Perl lexical scope changes
4154 at compile time.  See L<perlguts/"Compile-time scope hooks">.
4155
4156 =cut
4157 */
4158
4159 void
4160 Perl_blockhook_register(pTHX_ BHK *hk)
4161 {
4162     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
4163
4164     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
4165 }
4166
4167 void
4168 Perl_newPROG(pTHX_ OP *o)
4169 {
4170     PERL_ARGS_ASSERT_NEWPROG;
4171
4172     if (PL_in_eval) {
4173         PERL_CONTEXT *cx;
4174         I32 i;
4175         if (PL_eval_root)
4176                 return;
4177         PL_eval_root = newUNOP(OP_LEAVEEVAL,
4178                                ((PL_in_eval & EVAL_KEEPERR)
4179                                 ? OPf_SPECIAL : 0), o);
4180
4181         cx = CX_CUR();
4182         assert(CxTYPE(cx) == CXt_EVAL);
4183
4184         if ((cx->blk_gimme & G_WANT) == G_VOID)
4185             scalarvoid(PL_eval_root);
4186         else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
4187             list(PL_eval_root);
4188         else
4189             scalar(PL_eval_root);
4190
4191         PL_eval_start = op_linklist(PL_eval_root);
4192         PL_eval_root->op_private |= OPpREFCOUNTED;
4193         OpREFCNT_set(PL_eval_root, 1);
4194         PL_eval_root->op_next = 0;
4195         i = PL_savestack_ix;
4196         SAVEFREEOP(o);
4197         ENTER;
4198         CALL_PEEP(PL_eval_start);
4199         finalize_optree(PL_eval_root);
4200         S_prune_chain_head(&PL_eval_start);
4201         LEAVE;
4202         PL_savestack_ix = i;
4203     }
4204     else {
4205         if (o->op_type == OP_STUB) {
4206             /* This block is entered if nothing is compiled for the main
4207                program. This will be the case for an genuinely empty main
4208                program, or one which only has BEGIN blocks etc, so already
4209                run and freed.
4210
4211                Historically (5.000) the guard above was !o. However, commit
4212                f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
4213                c71fccf11fde0068, changed perly.y so that newPROG() is now
4214                called with the output of block_end(), which returns a new
4215                OP_STUB for the case of an empty optree. ByteLoader (and
4216                maybe other things) also take this path, because they set up
4217                PL_main_start and PL_main_root directly, without generating an
4218                optree.
4219
4220                If the parsing the main program aborts (due to parse errors,
4221                or due to BEGIN or similar calling exit), then newPROG()
4222                isn't even called, and hence this code path and its cleanups
4223                are skipped. This shouldn't make a make a difference:
4224                * a non-zero return from perl_parse is a failure, and
4225                  perl_destruct() should be called immediately.
4226                * however, if exit(0) is called during the parse, then
4227                  perl_parse() returns 0, and perl_run() is called. As
4228                  PL_main_start will be NULL, perl_run() will return
4229                  promptly, and the exit code will remain 0.
4230             */
4231
4232             PL_comppad_name = 0;
4233             PL_compcv = 0;
4234             S_op_destroy(aTHX_ o);
4235             return;
4236         }
4237         PL_main_root = op_scope(sawparens(scalarvoid(o)));
4238         PL_curcop = &PL_compiling;
4239         PL_main_start = LINKLIST(PL_main_root);
4240         PL_main_root->op_private |= OPpREFCOUNTED;
4241         OpREFCNT_set(PL_main_root, 1);
4242         PL_main_root->op_next = 0;
4243         CALL_PEEP(PL_main_start);
4244         finalize_optree(PL_main_root);
4245         S_prune_chain_head(&PL_main_start);
4246         cv_forget_slab(PL_compcv);
4247         PL_compcv = 0;
4248
4249         /* Register with debugger */
4250         if (PERLDB_INTER) {
4251             CV * const cv = get_cvs("DB::postponed", 0);
4252             if (cv) {
4253                 dSP;
4254                 PUSHMARK(SP);
4255                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
4256                 PUTBACK;
4257                 call_sv(MUTABLE_SV(cv), G_DISCARD);
4258             }
4259         }
4260     }
4261 }
4262
4263 OP *
4264 Perl_localize(pTHX_ OP *o, I32 lex)
4265 {
4266     PERL_ARGS_ASSERT_LOCALIZE;
4267
4268     if (o->op_flags & OPf_PARENS)
4269 /* [perl #17376]: this appears to be premature, and results in code such as
4270    C< our(%x); > executing in list mode rather than void mode */
4271 #if 0
4272         list(o);
4273 #else
4274         NOOP;
4275 #endif
4276     else {
4277         if ( PL_parser->bufptr > PL_parser->oldbufptr
4278             && PL_parser->bufptr[-1] == ','
4279             && ckWARN(WARN_PARENTHESIS))
4280         {
4281             char *s = PL_parser->bufptr;
4282             bool sigil = FALSE;
4283
4284             /* some heuristics to detect a potential error */
4285             while (*s && (strchr(", \t\n", *s)))
4286                 s++;
4287
4288             while (1) {
4289                 if (*s && (strchr("@$%", *s) || (!lex && *s == '*'))
4290                        && *++s
4291                        && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
4292                     s++;
4293                     sigil = TRUE;
4294                     while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
4295                         s++;
4296                     while (*s && (strchr(", \t\n", *s)))
4297                         s++;
4298                 }
4299                 else
4300                     break;
4301             }
4302             if (sigil && (*s == ';' || *s == '=')) {
4303                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
4304                                 "Parentheses missing around \"%s\" list",
4305                                 lex
4306                                     ? (PL_parser->in_my == KEY_our
4307                                         ? "our"
4308                                         : PL_parser->in_my == KEY_state
4309                                             ? "state"
4310                                             : "my")
4311                                     : "local");
4312             }
4313         }
4314     }
4315     if (lex)
4316         o = my(o);
4317     else
4318         o = op_lvalue(o, OP_NULL);              /* a bit kludgey */
4319     PL_parser->in_my = FALSE;
4320     PL_parser->in_my_stash = NULL;
4321     return o;
4322 }
4323
4324 OP *
4325 Perl_jmaybe(pTHX_ OP *o)
4326 {
4327     PERL_ARGS_ASSERT_JMAYBE;
4328
4329     if (o->op_type == OP_LIST) {
4330         OP * const o2
4331             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
4332         o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
4333     }
4334     return o;
4335 }
4336
4337 PERL_STATIC_INLINE OP *
4338 S_op_std_init(pTHX_ OP *o)
4339 {
4340     I32 type = o->op_type;
4341
4342     PERL_ARGS_ASSERT_OP_STD_INIT;
4343
4344     if (PL_opargs[type] & OA_RETSCALAR)
4345         scalar(o);
4346     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
4347         o->op_targ = pad_alloc(type, SVs_PADTMP);
4348
4349     return o;
4350 }
4351
4352 PERL_STATIC_INLINE OP *
4353 S_op_integerize(pTHX_ OP *o)
4354 {
4355     I32 type = o->op_type;
4356
4357     PERL_ARGS_ASSERT_OP_INTEGERIZE;
4358
4359     /* integerize op. */
4360     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
4361     {
4362         dVAR;
4363         o->op_ppaddr = PL_ppaddr[++(o->op_type)];
4364     }
4365
4366     if (type == OP_NEGATE)
4367         /* XXX might want a ck_negate() for this */
4368         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
4369
4370     return o;
4371 }
4372
4373 static OP *
4374 S_fold_constants(pTHX_ OP *const o)
4375 {
4376     dVAR;
4377     OP * VOL curop;
4378     OP *newop;
4379     VOL I32 type = o->op_type;
4380     bool is_stringify;
4381     SV * VOL sv = NULL;
4382     int ret = 0;
4383     OP *old_next;
4384     SV * const oldwarnhook = PL_warnhook;
4385     SV * const olddiehook  = PL_diehook;
4386     COP not_compiling;
4387     U8 oldwarn = PL_dowarn;
4388     I32 old_cxix;
4389     dJMPENV;
4390
4391     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
4392
4393     if (!(PL_opargs[type] & OA_FOLDCONST))
4394         goto nope;
4395
4396     switch (type) {
4397     case OP_UCFIRST:
4398     case OP_LCFIRST:
4399     case OP_UC:
4400     case OP_LC:
4401     case OP_FC:
4402 #ifdef USE_LOCALE_CTYPE
4403         if (IN_LC_COMPILETIME(LC_CTYPE))
4404             goto nope;
4405 #endif
4406         break;
4407     case OP_SLT:
4408     case OP_SGT:
4409     case OP_SLE:
4410     case OP_SGE:
4411     case OP_SCMP:
4412 #ifdef USE_LOCALE_COLLATE
4413         if (IN_LC_COMPILETIME(LC_COLLATE))
4414             goto nope;
4415 #endif
4416         break;
4417     case OP_SPRINTF:
4418         /* XXX what about the numeric ops? */
4419 #ifdef USE_LOCALE_NUMERIC
4420         if (IN_LC_COMPILETIME(LC_NUMERIC))
4421             goto nope;
4422 #endif
4423         break;
4424     case OP_PACK:
4425         if (!OpHAS_SIBLING(cLISTOPo->op_first)
4426           || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
4427             goto nope;
4428         {
4429             SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
4430             if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
4431             {
4432                 const char *s = SvPVX_const(sv);
4433                 while (s < SvEND(sv)) {
4434                     if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
4435                     s++;
4436                 }
4437             }
4438         }
4439         break;
4440     case OP_REPEAT:
4441         if (o->op_private & OPpREPEAT_DOLIST) goto nope;
4442         break;
4443     case OP_SREFGEN:
4444         if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
4445          || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
4446             goto nope;
4447     }
4448
4449     if (PL_parser && PL_parser->error_count)
4450         goto nope;              /* Don't try to run w/ errors */
4451
4452     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4453         switch (curop->op_type) {
4454         case OP_CONST:
4455             if (   (curop->op_private & OPpCONST_BARE)
4456                 && (curop->op_private & OPpCONST_STRICT)) {
4457                 no_bareword_allowed(curop);
4458                 goto nope;
4459             }
4460             /* FALLTHROUGH */
4461         case OP_LIST:
4462         case OP_SCALAR:
4463         case OP_NULL:
4464         case OP_PUSHMARK:
4465             /* Foldable; move to next op in list */
4466             break;
4467
4468         default:
4469             /* No other op types are considered foldable */
4470             goto nope;
4471         }
4472     }
4473
4474     curop = LINKLIST(o);
4475     old_next = o->op_next;
4476     o->op_next = 0;
4477     PL_op = curop;
4478
4479     old_cxix = cxstack_ix;
4480     create_eval_scope(NULL, G_FAKINGEVAL);
4481
4482     /* Verify that we don't need to save it:  */
4483     assert(PL_curcop == &PL_compiling);
4484     StructCopy(&PL_compiling, &not_compiling, COP);
4485     PL_curcop = &not_compiling;
4486     /* The above ensures that we run with all the correct hints of the
4487        currently compiling COP, but that IN_PERL_RUNTIME is true. */
4488     assert(IN_PERL_RUNTIME);
4489     PL_warnhook = PERL_WARNHOOK_FATAL;
4490     PL_diehook  = NULL;
4491     JMPENV_PUSH(ret);
4492
4493     /* Effective $^W=1.  */
4494     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
4495         PL_dowarn |= G_WARN_ON;
4496
4497     switch (ret) {
4498     case 0:
4499         CALLRUNOPS(aTHX);
4500         sv = *(PL_stack_sp--);
4501         if (o->op_targ && sv == PAD_SV(o->op_targ)) {   /* grab pad temp? */
4502             pad_swipe(o->op_targ,  FALSE);
4503         }
4504         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
4505             SvREFCNT_inc_simple_void(sv);
4506             SvTEMP_off(sv);
4507         }
4508         else { assert(SvIMMORTAL(sv)); }
4509         break;
4510     case 3:
4511         /* Something tried to die.  Abandon constant folding.  */
4512         /* Pretend the error never happened.  */
4513         CLEAR_ERRSV();
4514         o->op_next = old_next;
4515         break;
4516     default:
4517         JMPENV_POP;
4518         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
4519         PL_warnhook = oldwarnhook;
4520         PL_diehook  = olddiehook;
4521         /* XXX note that this croak may fail as we've already blown away
4522          * the stack - eg any nested evals */
4523         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
4524     }
4525     JMPENV_POP;
4526     PL_dowarn   = oldwarn;
4527     PL_warnhook = oldwarnhook;
4528     PL_diehook  = olddiehook;
4529     PL_curcop = &PL_compiling;
4530
4531     /* if we croaked, depending on how we croaked the eval scope
4532      * may or may not have already been popped */
4533     if (cxstack_ix > old_cxix) {
4534         assert(cxstack_ix == old_cxix + 1);
4535         assert(CxTYPE(CX_CUR()) == CXt_EVAL);
4536         delete_eval_scope();
4537     }
4538     if (ret)
4539         goto nope;
4540
4541     /* OP_STRINGIFY and constant folding are used to implement qq.
4542        Here the constant folding is an implementation detail that we
4543        want to hide.  If the stringify op is itself already marked
4544        folded, however, then it is actually a folded join.  */
4545     is_stringify = type == OP_STRINGIFY && !o->op_folded;
4546     op_free(o);
4547     assert(sv);
4548     if (is_stringify)
4549         SvPADTMP_off(sv);
4550     else if (!SvIMMORTAL(sv)) {
4551         SvPADTMP_on(sv);
4552         SvREADONLY_on(sv);
4553     }
4554     newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
4555     if (!is_stringify) newop->op_folded = 1;
4556     return newop;
4557
4558  nope:
4559     return o;
4560 }
4561
4562 static OP *
4563 S_gen_constant_list(pTHX_ OP *o)
4564 {
4565     dVAR;
4566     OP *curop;
4567     const SSize_t oldtmps_floor = PL_tmps_floor;
4568     SV **svp;
4569     AV *av;
4570
4571     list(o);
4572     if (PL_parser && PL_parser->error_count)
4573         return o;               /* Don't attempt to run with errors */
4574
4575     curop = LINKLIST(o);
4576     o->op_next = 0;
4577     CALL_PEEP(curop);
4578     S_prune_chain_head(&curop);
4579     PL_op = curop;
4580     Perl_pp_pushmark(aTHX);
4581     CALLRUNOPS(aTHX);
4582     PL_op = curop;
4583     assert (!(curop->op_flags & OPf_SPECIAL));
4584     assert(curop->op_type == OP_RANGE);
4585     Perl_pp_anonlist(aTHX);
4586     PL_tmps_floor = oldtmps_floor;
4587
4588     OpTYPE_set(o, OP_RV2AV);
4589     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
4590     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
4591     o->op_opt = 0;              /* needs to be revisited in rpeep() */
4592     av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
4593
4594     /* replace subtree with an OP_CONST */
4595     curop = ((UNOP*)o)->op_first;
4596     op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
4597     op_free(curop);
4598
4599     if (AvFILLp(av) != -1)
4600         for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
4601         {
4602             SvPADTMP_on(*svp);
4603             SvREADONLY_on(*svp);
4604         }
4605     LINKLIST(o);
4606     return list(o);
4607 }
4608
4609 /*
4610 =head1 Optree Manipulation Functions
4611 */
4612
4613 /* List constructors */
4614
4615 /*
4616 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
4617
4618 Append an item to the list of ops contained directly within a list-type
4619 op, returning the lengthened list.  C<first> is the list-type op,
4620 and C<last> is the op to append to the list.  C<optype> specifies the
4621 intended opcode for the list.  If C<first> is not already a list of the
4622 right type, it will be upgraded into one.  If either C<first> or C<last>
4623 is null, the other is returned unchanged.
4624
4625 =cut
4626 */
4627
4628 OP *
4629 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
4630 {
4631     if (!first)
4632         return last;
4633
4634     if (!last)
4635         return first;
4636
4637     if (first->op_type != (unsigned)type
4638         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
4639     {
4640         return newLISTOP(type, 0, first, last);
4641     }
4642
4643     op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
4644     first->op_flags |= OPf_KIDS;
4645     return first;
4646 }
4647
4648 /*
4649 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
4650
4651 Concatenate the lists of ops contained directly within two list-type ops,
4652 returning the combined list.  C<first> and C<last> are the list-type ops
4653 to concatenate.  C<optype> specifies the intended opcode for the list.
4654 If either C<first> or C<last> is not already a list of the right type,
4655 it will be upgraded into one.  If either C<first> or C<last> is null,
4656 the other is returned unchanged.
4657
4658 =cut
4659 */
4660
4661 OP *
4662 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
4663 {
4664     if (!first)
4665         return last;
4666
4667     if (!last)
4668         return first;
4669
4670     if (first->op_type != (unsigned)type)
4671         return op_prepend_elem(type, first, last);
4672
4673     if (last->op_type != (unsigned)type)
4674         return op_append_elem(type, first, last);
4675
4676     OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
4677     ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
4678     OpLASTSIB_set(((LISTOP*)first)->op_last, first);
4679     first->op_flags |= (last->op_flags & OPf_KIDS);
4680
4681     S_op_destroy(aTHX_ last);
4682
4683     return first;
4684 }
4685
4686 /*
4687 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
4688
4689 Prepend an item to the list of ops contained directly within a list-type
4690 op, returning the lengthened list.  C<first> is the op to prepend to the
4691 list, and C<last> is the list-type op.  C<optype> specifies the intended
4692 opcode for the list.  If C<last> is not already a list of the right type,
4693 it will be upgraded into one.  If either C<first> or C<last> is null,
4694 the other is returned unchanged.
4695
4696 =cut
4697 */
4698
4699 OP *
4700 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
4701 {
4702     if (!first)
4703         return last;
4704
4705     if (!last)
4706         return first;
4707
4708     if (last->op_type == (unsigned)type) {
4709         if (type == OP_LIST) {  /* already a PUSHMARK there */
4710             /* insert 'first' after pushmark */
4711             op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
4712             if (!(first->op_flags & OPf_PARENS))
4713                 last->op_flags &= ~OPf_PARENS;
4714         }
4715         else
4716             op_sibling_splice(last, NULL, 0, first);
4717         last->op_flags |= OPf_KIDS;
4718         return last;
4719     }
4720
4721     return newLISTOP(type, 0, first, last);
4722 }
4723
4724 /*
4725 =for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
4726
4727 Converts C<o> into a list op if it is not one already, and then converts it
4728 into the specified C<type>, calling its check function, allocating a target if
4729 it needs one, and folding constants.
4730
4731 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
4732 C<op_prepend_elem> and C<op_append_elem>.  Then finally it is passed to
4733 C<op_convert_list> to make it the right type.
4734
4735 =cut
4736 */
4737
4738 OP *
4739 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
4740 {
4741     dVAR;
4742     if (type < 0) type = -type, flags |= OPf_SPECIAL;
4743     if (!o || o->op_type != OP_LIST)
4744         o = force_list(o, 0);
4745     else
4746     {
4747         o->op_flags &= ~OPf_WANT;
4748         o->op_private &= ~OPpLVAL_INTRO;
4749     }
4750
4751     if (!(PL_opargs[type] & OA_MARK))
4752         op_null(cLISTOPo->op_first);
4753     else {
4754         OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
4755         if (kid2 && kid2->op_type == OP_COREARGS) {
4756             op_null(cLISTOPo->op_first);
4757             kid2->op_private |= OPpCOREARGS_PUSHMARK;
4758         }
4759     }
4760
4761     if (type != OP_SPLIT)
4762         /* At this point o is a LISTOP, but OP_SPLIT is a PMOP; let
4763          * ck_split() create a real PMOP and leave the op's type as listop
4764          * for now. Otherwise op_free() etc will crash.
4765          */
4766         OpTYPE_set(o, type);
4767
4768     o->op_flags |= flags;
4769     if (flags & OPf_FOLDED)
4770         o->op_folded = 1;
4771
4772     o = CHECKOP(type, o);
4773     if (o->op_type != (unsigned)type)
4774         return o;
4775
4776     return fold_constants(op_integerize(op_std_init(o)));
4777 }
4778
4779 /* Constructors */
4780
4781
4782 /*
4783 =head1 Optree construction
4784
4785 =for apidoc Am|OP *|newNULLLIST
4786
4787 Constructs, checks, and returns a new C<stub> op, which represents an
4788 empty list expression.
4789
4790 =cut
4791 */
4792
4793 OP *
4794 Perl_newNULLLIST(pTHX)
4795 {
4796     return newOP(OP_STUB, 0);
4797 }
4798
4799 /* promote o and any siblings to be a list if its not already; i.e.
4800  *
4801  *  o - A - B
4802  *
4803  * becomes
4804  *
4805  *  list
4806  *    |
4807  *  pushmark - o - A - B
4808  *
4809  * If nullit it true, the list op is nulled.
4810  */
4811
4812 static OP *
4813 S_force_list(pTHX_ OP *o, bool nullit)
4814 {
4815     if (!o || o->op_type != OP_LIST) {
4816         OP *rest = NULL;
4817         if (o) {
4818             /* manually detach any siblings then add them back later */