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 #ifdef DEBUGGING
 491     size_t savestack_count = 0;
 492 #endif
 493     PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
 494     slab2 = slab;
 495     do {
 496         OPSLOT *slot;
 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)
 659                 && isIDFIRST_utf8_safe((U8 *)name+1, name + len))
 660             || (name[1] == '_' && len > 2)))
 661     {
 662         if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
 663          && isASCII(name[1])
 664          && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
 665             /* diag_listed_as: Can't use global %s in "%s" */
 666             yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
 667                               name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
 668                               PL_parser->in_my == KEY_state ? "state" : "my"));
 669         } else {
 670             yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
 671                               PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
 672         }
 673     }
 674
 675     /* allocate a spare slot and store the name in that slot */
 676
 677     off = pad_add_name_pvn(name, len,
 678                        (is_our ? padadd_OUR :
 679                         PL_parser->in_my == KEY_state ? padadd_STATE : 0),
 680                     PL_parser->in_my_stash,
 681                     (is_our
 682                         /* $_ is always in main::, even with our */
 683                         ? (PL_curstash && !memEQs(name,len,"$_")
 684                             ? PL_curstash
 685                             : PL_defstash)
 686                         : NULL
 687                     )
 688     );
 689     /* anon sub prototypes contains state vars should always be cloned,
 690      * otherwise the state var would be shared between anon subs */
 691
 692     if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
 693         CvCLONE_on(PL_compcv);
 694
 695     return off;
 696 }
 697
 698 /*
 699 =head1 Optree Manipulation Functions
 700
 701 =for apidoc alloccopstash
 702
 703 Available only under threaded builds, this function allocates an entry in
 704 C<PL_stashpad> for the stash passed to it.
 705
 706 =cut
 707 */
 708
 709 #ifdef USE_ITHREADS
 710 PADOFFSET
 711 Perl_alloccopstash(pTHX_ HV *hv)
 712 {
 713     PADOFFSET off = 0, o = 1;
 714     bool found_slot = FALSE;
 715
 716     PERL_ARGS_ASSERT_ALLOCCOPSTASH;
 717
 718     if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
 719
 720     for (; o < PL_stashpadmax; ++o) {
 721         if (PL_stashpad[o] == hv) return PL_stashpadix = o;
 722         if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
 723             found_slot = TRUE, off = o;
 724     }
 725     if (!found_slot) {
 726         Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
 727         Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
 728         off = PL_stashpadmax;
 729         PL_stashpadmax += 10;
 730     }
 731
 732     PL_stashpad[PL_stashpadix = off] = hv;
 733     return off;
 734 }
 735 #endif
 736
 737 /* free the body of an op without examining its contents.
 738  * Always use this rather than FreeOp directly */
 739
 740 static void
 741 S_op_destroy(pTHX_ OP *o)
 742 {
 743     FreeOp(o);
 744 }
 745
 746 /* Destructor */
 747
 748 /*
 749 =for apidoc Am|void|op_free|OP *o
 750
 751 Free an op.  Only use this when an op is no longer linked to from any
 752 optree.
 753
 754 =cut
 755 */
 756
 757 void
 758 Perl_op_free(pTHX_ OP *o)
 759 {
 760     dVAR;
 761     OPCODE type;
 762     SSize_t defer_ix = -1;
 763     SSize_t defer_stack_alloc = 0;
 764     OP **defer_stack = NULL;
 765
 766     do {
 767
 768         /* Though ops may be freed twice, freeing the op after its slab is a
 769            big no-no. */
 770         assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
 771         /* During the forced freeing of ops after compilation failure, kidops
 772            may be freed before their parents. */
 773         if (!o || o->op_type == OP_FREED)
 774             continue;
 775
 776         type = o->op_type;
 777
 778         /* an op should only ever acquire op_private flags that we know about.
 779          * If this fails, you may need to fix something in regen/op_private.
 780          * Don't bother testing if:
 781          *   * the op_ppaddr doesn't match the op; someone may have
 782          *     overridden the op and be doing strange things with it;
 783          *   * we've errored, as op flags are often left in an
 784          *     inconsistent state then. Note that an error when
 785          *     compiling the main program leaves PL_parser NULL, so
 786          *     we can't spot faults in the main code, only
 787          *     evaled/required code */
 788 #ifdef DEBUGGING
 789         if (   o->op_ppaddr == PL_ppaddr[o->op_type]
 790             && PL_parser
 791             && !PL_parser->error_count)
 792         {
 793             assert(!(o->op_private & ~PL_op_private_valid[type]));
 794         }
 795 #endif
 796
 797         if (o->op_private & OPpREFCOUNTED) {
 798             switch (type) {
 799             case OP_LEAVESUB:
 800             case OP_LEAVESUBLV:
 801             case OP_LEAVEEVAL:
 802             case OP_LEAVE:
 803             case OP_SCOPE:
 804             case OP_LEAVEWRITE:
 805                 {
 806                 PADOFFSET refcnt;
 807                 OP_REFCNT_LOCK;
 808                 refcnt = OpREFCNT_dec(o);
 809                 OP_REFCNT_UNLOCK;
 810                 if (refcnt) {
 811                     /* Need to find and remove any pattern match ops from the list
 812                        we maintain for reset().  */
 813                     find_and_forget_pmops(o);
 814                     continue;
 815                 }
 816                 }
 817                 break;
 818             default:
 819                 break;
 820             }
 821         }
 822
 823         /* Call the op_free hook if it has been set. Do it now so that it's called
 824          * at the right time for refcounted ops, but still before all of the kids
 825          * are freed. */
 826         CALL_OPFREEHOOK(o);
 827
 828         if (o->op_flags & OPf_KIDS) {
 829             OP *kid, *nextkid;
 830             for (kid = cUNOPo->op_first; kid; kid = nextkid) {
 831                 nextkid = OpSIBLING(kid); /* Get before next freeing kid */
 832                 if (!kid || kid->op_type == OP_FREED)
 833                     /* During the forced freeing of ops after
 834                        compilation failure, kidops may be freed before
 835                        their parents. */
 836                     continue;
 837                 if (!(kid->op_flags & OPf_KIDS))
 838                     /* If it has no kids, just free it now */
 839                     op_free(kid);
 840                 else
 841                     DEFER_OP(kid);
 842             }
 843         }
 844         if (type == OP_NULL)
 845             type = (OPCODE)o->op_targ;
 846
 847         if (o->op_slabbed)
 848             Slab_to_rw(OpSLAB(o));
 849
 850         /* COP* is not cleared by op_clear() so that we may track line
 851          * numbers etc even after null() */
 852         if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
 853             cop_free((COP*)o);
 854         }
 855
 856         op_clear(o);
 857         FreeOp(o);
 858         if (PL_op == o)
 859             PL_op = NULL;
 860     } while ( (o = POP_DEFERRED_OP()) );
 861
 862     Safefree(defer_stack);
 863 }
 864
 865 /* S_op_clear_gv(): free a GV attached to an OP */
 866
 867 STATIC
 868 #ifdef USE_ITHREADS
 869 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
 870 #else
 871 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
 872 #endif
 873 {
 874
 875     GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
 876             || o->op_type == OP_MULTIDEREF)
 877 #ifdef USE_ITHREADS
 878                 && PL_curpad
 879                 ? ((GV*)PAD_SVl(*ixp)) : NULL;
 880 #else
 881                 ? (GV*)(*svp) : NULL;
 882 #endif
 883     /* It's possible during global destruction that the GV is freed
 884        before the optree. Whilst the SvREFCNT_inc is happy to bump from
 885        0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
 886        will trigger an assertion failure, because the entry to sv_clear
 887        checks that the scalar is not already freed.  A check of for
 888        !SvIS_FREED(gv) turns out to be invalid, because during global
 889        destruction the reference count can be forced down to zero
 890        (with SVf_BREAK set).  In which case raising to 1 and then
 891        dropping to 0 triggers cleanup before it should happen.  I
 892        *think* that this might actually be a general, systematic,
 893        weakness of the whole idea of SVf_BREAK, in that code *is*
 894        allowed to raise and lower references during global destruction,
 895        so any *valid* code that happens to do this during global
 896        destruction might well trigger premature cleanup.  */
 897     bool still_valid = gv && SvREFCNT(gv);
 898
 899     if (still_valid)
 900         SvREFCNT_inc_simple_void(gv);
 901 #ifdef USE_ITHREADS
 902     if (*ixp > 0) {
 903         pad_swipe(*ixp, TRUE);
 904         *ixp = 0;
 905     }
 906 #else
 907     SvREFCNT_dec(*svp);
 908     *svp = NULL;
 909 #endif
 910     if (still_valid) {
 911         int try_downgrade = SvREFCNT(gv) == 2;
 912         SvREFCNT_dec_NN(gv);
 913         if (try_downgrade)
 914             gv_try_downgrade(gv);
 915     }
 916 }
 917
 918
 919 void
 920 Perl_op_clear(pTHX_ OP *o)
 921 {
 922
 923     dVAR;
 924
 925     PERL_ARGS_ASSERT_OP_CLEAR;
 926
 927     switch (o->op_type) {
 928     case OP_NULL:       /* Was holding old type, if any. */
 929         /* FALLTHROUGH */
 930     case OP_ENTERTRY:
 931     case OP_ENTEREVAL:  /* Was holding hints. */
 932     case OP_ARGDEFELEM: /* Was holding signature index. */
 933         o->op_targ = 0;
 934         break;
 935     default:
 936         if (!(o->op_flags & OPf_REF)
 937             || (PL_check[o->op_type] != Perl_ck_ftst))
 938             break;
 939         /* FALLTHROUGH */
 940     case OP_GVSV:
 941     case OP_GV:
 942     case OP_AELEMFAST:
 943 #ifdef USE_ITHREADS
 944             S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
 945 #else
 946             S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
 947 #endif
 948         break;
 949     case OP_METHOD_REDIR:
 950     case OP_METHOD_REDIR_SUPER:
 951 #ifdef USE_ITHREADS
 952         if (cMETHOPx(o)->op_rclass_targ) {
 953             pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
 954             cMETHOPx(o)->op_rclass_targ = 0;
 955         }
 956 #else
 957         SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
 958         cMETHOPx(o)->op_rclass_sv = NULL;
 959 #endif
 960     case OP_METHOD_NAMED:
 961     case OP_METHOD_SUPER:
 962         SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
 963         cMETHOPx(o)->op_u.op_meth_sv = NULL;
 964 #ifdef USE_ITHREADS
 965         if (o->op_targ) {
 966             pad_swipe(o->op_targ, 1);
 967             o->op_targ = 0;
 968         }
 969 #endif
 970         break;
 971     case OP_CONST:
 972     case OP_HINTSEVAL:
 973         SvREFCNT_dec(cSVOPo->op_sv);
 974         cSVOPo->op_sv = NULL;
 975 #ifdef USE_ITHREADS
 976         /** Bug #15654
 977           Even if op_clear does a pad_free for the target of the op,
 978           pad_free doesn't actually remove the sv that exists in the pad;
 979           instead it lives on. This results in that it could be reused as
 980           a target later on when the pad was reallocated.
 981         **/
 982         if(o->op_targ) {
 983           pad_swipe(o->op_targ,1);
 984           o->op_targ = 0;
 985         }
 986 #endif
 987         break;
 988     case OP_DUMP:
 989     case OP_GOTO:
 990     case OP_NEXT:
 991     case OP_LAST:
 992     case OP_REDO:
 993         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
 994             break;
 995         /* FALLTHROUGH */
 996     case OP_TRANS:
 997     case OP_TRANSR:
 998         if (   (o->op_type == OP_TRANS || o->op_type == OP_TRANSR)
 999             && (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)))
1000         {
1001 #ifdef USE_ITHREADS
1002             if (cPADOPo->op_padix > 0) {
1003                 pad_swipe(cPADOPo->op_padix, TRUE);
1004                 cPADOPo->op_padix = 0;
1005             }
1006 #else
1007             SvREFCNT_dec(cSVOPo->op_sv);
1008             cSVOPo->op_sv = NULL;
1009 #endif
1010         }
1011         else {
1012             PerlMemShared_free(cPVOPo->op_pv);
1013             cPVOPo->op_pv = NULL;
1014         }
1015         break;
1016     case OP_SUBST:
1017         op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
1018         goto clear_pmop;
1019
1020     case OP_SPLIT:
1021         if (     (o->op_private & OPpSPLIT_ASSIGN) /* @array  = split */
1022             && !(o->op_flags & OPf_STACKED))       /* @{expr} = split */
1023         {
1024             if (o->op_private & OPpSPLIT_LEX)
1025                 pad_free(cPMOPo->op_pmreplrootu.op_pmtargetoff);
1026             else
1027 #ifdef USE_ITHREADS
1028                 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
1029 #else
1030                 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
1031 #endif
1032         }
1033         /* FALLTHROUGH */
1034     case OP_MATCH:
1035     case OP_QR:
1036     clear_pmop:
1037         if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
1038             op_free(cPMOPo->op_code_list);
1039         cPMOPo->op_code_list = NULL;
1040         forget_pmop(cPMOPo);
1041         cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
1042         /* we use the same protection as the "SAFE" version of the PM_ macros
1043          * here since sv_clean_all might release some PMOPs
1044          * after PL_regex_padav has been cleared
1045          * and the clearing of PL_regex_padav needs to
1046          * happen before sv_clean_all
1047          */
1048 #ifdef USE_ITHREADS
1049         if(PL_regex_pad) {        /* We could be in destruction */
1050             const IV offset = (cPMOPo)->op_pmoffset;
1051             ReREFCNT_dec(PM_GETRE(cPMOPo));
1052             PL_regex_pad[offset] = &PL_sv_undef;
1053             sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
1054                            sizeof(offset));
1055         }
1056 #else
1057         ReREFCNT_dec(PM_GETRE(cPMOPo));
1058         PM_SETRE(cPMOPo, NULL);
1059 #endif
1060
1061         break;
1062
1063     case OP_ARGCHECK:
1064         PerlMemShared_free(cUNOP_AUXo->op_aux);
1065         break;
1066
1067     case OP_MULTIDEREF:
1068         {
1069             UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1070             UV actions = items->uv;
1071             bool last = 0;
1072             bool is_hash = FALSE;
1073
1074             while (!last) {
1075                 switch (actions & MDEREF_ACTION_MASK) {
1076
1077                 case MDEREF_reload:
1078                     actions = (++items)->uv;
1079                     continue;
1080
1081                 case MDEREF_HV_padhv_helem:
1082                     is_hash = TRUE;
1083                 case MDEREF_AV_padav_aelem:
1084                     pad_free((++items)->pad_offset);
1085                     goto do_elem;
1086
1087                 case MDEREF_HV_gvhv_helem:
1088                     is_hash = TRUE;
1089                 case MDEREF_AV_gvav_aelem:
1090 #ifdef USE_ITHREADS
1091                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1092 #else
1093                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1094 #endif
1095                     goto do_elem;
1096
1097                 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1098                     is_hash = TRUE;
1099                 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1100 #ifdef USE_ITHREADS
1101                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1102 #else
1103                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1104 #endif
1105                     goto do_vivify_rv2xv_elem;
1106
1107                 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1108                     is_hash = TRUE;
1109                 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1110                     pad_free((++items)->pad_offset);
1111                     goto do_vivify_rv2xv_elem;
1112
1113                 case MDEREF_HV_pop_rv2hv_helem:
1114                 case MDEREF_HV_vivify_rv2hv_helem:
1115                     is_hash = TRUE;
1116                 do_vivify_rv2xv_elem:
1117                 case MDEREF_AV_pop_rv2av_aelem:
1118                 case MDEREF_AV_vivify_rv2av_aelem:
1119                 do_elem:
1120                     switch (actions & MDEREF_INDEX_MASK) {
1121                     case MDEREF_INDEX_none:
1122                         last = 1;
1123                         break;
1124                     case MDEREF_INDEX_const:
1125                         if (is_hash) {
1126 #ifdef USE_ITHREADS
1127                             /* see RT #15654 */
1128                             pad_swipe((++items)->pad_offset, 1);
1129 #else
1130                             SvREFCNT_dec((++items)->sv);
1131 #endif
1132                         }
1133                         else
1134                             items++;
1135                         break;
1136                     case MDEREF_INDEX_padsv:
1137                         pad_free((++items)->pad_offset);
1138                         break;
1139                     case MDEREF_INDEX_gvsv:
1140 #ifdef USE_ITHREADS
1141                         S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1142 #else
1143                         S_op_clear_gv(aTHX_ o, &((++items)->sv));
1144 #endif
1145                         break;
1146                     }
1147
1148                     if (actions & MDEREF_FLAG_last)
1149                         last = 1;
1150                     is_hash = FALSE;
1151
1152                     break;
1153
1154                 default:
1155                     assert(0);
1156                     last = 1;
1157                     break;
1158
1159                 } /* switch */
1160
1161                 actions >>= MDEREF_SHIFT;
1162             } /* while */
1163
1164             /* start of malloc is at op_aux[-1], where the length is
1165              * stored */
1166             PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1167         }
1168         break;
1169     }
1170
1171     if (o->op_targ > 0) {
1172         pad_free(o->op_targ);
1173         o->op_targ = 0;
1174     }
1175 }
1176
1177 STATIC void
1178 S_cop_free(pTHX_ COP* cop)
1179 {
1180     PERL_ARGS_ASSERT_COP_FREE;
1181
1182     CopFILE_free(cop);
1183     if (! specialWARN(cop->cop_warnings))
1184         PerlMemShared_free(cop->cop_warnings);
1185     cophh_free(CopHINTHASH_get(cop));
1186     if (PL_curcop == cop)
1187        PL_curcop = NULL;
1188 }
1189
1190 STATIC void
1191 S_forget_pmop(pTHX_ PMOP *const o
1192               )
1193 {
1194     HV * const pmstash = PmopSTASH(o);
1195
1196     PERL_ARGS_ASSERT_FORGET_PMOP;
1197
1198     if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1199         MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1200         if (mg) {
1201             PMOP **const array = (PMOP**) mg->mg_ptr;
1202             U32 count = mg->mg_len / sizeof(PMOP**);
1203             U32 i = count;
1204
1205             while (i--) {
1206                 if (array[i] == o) {
1207                     /* Found it. Move the entry at the end to overwrite it.  */
1208                     array[i] = array[--count];
1209                     mg->mg_len = count * sizeof(PMOP**);
1210                     /* Could realloc smaller at this point always, but probably
1211                        not worth it. Probably worth free()ing if we're the
1212                        last.  */
1213                     if(!count) {
1214                         Safefree(mg->mg_ptr);
1215                         mg->mg_ptr = NULL;
1216                     }
1217                     break;
1218                 }
1219             }
1220         }
1221     }
1222     if (PL_curpm == o)
1223         PL_curpm = NULL;
1224 }
1225
1226 STATIC void
1227 S_find_and_forget_pmops(pTHX_ OP *o)
1228 {
1229     PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1230
1231     if (o->op_flags & OPf_KIDS) {
1232         OP *kid = cUNOPo->op_first;
1233         while (kid) {
1234             switch (kid->op_type) {
1235             case OP_SUBST:
1236             case OP_SPLIT:
1237             case OP_MATCH:
1238             case OP_QR:
1239                 forget_pmop((PMOP*)kid);
1240             }
1241             find_and_forget_pmops(kid);
1242             kid = OpSIBLING(kid);
1243         }
1244     }
1245 }
1246
1247 /*
1248 =for apidoc Am|void|op_null|OP *o
1249
1250 Neutralizes an op when it is no longer needed, but is still linked to from
1251 other ops.
1252
1253 =cut
1254 */
1255
1256 void
1257 Perl_op_null(pTHX_ OP *o)
1258 {
1259     dVAR;
1260
1261     PERL_ARGS_ASSERT_OP_NULL;
1262
1263     if (o->op_type == OP_NULL)
1264         return;
1265     op_clear(o);
1266     o->op_targ = o->op_type;
1267     OpTYPE_set(o, OP_NULL);
1268 }
1269
1270 void
1271 Perl_op_refcnt_lock(pTHX)
1272   PERL_TSA_ACQUIRE(PL_op_mutex)
1273 {
1274 #ifdef USE_ITHREADS
1275     dVAR;
1276 #endif
1277     PERL_UNUSED_CONTEXT;
1278     OP_REFCNT_LOCK;
1279 }
1280
1281 void
1282 Perl_op_refcnt_unlock(pTHX)
1283   PERL_TSA_RELEASE(PL_op_mutex)
1284 {
1285 #ifdef USE_ITHREADS
1286     dVAR;
1287 #endif
1288     PERL_UNUSED_CONTEXT;
1289     OP_REFCNT_UNLOCK;
1290 }
1291
1292
1293 /*
1294 =for apidoc op_sibling_splice
1295
1296 A general function for editing the structure of an existing chain of
1297 op_sibling nodes.  By analogy with the perl-level C<splice()> function, allows
1298 you to delete zero or more sequential nodes, replacing them with zero or
1299 more different nodes.  Performs the necessary op_first/op_last
1300 housekeeping on the parent node and op_sibling manipulation on the
1301 children.  The last deleted node will be marked as as the last node by
1302 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1303
1304 Note that op_next is not manipulated, and nodes are not freed; that is the
1305 responsibility of the caller.  It also won't create a new list op for an
1306 empty list etc; use higher-level functions like op_append_elem() for that.
1307
1308 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1309 the splicing doesn't affect the first or last op in the chain.
1310
1311 C<start> is the node preceding the first node to be spliced.  Node(s)
1312 following it will be deleted, and ops will be inserted after it.  If it is
1313 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1314 beginning.
1315
1316 C<del_count> is the number of nodes to delete.  If zero, no nodes are deleted.
1317 If -1 or greater than or equal to the number of remaining kids, all
1318 remaining kids are deleted.
1319
1320 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1321 If C<NULL>, no nodes are inserted.
1322
1323 The head of the chain of deleted ops is returned, or C<NULL> if no ops were
1324 deleted.
1325
1326 For example:
1327
1328     action                    before      after         returns
1329     ------                    -----       -----         -------
1330
1331                               P           P
1332     splice(P, A, 2, X-Y-Z)    |           |             B-C
1333                               A-B-C-D     A-X-Y-Z-D
1334
1335                               P           P
1336     splice(P, NULL, 1, X-Y)   |           |             A
1337                               A-B-C-D     X-Y-B-C-D
1338
1339                               P           P
1340     splice(P, NULL, 3, NULL)  |           |             A-B-C
1341                               A-B-C-D     D
1342
1343                               P           P
1344     splice(P, B, 0, X-Y)      |           |             NULL
1345                               A-B-C-D     A-B-X-Y-C-D
1346
1347
1348 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1349 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
1350
1351 =cut
1352 */
1353
1354 OP *
1355 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1356 {
1357     OP *first;
1358     OP *rest;
1359     OP *last_del = NULL;
1360     OP *last_ins = NULL;
1361
1362     if (start)
1363         first = OpSIBLING(start);
1364     else if (!parent)
1365         goto no_parent;
1366     else
1367         first = cLISTOPx(parent)->op_first;
1368
1369     assert(del_count >= -1);
1370
1371     if (del_count && first) {
1372         last_del = first;
1373         while (--del_count && OpHAS_SIBLING(last_del))
1374             last_del = OpSIBLING(last_del);
1375         rest = OpSIBLING(last_del);
1376         OpLASTSIB_set(last_del, NULL);
1377     }
1378     else
1379         rest = first;
1380
1381     if (insert) {
1382         last_ins = insert;
1383         while (OpHAS_SIBLING(last_ins))
1384             last_ins = OpSIBLING(last_ins);
1385         OpMAYBESIB_set(last_ins, rest, NULL);
1386     }
1387     else
1388         insert = rest;
1389
1390     if (start) {
1391         OpMAYBESIB_set(start, insert, NULL);
1392     }
1393     else {
1394         if (!parent)
1395             goto no_parent;
1396         cLISTOPx(parent)->op_first = insert;
1397         if (insert)
1398             parent->op_flags |= OPf_KIDS;
1399         else
1400             parent->op_flags &= ~OPf_KIDS;
1401     }
1402
1403     if (!rest) {
1404         /* update op_last etc */
1405         U32 type;
1406         OP *lastop;
1407
1408         if (!parent)
1409             goto no_parent;
1410
1411         /* ought to use OP_CLASS(parent) here, but that can't handle
1412          * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1413          * either */
1414         type = parent->op_type;
1415         if (type == OP_CUSTOM) {
1416             dTHX;
1417             type = XopENTRYCUSTOM(parent, xop_class);
1418         }
1419         else {
1420             if (type == OP_NULL)
1421                 type = parent->op_targ;
1422             type = PL_opargs[type] & OA_CLASS_MASK;
1423         }
1424
1425         lastop = last_ins ? last_ins : start ? start : NULL;
1426         if (   type == OA_BINOP
1427             || type == OA_LISTOP
1428             || type == OA_PMOP
1429             || type == OA_LOOP
1430         )
1431             cLISTOPx(parent)->op_last = lastop;
1432
1433         if (lastop)
1434             OpLASTSIB_set(lastop, parent);
1435     }
1436     return last_del ? first : NULL;
1437
1438   no_parent:
1439     Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1440 }
1441
1442
1443 #ifdef PERL_OP_PARENT
1444
1445 /*
1446 =for apidoc op_parent
1447
1448 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1449 This function is only available on perls built with C<-DPERL_OP_PARENT>.
1450
1451 =cut
1452 */
1453
1454 OP *
1455 Perl_op_parent(OP *o)
1456 {
1457     PERL_ARGS_ASSERT_OP_PARENT;
1458     while (OpHAS_SIBLING(o))
1459         o = OpSIBLING(o);
1460     return o->op_sibparent;
1461 }
1462
1463 #endif
1464
1465
1466 /* replace the sibling following start with a new UNOP, which becomes
1467  * the parent of the original sibling; e.g.
1468  *
1469  *  op_sibling_newUNOP(P, A, unop-args...)
1470  *
1471  *  P              P
1472  *  |      becomes |
1473  *  A-B-C          A-U-C
1474  *                   |
1475  *                   B
1476  *
1477  * where U is the new UNOP.
1478  *
1479  * parent and start args are the same as for op_sibling_splice();
1480  * type and flags args are as newUNOP().
1481  *
1482  * Returns the new UNOP.
1483  */
1484
1485 STATIC OP *
1486 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1487 {
1488     OP *kid, *newop;
1489
1490     kid = op_sibling_splice(parent, start, 1, NULL);
1491     newop = newUNOP(type, flags, kid);
1492     op_sibling_splice(parent, start, 0, newop);
1493     return newop;
1494 }
1495
1496
1497 /* lowest-level newLOGOP-style function - just allocates and populates
1498  * the struct. Higher-level stuff should be done by S_new_logop() /
1499  * newLOGOP(). This function exists mainly to avoid op_first assignment
1500  * being spread throughout this file.
1501  */
1502
1503 LOGOP *
1504 Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1505 {
1506     dVAR;
1507     LOGOP *logop;
1508     OP *kid = first;
1509     NewOp(1101, logop, 1, LOGOP);
1510     OpTYPE_set(logop, type);
1511     logop->op_first = first;
1512     logop->op_other = other;
1513     logop->op_flags = OPf_KIDS;
1514     while (kid && OpHAS_SIBLING(kid))
1515         kid = OpSIBLING(kid);
1516     if (kid)
1517         OpLASTSIB_set(kid, (OP*)logop);
1518     return logop;
1519 }
1520
1521
1522 /* Contextualizers */
1523
1524 /*
1525 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1526
1527 Applies a syntactic context to an op tree representing an expression.
1528 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
1529 or C<G_VOID> to specify the context to apply.  The modified op tree
1530 is returned.
1531
1532 =cut
1533 */
1534
1535 OP *
1536 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1537 {
1538     PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1539     switch (context) {
1540         case G_SCALAR: return scalar(o);
1541         case G_ARRAY:  return list(o);
1542         case G_VOID:   return scalarvoid(o);
1543         default:
1544             Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1545                        (long) context);
1546     }
1547 }
1548
1549 /*
1550
1551 =for apidoc Am|OP*|op_linklist|OP *o
1552 This function is the implementation of the L</LINKLIST> macro.  It should
1553 not be called directly.
1554
1555 =cut
1556 */
1557
1558 OP *
1559 Perl_op_linklist(pTHX_ OP *o)
1560 {
1561     OP *first;
1562
1563     PERL_ARGS_ASSERT_OP_LINKLIST;
1564
1565     if (o->op_next)
1566         return o->op_next;
1567
1568     /* establish postfix order */
1569     first = cUNOPo->op_first;
1570     if (first) {
1571         OP *kid;
1572         o->op_next = LINKLIST(first);
1573         kid = first;
1574         for (;;) {
1575             OP *sibl = OpSIBLING(kid);
1576             if (sibl) {
1577                 kid->op_next = LINKLIST(sibl);
1578                 kid = sibl;
1579             } else {
1580                 kid->op_next = o;
1581                 break;
1582             }
1583         }
1584     }
1585     else
1586         o->op_next = o;
1587
1588     return o->op_next;
1589 }
1590
1591 static OP *
1592 S_scalarkids(pTHX_ OP *o)
1593 {
1594     if (o && o->op_flags & OPf_KIDS) {
1595         OP *kid;
1596         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1597             scalar(kid);
1598     }
1599     return o;
1600 }
1601
1602 STATIC OP *
1603 S_scalarboolean(pTHX_ OP *o)
1604 {
1605     PERL_ARGS_ASSERT_SCALARBOOLEAN;
1606
1607     if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1608          !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1609         (o->op_type == OP_NOT     && cUNOPo->op_first->op_type == OP_SASSIGN &&
1610          cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1611          !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
1612         if (ckWARN(WARN_SYNTAX)) {
1613             const line_t oldline = CopLINE(PL_curcop);
1614
1615             if (PL_parser && PL_parser->copline != NOLINE) {
1616                 /* This ensures that warnings are reported at the first line
1617                    of the conditional, not the last.  */
1618                 CopLINE_set(PL_curcop, PL_parser->copline);
1619             }
1620             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1621             CopLINE_set(PL_curcop, oldline);
1622         }
1623     }
1624     return scalar(o);
1625 }
1626
1627 static SV *
1628 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1629 {
1630     assert(o);
1631     assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1632            o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1633     {
1634         const char funny  = o->op_type == OP_PADAV
1635                          || o->op_type == OP_RV2AV ? '@' : '%';
1636         if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1637             GV *gv;
1638             if (cUNOPo->op_first->op_type != OP_GV
1639              || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1640                 return NULL;
1641             return varname(gv, funny, 0, NULL, 0, subscript_type);
1642         }
1643         return
1644             varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1645     }
1646 }
1647
1648 static SV *
1649 S_op_varname(pTHX_ const OP *o)
1650 {
1651     return S_op_varname_subscript(aTHX_ o, 1);
1652 }
1653
1654 static void
1655 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1656 { /* or not so pretty :-) */
1657     if (o->op_type == OP_CONST) {
1658         *retsv = cSVOPo_sv;
1659         if (SvPOK(*retsv)) {
1660             SV *sv = *retsv;
1661             *retsv = sv_newmortal();
1662             pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1663                       PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1664         }
1665         else if (!SvOK(*retsv))
1666             *retpv = "undef";
1667     }
1668     else *retpv = "...";
1669 }
1670
1671 static void
1672 S_scalar_slice_warning(pTHX_ const OP *o)
1673 {
1674     OP *kid;
1675     const bool h = o->op_type == OP_HSLICE
1676                 || (o->op_type == OP_NULL && o->op_targ == OP_HSLICE);
1677     const char lbrack =
1678         h ? '{' : '[';
1679     const char rbrack =
1680         h ? '}' : ']';
1681     SV *name;
1682     SV *keysv = NULL; /* just to silence compiler warnings */
1683     const char *key = NULL;
1684
1685     if (!(o->op_private & OPpSLICEWARNING))
1686         return;
1687     if (PL_parser && PL_parser->error_count)
1688         /* This warning can be nonsensical when there is a syntax error. */
1689         return;
1690
1691     kid = cLISTOPo->op_first;
1692     kid = OpSIBLING(kid); /* get past pushmark */
1693     /* weed out false positives: any ops that can return lists */
1694     switch (kid->op_type) {
1695     case OP_BACKTICK:
1696     case OP_GLOB:
1697     case OP_READLINE:
1698     case OP_MATCH:
1699     case OP_RV2AV:
1700     case OP_EACH:
1701     case OP_VALUES:
1702     case OP_KEYS:
1703     case OP_SPLIT:
1704     case OP_LIST:
1705     case OP_SORT:
1706     case OP_REVERSE:
1707     case OP_ENTERSUB:
1708     case OP_CALLER:
1709     case OP_LSTAT:
1710     case OP_STAT:
1711     case OP_READDIR:
1712     case OP_SYSTEM:
1713     case OP_TMS:
1714     case OP_LOCALTIME:
1715     case OP_GMTIME:
1716     case OP_ENTEREVAL:
1717         return;
1718     }
1719
1720     /* Don't warn if we have a nulled list either. */
1721     if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1722         return;
1723
1724     assert(OpSIBLING(kid));
1725     name = S_op_varname(aTHX_ OpSIBLING(kid));
1726     if (!name) /* XS module fiddling with the op tree */
1727         return;
1728     S_op_pretty(aTHX_ kid, &keysv, &key);
1729     assert(SvPOK(name));
1730     sv_chop(name,SvPVX(name)+1);
1731     if (key)
1732        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1733         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1734                    "Scalar value @%" SVf "%c%s%c better written as $%" SVf
1735                    "%c%s%c",
1736                     SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1737                     lbrack, key, rbrack);
1738     else
1739        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1740         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1741                    "Scalar value @%" SVf "%c%" SVf "%c better written as $%"
1742                     SVf "%c%" SVf "%c",
1743                     SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1744                     SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1745 }
1746
1747 OP *
1748 Perl_scalar(pTHX_ OP *o)
1749 {
1750     OP *kid;
1751
1752     /* assumes no premature commitment */
1753     if (!o || (PL_parser && PL_parser->error_count)
1754          || (o->op_flags & OPf_WANT)
1755          || o->op_type == OP_RETURN)
1756     {
1757         return o;
1758     }
1759
1760     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1761
1762     switch (o->op_type) {
1763     case OP_REPEAT:
1764         scalar(cBINOPo->op_first);
1765         if (o->op_private & OPpREPEAT_DOLIST) {
1766             kid = cLISTOPx(cUNOPo->op_first)->op_first;
1767             assert(kid->op_type == OP_PUSHMARK);
1768             if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1769                 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1770                 o->op_private &=~ OPpREPEAT_DOLIST;
1771             }
1772         }
1773         break;
1774     case OP_OR:
1775     case OP_AND:
1776     case OP_COND_EXPR:
1777         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
1778             scalar(kid);
1779         break;
1780         /* FALLTHROUGH */
1781     case OP_SPLIT:
1782     case OP_MATCH:
1783     case OP_QR:
1784     case OP_SUBST:
1785     case OP_NULL:
1786     default:
1787         if (o->op_flags & OPf_KIDS) {
1788             for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1789                 scalar(kid);
1790         }
1791         break;
1792     case OP_LEAVE:
1793     case OP_LEAVETRY:
1794         kid = cLISTOPo->op_first;
1795         scalar(kid);
1796         kid = OpSIBLING(kid);
1797     do_kids:
1798         while (kid) {
1799             OP *sib = OpSIBLING(kid);
1800             if (sib && kid->op_type != OP_LEAVEWHEN
1801              && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
1802                 || (  sib->op_targ != OP_NEXTSTATE
1803                    && sib->op_targ != OP_DBSTATE  )))
1804                 scalarvoid(kid);
1805             else
1806                 scalar(kid);
1807             kid = sib;
1808         }
1809         PL_curcop = &PL_compiling;
1810         break;
1811     case OP_SCOPE:
1812     case OP_LINESEQ:
1813     case OP_LIST:
1814         kid = cLISTOPo->op_first;
1815         goto do_kids;
1816     case OP_SORT:
1817         Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1818         break;
1819     case OP_KVHSLICE:
1820     case OP_KVASLICE:
1821     {
1822         /* Warn about scalar context */
1823         const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1824         const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1825         SV *name;
1826         SV *keysv;
1827         const char *key = NULL;
1828
1829         /* This warning can be nonsensical when there is a syntax error. */
1830         if (PL_parser && PL_parser->error_count)
1831             break;
1832
1833         if (!ckWARN(WARN_SYNTAX)) break;
1834
1835         kid = cLISTOPo->op_first;
1836         kid = OpSIBLING(kid); /* get past pushmark */
1837         assert(OpSIBLING(kid));
1838         name = S_op_varname(aTHX_ OpSIBLING(kid));
1839         if (!name) /* XS module fiddling with the op tree */
1840             break;
1841         S_op_pretty(aTHX_ kid, &keysv, &key);
1842         assert(SvPOK(name));
1843         sv_chop(name,SvPVX(name)+1);
1844         if (key)
1845   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1846             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1847                        "%%%" SVf "%c%s%c in scalar context better written "
1848                        "as $%" SVf "%c%s%c",
1849                         SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1850                         lbrack, key, rbrack);
1851         else
1852   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1853             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1854                        "%%%" SVf "%c%" SVf "%c in scalar context better "
1855                        "written as $%" SVf "%c%" SVf "%c",
1856                         SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1857                         SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1858     }
1859     }
1860     return o;
1861 }
1862
1863 OP *
1864 Perl_scalarvoid(pTHX_ OP *arg)
1865 {
1866     dVAR;
1867     OP *kid;
1868     SV* sv;
1869     SSize_t defer_stack_alloc = 0;
1870     SSize_t defer_ix = -1;
1871     OP **defer_stack = NULL;
1872     OP *o = arg;
1873
1874     PERL_ARGS_ASSERT_SCALARVOID;
1875
1876     do {
1877         U8 want;
1878         SV *useless_sv = NULL;
1879         const char* useless = NULL;
1880
1881         if (o->op_type == OP_NEXTSTATE
1882             || o->op_type == OP_DBSTATE
1883             || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1884                                           || o->op_targ == OP_DBSTATE)))
1885             PL_curcop = (COP*)o;                /* for warning below */
1886
1887         /* assumes no premature commitment */
1888         want = o->op_flags & OPf_WANT;
1889         if ((want && want != OPf_WANT_SCALAR)
1890             || (PL_parser && PL_parser->error_count)
1891             || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1892         {
1893             continue;
1894         }
1895
1896         if ((o->op_private & OPpTARGET_MY)
1897             && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1898         {
1899             /* newASSIGNOP has already applied scalar context, which we
1900                leave, as if this op is inside SASSIGN.  */
1901             continue;
1902         }
1903
1904         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1905
1906         switch (o->op_type) {
1907         default:
1908             if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1909                 break;
1910             /* FALLTHROUGH */
1911         case OP_REPEAT:
1912             if (o->op_flags & OPf_STACKED)
1913                 break;
1914             if (o->op_type == OP_REPEAT)
1915                 scalar(cBINOPo->op_first);
1916             goto func_ops;
1917         case OP_SUBSTR:
1918             if (o->op_private == 4)
1919                 break;
1920             /* FALLTHROUGH */
1921         case OP_WANTARRAY:
1922         case OP_GV:
1923         case OP_SMARTMATCH:
1924         case OP_AV2ARYLEN:
1925         case OP_REF:
1926         case OP_REFGEN:
1927         case OP_SREFGEN:
1928         case OP_DEFINED:
1929         case OP_HEX:
1930         case OP_OCT:
1931         case OP_LENGTH:
1932         case OP_VEC:
1933         case OP_INDEX:
1934         case OP_RINDEX:
1935         case OP_SPRINTF:
1936         case OP_KVASLICE:
1937         case OP_KVHSLICE:
1938         case OP_UNPACK:
1939         case OP_PACK:
1940         case OP_JOIN:
1941         case OP_LSLICE:
1942         case OP_ANONLIST:
1943         case OP_ANONHASH:
1944         case OP_SORT:
1945         case OP_REVERSE:
1946         case OP_RANGE:
1947         case OP_FLIP:
1948         case OP_FLOP:
1949         case OP_CALLER:
1950         case OP_FILENO:
1951         case OP_EOF:
1952         case OP_TELL:
1953         case OP_GETSOCKNAME:
1954         case OP_GETPEERNAME:
1955         case OP_READLINK:
1956         case OP_TELLDIR:
1957         case OP_GETPPID:
1958         case OP_GETPGRP:
1959         case OP_GETPRIORITY:
1960         case OP_TIME:
1961         case OP_TMS:
1962         case OP_LOCALTIME:
1963         case OP_GMTIME:
1964         case OP_GHBYNAME:
1965         case OP_GHBYADDR:
1966         case OP_GHOSTENT:
1967         case OP_GNBYNAME:
1968         case OP_GNBYADDR:
1969         case OP_GNETENT:
1970         case OP_GPBYNAME:
1971         case OP_GPBYNUMBER:
1972         case OP_GPROTOENT:
1973         case OP_GSBYNAME:
1974         case OP_GSBYPORT:
1975         case OP_GSERVENT:
1976         case OP_GPWNAM:
1977         case OP_GPWUID:
1978         case OP_GGRNAM:
1979         case OP_GGRGID:
1980         case OP_GETLOGIN:
1981         case OP_PROTOTYPE:
1982         case OP_RUNCV:
1983         func_ops:
1984             useless = OP_DESC(o);
1985             break;
1986
1987         case OP_GVSV:
1988         case OP_PADSV:
1989         case OP_PADAV:
1990         case OP_PADHV:
1991         case OP_PADANY:
1992         case OP_AELEM:
1993         case OP_AELEMFAST:
1994         case OP_AELEMFAST_LEX:
1995         case OP_ASLICE:
1996         case OP_HELEM:
1997         case OP_HSLICE:
1998             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1999                 /* Otherwise it's "Useless use of grep iterator" */
2000                 useless = OP_DESC(o);
2001             break;
2002
2003         case OP_SPLIT:
2004             if (!(o->op_private & OPpSPLIT_ASSIGN))
2005                 useless = OP_DESC(o);
2006             break;
2007
2008         case OP_NOT:
2009             kid = cUNOPo->op_first;
2010             if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2011                 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2012                 goto func_ops;
2013             }
2014             useless = "negative pattern binding (!~)";
2015             break;
2016
2017         case OP_SUBST:
2018             if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2019                 useless = "non-destructive substitution (s///r)";
2020             break;
2021
2022         case OP_TRANSR:
2023             useless = "non-destructive transliteration (tr///r)";
2024             break;
2025
2026         case OP_RV2GV:
2027         case OP_RV2SV:
2028         case OP_RV2AV:
2029         case OP_RV2HV:
2030             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
2031                 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
2032                 useless = "a variable";
2033             break;
2034
2035         case OP_CONST:
2036             sv = cSVOPo_sv;
2037             if (cSVOPo->op_private & OPpCONST_STRICT)
2038                 no_bareword_allowed(o);
2039             else {
2040                 if (ckWARN(WARN_VOID)) {
2041                     NV nv;
2042                     /* don't warn on optimised away booleans, eg
2043                      * use constant Foo, 5; Foo || print; */
2044                     if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2045                         useless = NULL;
2046                     /* the constants 0 and 1 are permitted as they are
2047                        conventionally used as dummies in constructs like
2048                        1 while some_condition_with_side_effects;  */
2049                     else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2050                         useless = NULL;
2051                     else if (SvPOK(sv)) {
2052                         SV * const dsv = newSVpvs("");
2053                         useless_sv
2054                             = Perl_newSVpvf(aTHX_
2055                                             "a constant (%s)",
2056                                             pv_pretty(dsv, SvPVX_const(sv),
2057                                                       SvCUR(sv), 32, NULL, NULL,
2058                                                       PERL_PV_PRETTY_DUMP
2059                                                       | PERL_PV_ESCAPE_NOCLEAR
2060                                                       | PERL_PV_ESCAPE_UNI_DETECT));
2061                         SvREFCNT_dec_NN(dsv);
2062                     }
2063                     else if (SvOK(sv)) {
2064                         useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv));
2065                     }
2066                     else
2067                         useless = "a constant (undef)";
2068                 }
2069             }
2070             op_null(o);         /* don't execute or even remember it */
2071             break;
2072
2073         case OP_POSTINC:
2074             OpTYPE_set(o, OP_PREINC);  /* pre-increment is faster */
2075             break;
2076
2077         case OP_POSTDEC:
2078             OpTYPE_set(o, OP_PREDEC);  /* pre-decrement is faster */
2079             break;
2080
2081         case OP_I_POSTINC:
2082             OpTYPE_set(o, OP_I_PREINC);        /* pre-increment is faster */
2083             break;
2084
2085         case OP_I_POSTDEC:
2086             OpTYPE_set(o, OP_I_PREDEC);        /* pre-decrement is faster */
2087             break;
2088
2089         case OP_SASSIGN: {
2090             OP *rv2gv;
2091             UNOP *refgen, *rv2cv;
2092             LISTOP *exlist;
2093
2094             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2095                 break;
2096
2097             rv2gv = ((BINOP *)o)->op_last;
2098             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2099                 break;
2100
2101             refgen = (UNOP *)((BINOP *)o)->op_first;
2102
2103             if (!refgen || (refgen->op_type != OP_REFGEN
2104                             && refgen->op_type != OP_SREFGEN))
2105                 break;
2106
2107             exlist = (LISTOP *)refgen->op_first;
2108             if (!exlist || exlist->op_type != OP_NULL
2109                 || exlist->op_targ != OP_LIST)
2110                 break;
2111
2112             if (exlist->op_first->op_type != OP_PUSHMARK
2113                 && exlist->op_first != exlist->op_last)
2114                 break;
2115
2116             rv2cv = (UNOP*)exlist->op_last;
2117
2118             if (rv2cv->op_type != OP_RV2CV)
2119                 break;
2120
2121             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2122             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2123             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2124
2125             o->op_private |= OPpASSIGN_CV_TO_GV;
2126             rv2gv->op_private |= OPpDONT_INIT_GV;
2127             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2128
2129             break;
2130         }
2131
2132         case OP_AASSIGN: {
2133             inplace_aassign(o);
2134             break;
2135         }
2136
2137         case OP_OR:
2138         case OP_AND:
2139             kid = cLOGOPo->op_first;
2140             if (kid->op_type == OP_NOT
2141                 && (kid->op_flags & OPf_KIDS)) {
2142                 if (o->op_type == OP_AND) {
2143                     OpTYPE_set(o, OP_OR);
2144                 } else {
2145                     OpTYPE_set(o, OP_AND);
2146                 }
2147                 op_null(kid);
2148             }
2149             /* FALLTHROUGH */
2150
2151         case OP_DOR:
2152         case OP_COND_EXPR:
2153         case OP_ENTERGIVEN:
2154         case OP_ENTERWHEN:
2155             for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2156                 if (!(kid->op_flags & OPf_KIDS))
2157                     scalarvoid(kid);
2158                 else
2159                     DEFER_OP(kid);
2160         break;
2161
2162         case OP_NULL:
2163             if (o->op_flags & OPf_STACKED)
2164                 break;
2165             /* FALLTHROUGH */
2166         case OP_NEXTSTATE:
2167         case OP_DBSTATE:
2168         case OP_ENTERTRY:
2169         case OP_ENTER:
2170             if (!(o->op_flags & OPf_KIDS))
2171                 break;
2172             /* FALLTHROUGH */
2173         case OP_SCOPE:
2174         case OP_LEAVE:
2175         case OP_LEAVETRY:
2176         case OP_LEAVELOOP:
2177         case OP_LINESEQ:
2178         case OP_LEAVEGIVEN:
2179         case OP_LEAVEWHEN:
2180         kids:
2181             for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2182                 if (!(kid->op_flags & OPf_KIDS))
2183                     scalarvoid(kid);
2184                 else
2185                     DEFER_OP(kid);
2186             break;
2187         case OP_LIST:
2188             /* If the first kid after pushmark is something that the padrange
2189                optimisation would reject, then null the list and the pushmark.
2190             */
2191             if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
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                       || !(kid = OpSIBLING(kid))
2198                       || (  kid->op_type != OP_PADSV
2199                             && kid->op_type != OP_PADAV
2200                             && kid->op_type != OP_PADHV)
2201                       || kid->op_private & ~OPpLVAL_INTRO)
2202             ) {
2203                 op_null(cUNOPo->op_first); /* NULL the pushmark */
2204                 op_null(o); /* NULL the list */
2205             }
2206             goto kids;
2207         case OP_ENTEREVAL:
2208             scalarkids(o);
2209             break;
2210         case OP_SCALAR:
2211             scalar(o);
2212             break;
2213         }
2214
2215         if (useless_sv) {
2216             /* mortalise it, in case warnings are fatal.  */
2217             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2218                            "Useless use of %" SVf " in void context",
2219                            SVfARG(sv_2mortal(useless_sv)));
2220         }
2221         else if (useless) {
2222             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2223                            "Useless use of %s in void context",
2224                            useless);
2225         }
2226     } while ( (o = POP_DEFERRED_OP()) );
2227
2228     Safefree(defer_stack);
2229
2230     return arg;
2231 }
2232
2233 static OP *
2234 S_listkids(pTHX_ OP *o)
2235 {
2236     if (o && o->op_flags & OPf_KIDS) {
2237         OP *kid;
2238         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2239             list(kid);
2240     }
2241     return o;
2242 }
2243
2244 OP *
2245 Perl_list(pTHX_ OP *o)
2246 {
2247     OP *kid;
2248
2249     /* assumes no premature commitment */
2250     if (!o || (o->op_flags & OPf_WANT)
2251          || (PL_parser && PL_parser->error_count)
2252          || o->op_type == OP_RETURN)
2253     {
2254         return o;
2255     }
2256
2257     if ((o->op_private & OPpTARGET_MY)
2258         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2259     {
2260         return o;                               /* As if inside SASSIGN */
2261     }
2262
2263     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2264
2265     switch (o->op_type) {
2266     case OP_FLOP:
2267         list(cBINOPo->op_first);
2268         break;
2269     case OP_REPEAT:
2270         if (o->op_private & OPpREPEAT_DOLIST
2271          && !(o->op_flags & OPf_STACKED))
2272         {
2273             list(cBINOPo->op_first);
2274             kid = cBINOPo->op_last;
2275             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2276              && SvIVX(kSVOP_sv) == 1)
2277             {
2278                 op_null(o); /* repeat */
2279                 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2280                 /* const (rhs): */
2281                 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2282             }
2283         }
2284         break;
2285     case OP_OR:
2286     case OP_AND:
2287     case OP_COND_EXPR:
2288         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2289             list(kid);
2290         break;
2291     default:
2292     case OP_MATCH:
2293     case OP_QR:
2294     case OP_SUBST:
2295     case OP_NULL:
2296         if (!(o->op_flags & OPf_KIDS))
2297             break;
2298         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2299             list(cBINOPo->op_first);
2300             return gen_constant_list(o);
2301         }
2302         listkids(o);
2303         break;
2304     case OP_LIST:
2305         listkids(o);
2306         if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2307             op_null(cUNOPo->op_first); /* NULL the pushmark */
2308             op_null(o); /* NULL the list */
2309         }
2310         break;
2311     case OP_LEAVE:
2312     case OP_LEAVETRY:
2313         kid = cLISTOPo->op_first;
2314         list(kid);
2315         kid = OpSIBLING(kid);
2316     do_kids:
2317         while (kid) {
2318             OP *sib = OpSIBLING(kid);
2319             if (sib && kid->op_type != OP_LEAVEWHEN)
2320                 scalarvoid(kid);
2321             else
2322                 list(kid);
2323             kid = sib;
2324         }
2325         PL_curcop = &PL_compiling;
2326         break;
2327     case OP_SCOPE:
2328     case OP_LINESEQ:
2329         kid = cLISTOPo->op_first;
2330         goto do_kids;
2331     }
2332     return o;
2333 }
2334
2335 static OP *
2336 S_scalarseq(pTHX_ OP *o)
2337 {
2338     if (o) {
2339         const OPCODE type = o->op_type;
2340
2341         if (type == OP_LINESEQ || type == OP_SCOPE ||
2342             type == OP_LEAVE || type == OP_LEAVETRY)
2343         {
2344             OP *kid, *sib;
2345             for (kid = cLISTOPo->op_first; kid; kid = sib) {
2346                 if ((sib = OpSIBLING(kid))
2347                  && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2348                     || (  sib->op_targ != OP_NEXTSTATE
2349                        && sib->op_targ != OP_DBSTATE  )))
2350                 {
2351                     scalarvoid(kid);
2352                 }
2353             }
2354             PL_curcop = &PL_compiling;
2355         }
2356         o->op_flags &= ~OPf_PARENS;
2357         if (PL_hints & HINT_BLOCK_SCOPE)
2358             o->op_flags |= OPf_PARENS;
2359     }
2360     else
2361         o = newOP(OP_STUB, 0);
2362     return o;
2363 }
2364
2365 STATIC OP *
2366 S_modkids(pTHX_ OP *o, I32 type)
2367 {
2368     if (o && o->op_flags & OPf_KIDS) {
2369         OP *kid;
2370         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2371             op_lvalue(kid, type);
2372     }
2373     return o;
2374 }
2375
2376
2377 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2378  * const fields. Also, convert CONST keys to HEK-in-SVs.
2379  * rop is the op that retrieves the hash;
2380  * key_op is the first key
2381  */
2382
2383 STATIC void
2384 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op)
2385 {
2386     PADNAME *lexname;
2387     GV **fields;
2388     bool check_fields;
2389
2390     /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2391     if (rop) {
2392         if (rop->op_first->op_type == OP_PADSV)
2393             /* @$hash{qw(keys here)} */
2394             rop = (UNOP*)rop->op_first;
2395         else {
2396             /* @{$hash}{qw(keys here)} */
2397             if (rop->op_first->op_type == OP_SCOPE
2398                 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2399                 {
2400                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2401                 }
2402             else
2403                 rop = NULL;
2404         }
2405     }
2406
2407     lexname = NULL; /* just to silence compiler warnings */
2408     fields  = NULL; /* just to silence compiler warnings */
2409
2410     check_fields =
2411             rop
2412          && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2413              SvPAD_TYPED(lexname))
2414          && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2415          && isGV(*fields) && GvHV(*fields);
2416
2417     for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2418         SV **svp, *sv;
2419         if (key_op->op_type != OP_CONST)
2420             continue;
2421         svp = cSVOPx_svp(key_op);
2422
2423         /* make sure it's not a bareword under strict subs */
2424         if (key_op->op_private & OPpCONST_BARE &&
2425             key_op->op_private & OPpCONST_STRICT)
2426         {
2427             no_bareword_allowed((OP*)key_op);
2428         }
2429
2430         /* Make the CONST have a shared SV */
2431         if (   !SvIsCOW_shared_hash(sv = *svp)
2432             && SvTYPE(sv) < SVt_PVMG
2433             && SvOK(sv)
2434             && !SvROK(sv))
2435         {
2436             SSize_t keylen;
2437             const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2438             SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2439             SvREFCNT_dec_NN(sv);
2440             *svp = nsv;
2441         }
2442
2443         if (   check_fields
2444             && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2445         {
2446             Perl_croak(aTHX_ "No such class field \"%" SVf "\" "
2447                         "in variable %" PNf " of type %" HEKf,
2448                         SVfARG(*svp), PNfARG(lexname),
2449                         HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2450         }
2451     }
2452 }
2453
2454
2455 /* do all the final processing on an optree (e.g. running the peephole
2456  * optimiser on it), then attach it to cv (if cv is non-null)
2457  */
2458
2459 static void
2460 S_process_optree(pTHX_ CV *cv, OP *optree, OP* start)
2461 {
2462     OP **startp;
2463
2464     /* XXX for some reason, evals, require and main optrees are
2465      * never attached to their CV; instead they just hang off
2466      * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start
2467      * and get manually freed when appropriate */
2468     if (cv)
2469         startp = &CvSTART(cv);
2470     else
2471         startp = PL_in_eval? &PL_eval_start : &PL_main_start;
2472
2473     *startp = start;
2474     optree->op_private |= OPpREFCOUNTED;
2475     OpREFCNT_set(optree, 1);
2476     CALL_PEEP(*startp);
2477     finalize_optree(optree);
2478     S_prune_chain_head(startp);
2479
2480     if (cv) {
2481         /* now that optimizer has done its work, adjust pad values */
2482         pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT
2483                  : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
2484     }
2485 }
2486
2487
2488 /*
2489 =for apidoc finalize_optree
2490
2491 This function finalizes the optree.  Should be called directly after
2492 the complete optree is built.  It does some additional
2493 checking which can't be done in the normal C<ck_>xxx functions and makes
2494 the tree thread-safe.
2495
2496 =cut
2497 */
2498 void
2499 Perl_finalize_optree(pTHX_ OP* o)
2500 {
2501     PERL_ARGS_ASSERT_FINALIZE_OPTREE;
2502
2503     ENTER;
2504     SAVEVPTR(PL_curcop);
2505
2506     finalize_op(o);
2507
2508     LEAVE;
2509 }
2510
2511 #ifdef USE_ITHREADS
2512 /* Relocate sv to the pad for thread safety.
2513  * Despite being a "constant", the SV is written to,
2514  * for reference counts, sv_upgrade() etc. */
2515 PERL_STATIC_INLINE void
2516 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
2517 {
2518     PADOFFSET ix;
2519     PERL_ARGS_ASSERT_OP_RELOCATE_SV;
2520     if (!*svp) return;
2521     ix = pad_alloc(OP_CONST, SVf_READONLY);
2522     SvREFCNT_dec(PAD_SVl(ix));
2523     PAD_SETSV(ix, *svp);
2524     /* XXX I don't know how this isn't readonly already. */
2525     if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
2526     *svp = NULL;
2527     *targp = ix;
2528 }
2529 #endif
2530
2531
2532 STATIC void
2533 S_finalize_op(pTHX_ OP* o)
2534 {
2535     PERL_ARGS_ASSERT_FINALIZE_OP;
2536
2537     assert(o->op_type != OP_FREED);
2538
2539     switch (o->op_type) {
2540     case OP_NEXTSTATE:
2541     case OP_DBSTATE:
2542         PL_curcop = ((COP*)o);          /* for warnings */
2543         break;
2544     case OP_EXEC:
2545         if (OpHAS_SIBLING(o)) {
2546             OP *sib = OpSIBLING(o);
2547             if ((  sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
2548                 && ckWARN(WARN_EXEC)
2549                 && OpHAS_SIBLING(sib))
2550             {
2551                     const OPCODE type = OpSIBLING(sib)->op_type;
2552                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
2553                         const line_t oldline = CopLINE(PL_curcop);
2554                         CopLINE_set(PL_curcop, CopLINE((COP*)sib));
2555                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
2556                             "Statement unlikely to be reached");
2557                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
2558                             "\t(Maybe you meant system() when you said exec()?)\n");
2559                         CopLINE_set(PL_curcop, oldline);
2560                     }
2561             }
2562         }
2563         break;
2564
2565     case OP_GV:
2566         if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
2567             GV * const gv = cGVOPo_gv;
2568             if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
2569                 /* XXX could check prototype here instead of just carping */
2570                 SV * const sv = sv_newmortal();
2571                 gv_efullname3(sv, gv, NULL);
2572                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
2573                     "%" SVf "() called too early to check prototype",
2574                     SVfARG(sv));
2575             }
2576         }
2577         break;
2578
2579     case OP_CONST:
2580         if (cSVOPo->op_private & OPpCONST_STRICT)
2581             no_bareword_allowed(o);
2582         /* FALLTHROUGH */
2583 #ifdef USE_ITHREADS
2584     case OP_HINTSEVAL:
2585         op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
2586 #endif
2587         break;
2588
2589 #ifdef USE_ITHREADS
2590     /* Relocate all the METHOP's SVs to the pad for thread safety. */
2591     case OP_METHOD_NAMED:
2592     case OP_METHOD_SUPER:
2593     case OP_METHOD_REDIR:
2594     case OP_METHOD_REDIR_SUPER:
2595         op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
2596         break;
2597 #endif
2598
2599     case OP_HELEM: {
2600         UNOP *rop;
2601         SVOP *key_op;
2602         OP *kid;
2603
2604         if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
2605             break;
2606
2607         rop = (UNOP*)((BINOP*)o)->op_first;
2608
2609         goto check_keys;
2610
2611     case OP_HSLICE:
2612         S_scalar_slice_warning(aTHX_ o);
2613         /* FALLTHROUGH */
2614
2615     case OP_KVHSLICE:
2616         kid = OpSIBLING(cLISTOPo->op_first);
2617         if (/* I bet there's always a pushmark... */
2618             OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
2619             && OP_TYPE_ISNT_NN(kid, OP_CONST))
2620         {
2621             break;
2622         }
2623
2624         key_op = (SVOP*)(kid->op_type == OP_CONST
2625                                 ? kid
2626                                 : OpSIBLING(kLISTOP->op_first));
2627
2628         rop = (UNOP*)((LISTOP*)o)->op_last;
2629
2630       check_keys:
2631         if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
2632             rop = NULL;
2633         S_check_hash_fields_and_hekify(aTHX_ rop, key_op);
2634         break;
2635     }
2636     case OP_NULL:
2637         if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE)
2638             break;
2639         /* FALLTHROUGH */
2640     case OP_ASLICE:
2641         S_scalar_slice_warning(aTHX_ o);
2642         break;
2643
2644     case OP_SUBST: {
2645         if (cPMOPo->op_pmreplrootu.op_pmreplroot)
2646             finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
2647         break;
2648     }
2649     default:
2650         break;
2651     }
2652
2653     if (o->op_flags & OPf_KIDS) {
2654         OP *kid;
2655
2656 #ifdef DEBUGGING
2657         /* check that op_last points to the last sibling, and that
2658          * the last op_sibling/op_sibparent field points back to the
2659          * parent, and that the only ops with KIDS are those which are
2660          * entitled to them */
2661         U32 type = o->op_type;
2662         U32 family;
2663         bool has_last;
2664
2665         if (type == OP_NULL) {
2666             type = o->op_targ;
2667             /* ck_glob creates a null UNOP with ex-type GLOB
2668              * (which is a list op. So pretend it wasn't a listop */
2669             if (type == OP_GLOB)
2670                 type = OP_NULL;
2671         }
2672         family = PL_opargs[type] & OA_CLASS_MASK;
2673
2674         has_last = (   family == OA_BINOP
2675                     || family == OA_LISTOP
2676                     || family == OA_PMOP
2677                     || family == OA_LOOP
2678                    );
2679         assert(  has_last /* has op_first and op_last, or ...
2680               ... has (or may have) op_first: */
2681               || family == OA_UNOP
2682               || family == OA_UNOP_AUX
2683               || family == OA_LOGOP
2684               || family == OA_BASEOP_OR_UNOP
2685               || family == OA_FILESTATOP
2686               || family == OA_LOOPEXOP
2687               || family == OA_METHOP
2688               || type == OP_CUSTOM
2689               || type == OP_NULL /* new_logop does this */
2690               );
2691
2692         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2693 #  ifdef PERL_OP_PARENT
2694             if (!OpHAS_SIBLING(kid)) {
2695                 if (has_last)
2696                     assert(kid == cLISTOPo->op_last);
2697                 assert(kid->op_sibparent == o);
2698             }
2699 #  else
2700             if (has_last && !OpHAS_SIBLING(kid))
2701                 assert(kid == cLISTOPo->op_last);
2702 #  endif
2703         }
2704 #endif
2705
2706         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
2707             finalize_op(kid);
2708     }
2709 }
2710
2711 /*
2712 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
2713
2714 Propagate lvalue ("modifiable") context to an op and its children.
2715 C<type> represents the context type, roughly based on the type of op that
2716 would do the modifying, although C<local()> is represented by C<OP_NULL>,
2717 because it has no op type of its own (it is signalled by a flag on
2718 the lvalue op).
2719
2720 This function detects things that can't be modified, such as C<$x+1>, and
2721 generates errors for them.  For example, C<$x+1 = 2> would cause it to be
2722 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
2723
2724 It also flags things that need to behave specially in an lvalue context,
2725 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
2726
2727 =cut
2728 */
2729
2730 static void
2731 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
2732 {
2733     CV *cv = PL_compcv;
2734     PadnameLVALUE_on(pn);
2735     while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
2736         cv = CvOUTSIDE(cv);
2737         /* RT #127786: cv can be NULL due to an eval within the DB package
2738          * called from an anon sub - anon subs don't have CvOUTSIDE() set
2739          * unless they contain an eval, but calling eval within DB
2740          * pretends the eval was done in the caller's scope.
2741          */
2742         if (!cv)
2743             break;
2744         assert(CvPADLIST(cv));
2745         pn =
2746            PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
2747         assert(PadnameLEN(pn));
2748         PadnameLVALUE_on(pn);
2749     }
2750 }
2751
2752 static bool
2753 S_vivifies(const OPCODE type)
2754 {
2755     switch(type) {
2756     case OP_RV2AV:     case   OP_ASLICE:
2757     case OP_RV2HV:     case OP_KVASLICE:
2758     case OP_RV2SV:     case   OP_HSLICE:
2759     case OP_AELEMFAST: case OP_KVHSLICE:
2760     case OP_HELEM:
2761     case OP_AELEM:
2762         return 1;
2763     }
2764     return 0;
2765 }
2766
2767 static void
2768 S_lvref(pTHX_ OP *o, I32 type)
2769 {
2770     dVAR;
2771     OP *kid;
2772     switch (o->op_type) {
2773     case OP_COND_EXPR:
2774         for (kid = OpSIBLING(cUNOPo->op_first); kid;
2775              kid = OpSIBLING(kid))
2776             S_lvref(aTHX_ kid, type);
2777         /* FALLTHROUGH */
2778     case OP_PUSHMARK:
2779         return;
2780     case OP_RV2AV:
2781         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2782         o->op_flags |= OPf_STACKED;
2783         if (o->op_flags & OPf_PARENS) {
2784             if (o->op_private & OPpLVAL_INTRO) {
2785                  yyerror(Perl_form(aTHX_ "Can't modify reference to "
2786                       "localized parenthesized array in list assignment"));
2787                 return;
2788             }
2789           slurpy:
2790             OpTYPE_set(o, OP_LVAVREF);
2791             o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
2792             o->op_flags |= OPf_MOD|OPf_REF;
2793             return;
2794         }
2795         o->op_private |= OPpLVREF_AV;
2796         goto checkgv;
2797     case OP_RV2CV:
2798         kid = cUNOPo->op_first;
2799         if (kid->op_type == OP_NULL)
2800             kid = cUNOPx(OpSIBLING(kUNOP->op_first))
2801                 ->op_first;
2802         o->op_private = OPpLVREF_CV;
2803         if (kid->op_type == OP_GV)
2804             o->op_flags |= OPf_STACKED;
2805         else if (kid->op_type == OP_PADCV) {
2806             o->op_targ = kid->op_targ;
2807             kid->op_targ = 0;
2808             op_free(cUNOPo->op_first);
2809             cUNOPo->op_first = NULL;
2810             o->op_flags &=~ OPf_KIDS;
2811         }
2812         else goto badref;
2813         break;
2814     case OP_RV2HV:
2815         if (o->op_flags & OPf_PARENS) {
2816           parenhash:
2817             yyerror(Perl_form(aTHX_ "Can't modify reference to "
2818                                  "parenthesized hash in list assignment"));
2819                 return;
2820         }
2821         o->op_private |= OPpLVREF_HV;
2822         /* FALLTHROUGH */
2823     case OP_RV2SV:
2824       checkgv:
2825         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2826         o->op_flags |= OPf_STACKED;
2827         break;
2828     case OP_PADHV:
2829         if (o->op_flags & OPf_PARENS) goto parenhash;
2830         o->op_private |= OPpLVREF_HV;
2831         /* FALLTHROUGH */
2832     case OP_PADSV:
2833         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2834         break;
2835     case OP_PADAV:
2836         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2837         if (o->op_flags & OPf_PARENS) goto slurpy;
2838         o->op_private |= OPpLVREF_AV;
2839         break;
2840     case OP_AELEM:
2841     case OP_HELEM:
2842         o->op_private |= OPpLVREF_ELEM;
2843         o->op_flags   |= OPf_STACKED;
2844         break;
2845     case OP_ASLICE:
2846     case OP_HSLICE:
2847         OpTYPE_set(o, OP_LVREFSLICE);
2848         o->op_private &= OPpLVAL_INTRO;
2849         return;
2850     case OP_NULL:
2851         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
2852             goto badref;
2853         else if (!(o->op_flags & OPf_KIDS))
2854             return;
2855         if (o->op_targ != OP_LIST) {
2856             S_lvref(aTHX_ cBINOPo->op_first, type);
2857             return;
2858         }
2859         /* FALLTHROUGH */
2860     case OP_LIST:
2861         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
2862             assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
2863             S_lvref(aTHX_ kid, type);
2864         }
2865         return;
2866     case OP_STUB:
2867         if (o->op_flags & OPf_PARENS)
2868             return;
2869         /* FALLTHROUGH */
2870     default:
2871       badref:
2872         /* diag_listed_as: Can't modify reference to %s in %s assignment */
2873         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
2874                      o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
2875                       ? "do block"
2876                       : OP_DESC(o),
2877                      PL_op_desc[type]));
2878         return;
2879     }
2880     OpTYPE_set(o, OP_LVREF);
2881     o->op_private &=
2882         OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
2883     if (type == OP_ENTERLOOP)
2884         o->op_private |= OPpLVREF_ITER;
2885 }
2886
2887 PERL_STATIC_INLINE bool
2888 S_potential_mod_type(I32 type)
2889 {
2890     /* Types that only potentially result in modification.  */
2891     return type == OP_GREPSTART || type == OP_ENTERSUB
2892         || type == OP_REFGEN    || type == OP_LEAVESUBLV;
2893 }
2894
2895 OP *
2896 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
2897 {
2898     dVAR;
2899     OP *kid;
2900     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2901     int localize = -1;
2902
2903     if (!o || (PL_parser && PL_parser->error_count))
2904         return o;
2905
2906     if ((o->op_private & OPpTARGET_MY)
2907         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2908     {
2909         return o;
2910     }
2911
2912     assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2913
2914     if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2915
2916     switch (o->op_type) {
2917     case OP_UNDEF:
2918         PL_modcount++;
2919         return o;
2920     case OP_STUB:
2921         if ((o->op_flags & OPf_PARENS))
2922             break;
2923         goto nomod;
2924     case OP_ENTERSUB:
2925         if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
2926             !(o->op_flags & OPf_STACKED)) {
2927             OpTYPE_set(o, OP_RV2CV);            /* entersub => rv2cv */
2928             assert(cUNOPo->op_first->op_type == OP_NULL);
2929             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
2930             break;
2931         }
2932         else {                          /* lvalue subroutine call */
2933             o->op_private |= OPpLVAL_INTRO;
2934             PL_modcount = RETURN_UNLIMITED_NUMBER;
2935             if (S_potential_mod_type(type)) {
2936                 o->op_private |= OPpENTERSUB_INARGS;
2937                 break;
2938             }
2939             else {                      /* Compile-time error message: */
2940                 OP *kid = cUNOPo->op_first;
2941                 CV *cv;
2942                 GV *gv;
2943                 SV *namesv;
2944
2945                 if (kid->op_type != OP_PUSHMARK) {
2946                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2947                         Perl_croak(aTHX_
2948                                 "panic: unexpected lvalue entersub "
2949                                 "args: type/targ %ld:%" UVuf,
2950                                 (long)kid->op_type, (UV)kid->op_targ);
2951                     kid = kLISTOP->op_first;
2952                 }
2953                 while (OpHAS_SIBLING(kid))
2954                     kid = OpSIBLING(kid);
2955                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
2956                     break;      /* Postpone until runtime */
2957                 }
2958
2959                 kid = kUNOP->op_first;
2960                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2961                     kid = kUNOP->op_first;
2962                 if (kid->op_type == OP_NULL)
2963                     Perl_croak(aTHX_
2964                                "Unexpected constant lvalue entersub "
2965                                "entry via type/targ %ld:%" UVuf,
2966                                (long)kid->op_type, (UV)kid->op_targ);
2967                 if (kid->op_type != OP_GV) {
2968                     break;
2969                 }
2970
2971                 gv = kGVOP_gv;
2972                 cv = isGV(gv)
2973                     ? GvCV(gv)
2974                     : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
2975                         ? MUTABLE_CV(SvRV(gv))
2976                         : NULL;
2977                 if (!cv)
2978                     break;
2979                 if (CvLVALUE(cv))
2980                     break;
2981                 if (flags & OP_LVALUE_NO_CROAK)
2982                     return NULL;
2983
2984                 namesv = cv_name(cv, NULL, 0);
2985                 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
2986                                      "subroutine call of &%" SVf " in %s",
2987                                      SVfARG(namesv), PL_op_desc[type]),
2988                            SvUTF8(namesv));
2989                 return o;
2990             }
2991         }
2992         /* FALLTHROUGH */
2993     default:
2994       nomod:
2995         if (flags & OP_LVALUE_NO_CROAK) return NULL;
2996         /* grep, foreach, subcalls, refgen */
2997         if (S_potential_mod_type(type))
2998             break;
2999         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
3000                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
3001                       ? "do block"
3002                       : OP_DESC(o)),
3003                      type ? PL_op_desc[type] : "local"));
3004         return o;
3005
3006     case OP_PREINC:
3007     case OP_PREDEC:
3008     case OP_POW:
3009     case OP_MULTIPLY:
3010     case OP_DIVIDE:
3011     case OP_MODULO:
3012     case OP_ADD:
3013     case OP_SUBTRACT:
3014     case OP_CONCAT:
3015     case OP_LEFT_SHIFT:
3016     case OP_RIGHT_SHIFT:
3017     case OP_BIT_AND:
3018     case OP_BIT_XOR:
3019     case OP_BIT_OR:
3020     case OP_I_MULTIPLY:
3021     case OP_I_DIVIDE:
3022     case OP_I_MODULO:
3023     case OP_I_ADD:
3024     case OP_I_SUBTRACT:
3025         if (!(o->op_flags & OPf_STACKED))
3026             goto nomod;
3027         PL_modcount++;
3028         break;
3029
3030     case OP_REPEAT:
3031         if (o->op_flags & OPf_STACKED) {
3032             PL_modcount++;
3033             break;
3034         }
3035         if (!(o->op_private & OPpREPEAT_DOLIST))
3036             goto nomod;
3037         else {
3038             const I32 mods = PL_modcount;
3039             modkids(cBINOPo->op_first, type);
3040             if (type != OP_AASSIGN)
3041                 goto nomod;
3042             kid = cBINOPo->op_last;
3043             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
3044                 const IV iv = SvIV(kSVOP_sv);
3045                 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
3046                     PL_modcount =
3047                         mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
3048             }
3049             else
3050                 PL_modcount = RETURN_UNLIMITED_NUMBER;
3051         }
3052         break;
3053
3054     case OP_COND_EXPR:
3055         localize = 1;
3056         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
3057             op_lvalue(kid, type);
3058         break;
3059
3060     case OP_RV2AV:
3061     case OP_RV2HV:
3062         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
3063            PL_modcount = RETURN_UNLIMITED_NUMBER;
3064             return o;           /* Treat \(@foo) like ordinary list. */
3065         }
3066         /* FALLTHROUGH */
3067     case OP_RV2GV:
3068         if (scalar_mod_type(o, type))
3069             goto nomod;
3070         ref(cUNOPo->op_first, o->op_type);
3071         /* FALLTHROUGH */
3072     case OP_ASLICE:
3073     case OP_HSLICE:
3074         localize = 1;
3075         /* FALLTHROUGH */
3076     case OP_AASSIGN:
3077         /* Do not apply the lvsub flag for rv2[ah]v in scalar context.  */
3078         if (type == OP_LEAVESUBLV && (
3079                 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
3080              || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
3081            ))
3082             o->op_private |= OPpMAYBE_LVSUB;
3083         /* FALLTHROUGH */
3084     case OP_NEXTSTATE:
3085     case OP_DBSTATE:
3086        PL_modcount = RETURN_UNLIMITED_NUMBER;
3087         break;
3088     case OP_KVHSLICE:
3089     case OP_KVASLICE:
3090     case OP_AKEYS:
3091         if (type == OP_LEAVESUBLV)
3092             o->op_private |= OPpMAYBE_LVSUB;
3093         goto nomod;
3094     case OP_AVHVSWITCH:
3095         if (type == OP_LEAVESUBLV
3096          && (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS)
3097             o->op_private |= OPpMAYBE_LVSUB;
3098         goto nomod;
3099     case OP_AV2ARYLEN:
3100         PL_hints |= HINT_BLOCK_SCOPE;
3101         if (type == OP_LEAVESUBLV)
3102             o->op_private |= OPpMAYBE_LVSUB;
3103         PL_modcount++;
3104         break;
3105     case OP_RV2SV:
3106         ref(cUNOPo->op_first, o->op_type);
3107         localize = 1;
3108         /* FALLTHROUGH */
3109     case OP_GV:
3110         PL_hints |= HINT_BLOCK_SCOPE;
3111         /* FALLTHROUGH */
3112     case OP_SASSIGN:
3113     case OP_ANDASSIGN:
3114     case OP_ORASSIGN:
3115     case OP_DORASSIGN:
3116         PL_modcount++;
3117         break;
3118
3119     case OP_AELEMFAST:
3120     case OP_AELEMFAST_LEX:
3121         localize = -1;
3122         PL_modcount++;
3123         break;
3124
3125     case OP_PADAV:
3126     case OP_PADHV:
3127        PL_modcount = RETURN_UNLIMITED_NUMBER;
3128         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
3129             return o;           /* Treat \(@foo) like ordinary list. */
3130         if (scalar_mod_type(o, type))
3131             goto nomod;
3132         if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
3133           && type == OP_LEAVESUBLV)
3134             o->op_private |= OPpMAYBE_LVSUB;
3135         /* FALLTHROUGH */
3136     case OP_PADSV:
3137         PL_modcount++;
3138         if (!type) /* local() */
3139             Perl_croak(aTHX_ "Can't localize lexical variable %" PNf,
3140                               PNfARG(PAD_COMPNAME(o->op_targ)));
3141         if (!(o->op_private & OPpLVAL_INTRO)
3142          || (  type != OP_SASSIGN && type != OP_AASSIGN
3143             && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ))  ))
3144             S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
3145         break;
3146
3147     case OP_PUSHMARK:
3148         localize = 0;
3149         break;
3150
3151     case OP_KEYS:
3152         if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
3153             goto nomod;
3154         goto lvalue_func;
3155     case OP_SUBSTR:
3156         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
3157             goto nomod;
3158         /* FALLTHROUGH */
3159     case OP_POS:
3160     case OP_VEC:
3161       lvalue_func:
3162         if (type == OP_LEAVESUBLV)
3163             o->op_private |= OPpMAYBE_LVSUB;
3164         if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
3165             /* substr and vec */
3166             /* If this op is in merely potential (non-fatal) modifiable
3167                context, then apply OP_ENTERSUB context to
3168                the kid op (to avoid croaking).  Other-
3169                wise pass this op’s own type so the correct op is mentioned
3170                in error messages.  */
3171             op_lvalue(OpSIBLING(cBINOPo->op_first),
3172                       S_potential_mod_type(type)
3173                         ? (I32)OP_ENTERSUB
3174                         : o->op_type);
3175         }
3176         break;
3177
3178     case OP_AELEM:
3179     case OP_HELEM:
3180         ref(cBINOPo->op_first, o->op_type);
3181         if (type == OP_ENTERSUB &&
3182              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
3183             o->op_private |= OPpLVAL_DEFER;
3184         if (type == OP_LEAVESUBLV)
3185             o->op_private |= OPpMAYBE_LVSUB;
3186         localize = 1;
3187         PL_modcount++;
3188         break;
3189
3190     case OP_LEAVE:
3191     case OP_LEAVELOOP:
3192         o->op_private |= OPpLVALUE;
3193         /* FALLTHROUGH */
3194     case OP_SCOPE:
3195     case OP_ENTER:
3196     case OP_LINESEQ:
3197         localize = 0;
3198         if (o->op_flags & OPf_KIDS)
3199             op_lvalue(cLISTOPo->op_last, type);
3200         break;
3201
3202     case OP_NULL:
3203         localize = 0;
3204         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
3205             goto nomod;
3206         else if (!(o->op_flags & OPf_KIDS))
3207             break;
3208
3209         if (o->op_targ != OP_LIST) {
3210             OP *sib = OpSIBLING(cLISTOPo->op_first);
3211             /* OP_TRANS and OP_TRANSR with argument have a weird optree
3212              * that looks like
3213              *
3214              *   null
3215              *      arg
3216              *      trans
3217              *
3218              * compared with things like OP_MATCH which have the argument
3219              * as a child:
3220              *
3221              *   match
3222              *      arg
3223              *
3224              * so handle specially to correctly get "Can't modify" croaks etc
3225              */
3226
3227             if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR))
3228             {
3229                 /* this should trigger a "Can't modify transliteration" err */
3230                 op_lvalue(sib, type);
3231             }
3232             op_lvalue(cBINOPo->op_first, type);
3233             break;
3234         }
3235         /* FALLTHROUGH */
3236     case OP_LIST:
3237         localize = 0;
3238         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3239             /* elements might be in void context because the list is
3240                in scalar context or because they are attribute sub calls */
3241             if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
3242                 op_lvalue(kid, type);
3243         break;
3244
3245     case OP_COREARGS:
3246         return o;
3247
3248     case OP_AND:
3249     case OP_OR:
3250         if (type == OP_LEAVESUBLV
3251          || !S_vivifies(cLOGOPo->op_first->op_type))
3252             op_lvalue(cLOGOPo->op_first, type);
3253         if (type == OP_LEAVESUBLV
3254          || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
3255             op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
3256         goto nomod;
3257
3258     case OP_SREFGEN:
3259         if (type == OP_NULL) { /* local */
3260           local_refgen:
3261             if (!FEATURE_MYREF_IS_ENABLED)
3262                 Perl_croak(aTHX_ "The experimental declared_refs "
3263                                  "feature is not enabled");
3264             Perl_ck_warner_d(aTHX_
3265                      packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
3266                     "Declaring references is experimental");
3267             op_lvalue(cUNOPo->op_first, OP_NULL);
3268             return o;
3269         }
3270         if (type != OP_AASSIGN && type != OP_SASSIGN
3271          && type != OP_ENTERLOOP)
3272             goto nomod;
3273         /* Don’t bother applying lvalue context to the ex-list.  */
3274         kid = cUNOPx(cUNOPo->op_first)->op_first;
3275         assert (!OpHAS_SIBLING(kid));
3276         goto kid_2lvref;
3277     case OP_REFGEN:
3278         if (type == OP_NULL) /* local */
3279             goto local_refgen;
3280         if (type != OP_AASSIGN) goto nomod;
3281         kid = cUNOPo->op_first;
3282       kid_2lvref:
3283         {
3284             const U8 ec = PL_parser ? PL_parser->error_count : 0;
3285             S_lvref(aTHX_ kid, type);
3286             if (!PL_parser || PL_parser->error_count == ec) {
3287                 if (!FEATURE_REFALIASING_IS_ENABLED)
3288                     Perl_croak(aTHX_
3289                        "Experimental aliasing via reference not enabled");
3290                 Perl_ck_warner_d(aTHX_
3291                                  packWARN(WARN_EXPERIMENTAL__REFALIASING),
3292                                 "Aliasing via reference is experimental");
3293             }
3294         }
3295         if (o->op_type == OP_REFGEN)
3296             op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
3297         op_null(o);
3298         return o;
3299
3300     case OP_SPLIT:
3301         if ((o->op_private & OPpSPLIT_ASSIGN)) {
3302             /* This is actually @array = split.  */
3303             PL_modcount = RETURN_UNLIMITED_NUMBER;
3304             break;
3305         }
3306         goto nomod;
3307
3308     case OP_SCALAR:
3309         op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
3310         goto nomod;
3311     }
3312
3313     /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
3314        their argument is a filehandle; thus \stat(".") should not set
3315        it. AMS 20011102 */
3316     if (type == OP_REFGEN &&
3317         PL_check[o->op_type] == Perl_ck_ftst)
3318         return o;
3319
3320     if (type != OP_LEAVESUBLV)
3321         o->op_flags |= OPf_MOD;
3322
3323     if (type == OP_AASSIGN || type == OP_SASSIGN)
3324         o->op_flags |= OPf_SPECIAL
3325                       |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF);
3326     else if (!type) { /* local() */
3327         switch (localize) {
3328         case 1:
3329             o->op_private |= OPpLVAL_INTRO;
3330             o->op_flags &= ~OPf_SPECIAL;
3331             PL_hints |= HINT_BLOCK_SCOPE;
3332             break;
3333         case 0:
3334             break;
3335         case -1:
3336             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
3337                            "Useless localization of %s", OP_DESC(o));
3338         }
3339     }
3340     else if (type != OP_GREPSTART && type != OP_ENTERSUB
3341              && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
3342         o->op_flags |= OPf_REF;
3343     return o;
3344 }
3345
3346 STATIC bool
3347 S_scalar_mod_type(const OP *o, I32 type)
3348 {
3349     switch (type) {
3350     case OP_POS:
3351     case OP_SASSIGN:
3352         if (o && o->op_type == OP_RV2GV)
3353             return FALSE;
3354         /* FALLTHROUGH */
3355     case OP_PREINC:
3356     case OP_PREDEC:
3357     case OP_POSTINC:
3358     case OP_POSTDEC:
3359     case OP_I_PREINC:
3360     case OP_I_PREDEC:
3361     case OP_I_POSTINC:
3362     case OP_I_POSTDEC:
3363     case OP_POW:
3364     case OP_MULTIPLY:
3365     case OP_DIVIDE:
3366     case OP_MODULO:
3367     case OP_REPEAT:
3368     case OP_ADD:
3369     case OP_SUBTRACT:
3370     case OP_I_MULTIPLY:
3371     case OP_I_DIVIDE:
3372     case OP_I_MODULO:
3373     case OP_I_ADD:
3374     case OP_I_SUBTRACT:
3375     case OP_LEFT_SHIFT:
3376     case OP_RIGHT_SHIFT:
3377     case OP_BIT_AND:
3378     case OP_BIT_XOR:
3379     case OP_BIT_OR:
3380     case OP_NBIT_AND:
3381     case OP_NBIT_XOR:
3382     case OP_NBIT_OR:
3383     case OP_SBIT_AND:
3384     case OP_SBIT_XOR:
3385     case OP_SBIT_OR:
3386     case OP_CONCAT:
3387     case OP_SUBST:
3388     case OP_TRANS:
3389     case OP_TRANSR:
3390     case OP_READ:
3391     case OP_SYSREAD:
3392     case OP_RECV:
3393     case OP_ANDASSIGN:
3394     case OP_ORASSIGN:
3395     case OP_DORASSIGN:
3396     case OP_VEC:
3397     case OP_SUBSTR:
3398         return TRUE;
3399     default:
3400         return FALSE;
3401     }
3402 }
3403
3404 STATIC bool
3405 S_is_handle_constructor(const OP *o, I32 numargs)
3406 {
3407     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
3408
3409     switch (o->op_type) {
3410     case OP_PIPE_OP:
3411     case OP_SOCKPAIR:
3412         if (numargs == 2)
3413             return TRUE;
3414         /* FALLTHROUGH */
3415     case OP_SYSOPEN:
3416     case OP_OPEN:
3417     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
3418     case OP_SOCKET:
3419     case OP_OPEN_DIR:
3420     case OP_ACCEPT:
3421         if (numargs == 1)
3422             return TRUE;
3423         /* FALLTHROUGH */
3424     default:
3425         return FALSE;
3426     }
3427 }
3428
3429 static OP *
3430 S_refkids(pTHX_ OP *o, I32 type)
3431 {
3432     if (o && o->op_flags & OPf_KIDS) {
3433         OP *kid;
3434         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3435             ref(kid, type);
3436     }
3437     return o;
3438 }
3439
3440 OP *
3441 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
3442 {
3443     dVAR;
3444     OP *kid;
3445
3446     PERL_ARGS_ASSERT_DOREF;
3447
3448     if (PL_parser && PL_parser->error_count)
3449         return o;
3450
3451     switch (o->op_type) {
3452     case OP_ENTERSUB:
3453         if ((type == OP_EXISTS || type == OP_DEFINED) &&
3454             !(o->op_flags & OPf_STACKED)) {
3455             OpTYPE_set(o, OP_RV2CV);             /* entersub => rv2cv */
3456             assert(cUNOPo->op_first->op_type == OP_NULL);
3457             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
3458             o->op_flags |= OPf_SPECIAL;
3459         }
3460         else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
3461             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3462                               : type == OP_RV2HV ? OPpDEREF_HV
3463                               : OPpDEREF_SV);
3464             o->op_flags |= OPf_MOD;
3465         }
3466
3467         break;
3468
3469     case OP_COND_EXPR:
3470         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
3471             doref(kid, type, set_op_ref);
3472         break;
3473     case OP_RV2SV:
3474         if (type == OP_DEFINED)
3475             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
3476         doref(cUNOPo->op_first, o->op_type, set_op_ref);
3477         /* FALLTHROUGH */
3478     case OP_PADSV:
3479         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3480             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3481                               : type == OP_RV2HV ? OPpDEREF_HV
3482                               : OPpDEREF_SV);
3483             o->op_flags |= OPf_MOD;
3484         }
3485         break;
3486
3487     case OP_RV2AV:
3488     case OP_RV2HV:
3489         if (set_op_ref)
3490             o->op_flags |= OPf_REF;
3491         /* FALLTHROUGH */
3492     case OP_RV2GV:
3493         if (type == OP_DEFINED)
3494             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
3495         doref(cUNOPo->op_first, o->op_type, set_op_ref);
3496         break;
3497
3498     case OP_PADAV:
3499     case OP_PADHV:
3500         if (set_op_ref)
3501             o->op_flags |= OPf_REF;
3502         break;
3503
3504     case OP_SCALAR:
3505     case OP_NULL:
3506         if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
3507             break;
3508         doref(cBINOPo->op_first, type, set_op_ref);
3509         break;
3510     case OP_AELEM:
3511     case OP_HELEM:
3512         doref(cBINOPo->op_first, o->op_type, set_op_ref);
3513         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3514             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3515                               : type == OP_RV2HV ? OPpDEREF_HV
3516                               : OPpDEREF_SV);
3517             o->op_flags |= OPf_MOD;
3518         }
3519         break;
3520
3521     case OP_SCOPE:
3522     case OP_LEAVE:
3523         set_op_ref = FALSE;
3524         /* FALLTHROUGH */
3525     case OP_ENTER:
3526     case OP_LIST:
3527         if (!(o->op_flags & OPf_KIDS))
3528             break;
3529         doref(cLISTOPo->op_last, type, set_op_ref);
3530         break;
3531     default:
3532         break;
3533     }
3534     return scalar(o);
3535
3536 }
3537
3538 STATIC OP *
3539 S_dup_attrlist(pTHX_ OP *o)
3540 {
3541     OP *rop;
3542
3543     PERL_ARGS_ASSERT_DUP_ATTRLIST;
3544
3545     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
3546      * where the first kid is OP_PUSHMARK and the remaining ones
3547      * are OP_CONST.  We need to push the OP_CONST values.
3548      */
3549     if (o->op_type == OP_CONST)
3550         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
3551     else {
3552         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
3553         rop = NULL;
3554         for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
3555             if (o->op_type == OP_CONST)
3556                 rop = op_append_elem(OP_LIST, rop,
3557                                   newSVOP(OP_CONST, o->op_flags,
3558                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
3559         }
3560     }
3561     return rop;
3562 }
3563
3564 STATIC void
3565 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
3566 {
3567     PERL_ARGS_ASSERT_APPLY_ATTRS;
3568     {
3569         SV * const stashsv = newSVhek(HvNAME_HEK(stash));
3570
3571         /* fake up C<use attributes $pkg,$rv,@attrs> */
3572
3573 #define ATTRSMODULE "attributes"
3574 #define ATTRSMODULE_PM "attributes.pm"
3575
3576         Perl_load_module(
3577           aTHX_ PERL_LOADMOD_IMPORT_OPS,
3578           newSVpvs(ATTRSMODULE),
3579           NULL,
3580           op_prepend_elem(OP_LIST,
3581                           newSVOP(OP_CONST, 0, stashsv),
3582                           op_prepend_elem(OP_LIST,
3583                                           newSVOP(OP_CONST, 0,
3584                                                   newRV(target)),
3585                                           dup_attrlist(attrs))));
3586     }
3587 }
3588
3589 STATIC void
3590 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
3591 {
3592     OP *pack, *imop, *arg;
3593     SV *meth, *stashsv, **svp;
3594
3595     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
3596
3597     if (!attrs)
3598         return;
3599
3600     assert(target->op_type == OP_PADSV ||
3601            target->op_type == OP_PADHV ||
3602            target->op_type == OP_PADAV);
3603
3604     /* Ensure that attributes.pm is loaded. */
3605     /* Don't force the C<use> if we don't need it. */
3606     svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
3607     if (svp && *svp != &PL_sv_undef)
3608         NOOP;   /* already in %INC */
3609     else
3610         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
3611                                newSVpvs(ATTRSMODULE), NULL);
3612
3613     /* Need package name for method call. */
3614     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
3615
3616     /* Build up the real arg-list. */
3617     stashsv = newSVhek(HvNAME_HEK(stash));
3618
3619     arg = newOP(OP_PADSV, 0);
3620     arg->op_targ = target->op_targ;
3621     arg = op_prepend_elem(OP_LIST,
3622                        newSVOP(OP_CONST, 0, stashsv),
3623                        op_prepend_elem(OP_LIST,
3624                                     newUNOP(OP_REFGEN, 0,
3625                                             arg),
3626                                     dup_attrlist(attrs)));
3627
3628     /* Fake up a method call to import */
3629     meth = newSVpvs_share("import");
3630     imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
3631                    op_append_elem(OP_LIST,
3632                                op_prepend_elem(OP_LIST, pack, arg),
3633                                newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
3634
3635     /* Combine the ops. */
3636     *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
3637 }
3638
3639 /*
3640 =notfor apidoc apply_attrs_string
3641
3642 Attempts to apply a list of attributes specified by the C<attrstr> and
3643 C<len> arguments to the subroutine identified by the C<cv> argument which
3644 is expected to be associated with the package identified by the C<stashpv>
3645 argument (see L<attributes>).  It gets this wrong, though, in that it
3646 does not correctly identify the boundaries of the individual attribute
3647 specifications within C<attrstr>.  This is not really intended for the
3648 public API, but has to be listed here for systems such as AIX which
3649 need an explicit export list for symbols.  (It's called from XS code
3650 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
3651 to respect attribute syntax properly would be welcome.
3652
3653 =cut
3654 */
3655
3656 void
3657 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
3658                         const char *attrstr, STRLEN len)
3659 {
3660     OP *attrs = NULL;
3661
3662     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
3663
3664     if (!len) {
3665         len = strlen(attrstr);
3666     }
3667
3668     while (len) {
3669         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
3670         if (len) {
3671             const char * const sstr = attrstr;
3672             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
3673             attrs = op_append_elem(OP_LIST, attrs,
3674                                 newSVOP(OP_CONST, 0,
3675                                         newSVpvn(sstr, attrstr-sstr)));
3676         }
3677     }
3678
3679     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3680                      newSVpvs(ATTRSMODULE),
3681                      NULL, op_prepend_elem(OP_LIST,
3682                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
3683                                   op_prepend_elem(OP_LIST,
3684                                                newSVOP(OP_CONST, 0,
3685                                                        newRV(MUTABLE_SV(cv))),
3686                                                attrs)));
3687 }
3688
3689 STATIC void
3690 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name,
3691                         bool curstash)
3692 {
3693     OP *new_proto = NULL;
3694     STRLEN pvlen;
3695     char *pv;
3696     OP *o;
3697
3698     PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
3699
3700     if (!*attrs)
3701         return;
3702
3703     o = *attrs;
3704     if (o->op_type == OP_CONST) {
3705         pv = SvPV(cSVOPo_sv, pvlen);
3706         if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3707             SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3708             SV ** const tmpo = cSVOPx_svp(o);
3709             SvREFCNT_dec(cSVOPo_sv);
3710             *tmpo = tmpsv;
3711             new_proto = o;
3712             *attrs = NULL;
3713         }
3714     } else if (o->op_type == OP_LIST) {
3715         OP * lasto;
3716         assert(o->op_flags & OPf_KIDS);
3717         lasto = cLISTOPo->op_first;
3718         assert(lasto->op_type == OP_PUSHMARK);
3719         for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
3720             if (o->op_type == OP_CONST) {
3721                 pv = SvPV(cSVOPo_sv, pvlen);
3722                 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3723                     SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3724                     SV ** const tmpo = cSVOPx_svp(o);
3725                     SvREFCNT_dec(cSVOPo_sv);
3726                     *tmpo = tmpsv;
3727                     if (new_proto && ckWARN(WARN_MISC)) {
3728                         STRLEN new_len;
3729                         const char * newp = SvPV(cSVOPo_sv, new_len);
3730                         Perl_warner(aTHX_ packWARN(WARN_MISC),
3731                             "Attribute prototype(%" UTF8f ") discards earlier prototype attribute in same sub",
3732                             UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
3733                         op_free(new_proto);
3734                     }
3735                     else if (new_proto)
3736                         op_free(new_proto);
3737                     new_proto = o;
3738                     /* excise new_proto from the list */
3739                     op_sibling_splice(*attrs, lasto, 1, NULL);
3740                     o = lasto;
3741                     continue;
3742                 }
3743             }
3744             lasto = o;
3745         }
3746         /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
3747            would get pulled in with no real need */
3748         if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
3749             op_free(*attrs);
3750             *attrs = NULL;
3751         }
3752     }
3753
3754     if (new_proto) {
3755         SV *svname;
3756         if (isGV(name)) {
3757             svname = sv_newmortal();
3758             gv_efullname3(svname, name, NULL);
3759         }
3760         else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
3761             svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
3762         else
3763             svname = (SV *)name;
3764         if (ckWARN(WARN_ILLEGALPROTO))
3765             (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE,
3766                                  curstash);
3767         if (*proto && ckWARN(WARN_PROTOTYPE)) {
3768             STRLEN old_len, new_len;
3769             const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
3770             const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
3771
3772             Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3773                 "Prototype '%" UTF8f "' overridden by attribute 'prototype(%" UTF8f ")'"
3774                 " in %" SVf,
3775                 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
3776                 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
3777                 SVfARG(svname));
3778         }
3779         if (*proto)
3780             op_free(*proto);
3781         *proto = new_proto;
3782     }
3783 }
3784
3785 static void
3786 S_cant_declare(pTHX_ OP *o)
3787 {
3788     if (o->op_type == OP_NULL
3789      && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
3790         o = cUNOPo->op_first;
3791     yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
3792                              o->op_type == OP_NULL
3793                                && o->op_flags & OPf_SPECIAL
3794                                  ? "do block"
3795                                  : OP_DESC(o),
3796                              PL_parser->in_my == KEY_our   ? "our"   :
3797                              PL_parser->in_my == KEY_state ? "state" :
3798                                                              "my"));
3799 }
3800
3801 STATIC OP *
3802 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
3803 {
3804     I32 type;
3805     const bool stately = PL_parser && PL_parser->in_my == KEY_state;
3806
3807     PERL_ARGS_ASSERT_MY_KID;
3808
3809     if (!o || (PL_parser && PL_parser->error_count))
3810         return o;
3811
3812     type = o->op_type;
3813
3814     if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
3815         OP *kid;
3816         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3817             my_kid(kid, attrs, imopsp);
3818         return o;
3819     } else if (type == OP_UNDEF || type == OP_STUB) {
3820         return o;
3821     } else if (type == OP_RV2SV ||      /* "our" declaration */
3822                type == OP_RV2AV ||
3823                type == OP_RV2HV) {
3824         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
3825             S_cant_declare(aTHX_ o);
3826         } else if (attrs) {
3827             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
3828             assert(PL_parser);
3829             PL_parser->in_my = FALSE;
3830             PL_parser->in_my_stash = NULL;
3831             apply_attrs(GvSTASH(gv),
3832                         (type == OP_RV2SV ? GvSVn(gv) :
3833                          type == OP_RV2AV ? MUTABLE_SV(GvAVn(gv)) :
3834                          type == OP_RV2HV ? MUTABLE_SV(GvHVn(gv)) : MUTABLE_SV(gv)),
3835                         attrs);
3836         }
3837         o->op_private |= OPpOUR_INTRO;
3838         return o;
3839     }
3840     else if (type == OP_REFGEN || type == OP_SREFGEN) {
3841         if (!FEATURE_MYREF_IS_ENABLED)
3842             Perl_croak(aTHX_ "The experimental declared_refs "
3843                              "feature is not enabled");
3844         Perl_ck_warner_d(aTHX_
3845              packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
3846             "Declaring references is experimental");
3847         /* Kid is a nulled OP_LIST, handled above.  */
3848         my_kid(cUNOPo->op_first, attrs, imopsp);
3849         return o;
3850     }
3851     else if (type != OP_PADSV &&
3852              type != OP_PADAV &&
3853              type != OP_PADHV &&
3854              type != OP_PUSHMARK)
3855     {
3856         S_cant_declare(aTHX_ o);
3857         return o;
3858     }
3859     else if (attrs && type != OP_PUSHMARK) {
3860         HV *stash;
3861
3862         assert(PL_parser);
3863         PL_parser->in_my = FALSE;
3864         PL_parser->in_my_stash = NULL;
3865
3866         /* check for C<my Dog $spot> when deciding package */
3867         stash = PAD_COMPNAME_TYPE(o->op_targ);
3868         if (!stash)
3869             stash = PL_curstash;
3870         apply_attrs_my(stash, o, attrs, imopsp);
3871     }
3872     o->op_flags |= OPf_MOD;
3873     o->op_private |= OPpLVAL_INTRO;
3874     if (stately)
3875         o->op_private |= OPpPAD_STATE;
3876     return o;
3877 }
3878
3879 OP *
3880 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
3881 {
3882     OP *rops;
3883     int maybe_scalar = 0;
3884
3885     PERL_ARGS_ASSERT_MY_ATTRS;
3886
3887 /* [perl #17376]: this appears to be premature, and results in code such as
3888    C< our(%x); > executing in list mode rather than void mode */
3889 #if 0
3890     if (o->op_flags & OPf_PARENS)
3891         list(o);
3892     else
3893         maybe_scalar = 1;
3894 #else
3895     maybe_scalar = 1;
3896 #endif
3897     if (attrs)
3898         SAVEFREEOP(attrs);
3899     rops = NULL;
3900     o = my_kid(o, attrs, &rops);
3901     if (rops) {
3902         if (maybe_scalar && o->op_type == OP_PADSV) {
3903             o = scalar(op_append_list(OP_LIST, rops, o));
3904             o->op_private |= OPpLVAL_INTRO;
3905         }
3906         else {
3907             /* The listop in rops might have a pushmark at the beginning,
3908                which will mess up list assignment. */
3909             LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
3910             if (rops->op_type == OP_LIST &&
3911                 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
3912             {
3913                 OP * const pushmark = lrops->op_first;
3914                 /* excise pushmark */
3915                 op_sibling_splice(rops, NULL, 1, NULL);
3916                 op_free(pushmark);
3917             }
3918             o = op_append_list(OP_LIST, o, rops);
3919         }
3920     }
3921     PL_parser->in_my = FALSE;
3922     PL_parser->in_my_stash = NULL;
3923     return o;
3924 }
3925
3926 OP *
3927 Perl_sawparens(pTHX_ OP *o)
3928 {
3929     PERL_UNUSED_CONTEXT;
3930     if (o)
3931         o->op_flags |= OPf_PARENS;
3932     return o;
3933 }
3934
3935 OP *
3936 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
3937 {
3938     OP *o;
3939     bool ismatchop = 0;
3940     const OPCODE ltype = left->op_type;
3941     const OPCODE rtype = right->op_type;
3942
3943     PERL_ARGS_ASSERT_BIND_MATCH;
3944
3945     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
3946           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
3947     {
3948       const char * const desc
3949           = PL_op_desc[(
3950                           rtype == OP_SUBST || rtype == OP_TRANS
3951                        || rtype == OP_TRANSR
3952                        )
3953                        ? (int)rtype : OP_MATCH];
3954       const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
3955       SV * const name =
3956         S_op_varname(aTHX_ left);
3957       if (name)
3958         Perl_warner(aTHX_ packWARN(WARN_MISC),
3959              "Applying %s to %" SVf " will act on scalar(%" SVf ")",
3960              desc, SVfARG(name), SVfARG(name));
3961       else {
3962         const char * const sample = (isary
3963              ? "@array" : "%hash");
3964         Perl_warner(aTHX_ packWARN(WARN_MISC),
3965              "Applying %s to %s will act on scalar(%s)",
3966              desc, sample, sample);
3967       }
3968     }
3969
3970     if (rtype == OP_CONST &&
3971         cSVOPx(right)->op_private & OPpCONST_BARE &&
3972         cSVOPx(right)->op_private & OPpCONST_STRICT)
3973     {
3974         no_bareword_allowed(right);
3975     }
3976
3977     /* !~ doesn't make sense with /r, so error on it for now */
3978     if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
3979         type == OP_NOT)
3980         /* diag_listed_as: Using !~ with %s doesn't make sense */
3981         yyerror("Using !~ with s///r doesn't make sense");
3982     if (rtype == OP_TRANSR && type == OP_NOT)
3983         /* diag_listed_as: Using !~ with %s doesn't make sense */
3984         yyerror("Using !~ with tr///r doesn't make sense");
3985
3986     ismatchop = (rtype == OP_MATCH ||
3987                  rtype == OP_SUBST ||
3988                  rtype == OP_TRANS || rtype == OP_TRANSR)
3989              && !(right->op_flags & OPf_SPECIAL);
3990     if (ismatchop && right->op_private & OPpTARGET_MY) {
3991         right->op_targ = 0;
3992         right->op_private &= ~OPpTARGET_MY;
3993     }
3994     if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
3995         if (left->op_type == OP_PADSV
3996          && !(left->op_private & OPpLVAL_INTRO))
3997         {
3998             right->op_targ = left->op_targ;
3999             op_free(left);
4000             o = right;
4001         }
4002         else {
4003             right->op_flags |= OPf_STACKED;
4004             if (rtype != OP_MATCH && rtype != OP_TRANSR &&
4005             ! (rtype == OP_TRANS &&
4006                right->op_private & OPpTRANS_IDENTICAL) &&
4007             ! (rtype == OP_SUBST &&
4008                (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
4009                 left = op_lvalue(left, rtype);
4010             if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
4011                 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
4012             else
4013                 o = op_prepend_elem(rtype, scalar(left), right);
4014         }
4015         if (type == OP_NOT)
4016             return newUNOP(OP_NOT, 0, scalar(o));
4017         return o;
4018     }
4019     else
4020         return bind_match(type, left,
4021                 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
4022 }
4023
4024 OP *
4025 Perl_invert(pTHX_ OP *o)
4026 {
4027     if (!o)
4028         return NULL;
4029     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
4030 }
4031
4032 /*
4033 =for apidoc Amx|OP *|op_scope|OP *o
4034
4035 Wraps up an op tree with some additional ops so that at runtime a dynamic
4036 scope will be created.  The original ops run in the new dynamic scope,
4037 and then, provided that they exit normally, the scope will be unwound.
4038 The additional ops used to create and unwind the dynamic scope will
4039 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
4040 instead if the ops are simple enough to not need the full dynamic scope
4041 structure.
4042
4043 =cut
4044 */
4045
4046 OP *
4047 Perl_op_scope(pTHX_ OP *o)
4048 {
4049     dVAR;
4050     if (o) {
4051         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
4052             o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
4053             OpTYPE_set(o, OP_LEAVE);
4054         }
4055         else if (o->op_type == OP_LINESEQ) {
4056             OP *kid;
4057             OpTYPE_set(o, OP_SCOPE);
4058             kid = ((LISTOP*)o)->op_first;
4059             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
4060                 op_null(kid);
4061
4062                 /* The following deals with things like 'do {1 for 1}' */
4063                 kid = OpSIBLING(kid);
4064                 if (kid &&
4065                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
4066                     op_null(kid);
4067             }
4068         }
4069         else
4070             o = newLISTOP(OP_SCOPE, 0, o, NULL);
4071     }
4072     return o;
4073 }
4074
4075 OP *
4076 Perl_op_unscope(pTHX_ OP *o)
4077 {
4078     if (o && o->op_type == OP_LINESEQ) {
4079         OP *kid = cLISTOPo->op_first;
4080         for(; kid; kid = OpSIBLING(kid))
4081             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
4082                 op_null(kid);
4083     }
4084     return o;
4085 }
4086
4087 /*
4088 =for apidoc Am|int|block_start|int full
4089
4090 Handles compile-time scope entry.
4091 Arranges for hints to be restored on block
4092 exit and also handles pad sequence numbers to make lexical variables scope
4093 right.  Returns a savestack index for use with C<block_end>.
4094
4095 =cut
4096 */
4097
4098 int
4099 Perl_block_start(pTHX_ int full)
4100 {
4101     const int retval = PL_savestack_ix;
4102
4103     PL_compiling.cop_seq = PL_cop_seqmax;
4104     COP_SEQMAX_INC;
4105     pad_block_start(full);
4106     SAVEHINTS();
4107     PL_hints &= ~HINT_BLOCK_SCOPE;
4108     SAVECOMPILEWARNINGS();
4109     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
4110     SAVEI32(PL_compiling.cop_seq);
4111     PL_compiling.cop_seq = 0;
4112
4113     CALL_BLOCK_HOOKS(bhk_start, full);
4114
4115     return retval;
4116 }
4117
4118 /*
4119 =for apidoc Am|OP *|block_end|I32 floor|OP *seq
4120
4121 Handles compile-time scope exit.  C<floor>
4122 is the savestack index returned by
4123 C<block_start>, and C<seq> is the body of the block.  Returns the block,
4124 possibly modified.
4125
4126 =cut
4127 */
4128
4129 OP*
4130 Perl_block_end(pTHX_ I32 floor, OP *seq)
4131 {
4132     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
4133     OP* retval = scalarseq(seq);
4134     OP *o;
4135
4136     /* XXX Is the null PL_parser check necessary here? */
4137     assert(PL_parser); /* Let’s find out under debugging builds.  */
4138     if (PL_parser && PL_parser->parsed_sub) {
4139         o = newSTATEOP(0, NULL, NULL);
4140         op_null(o);
4141         retval = op_append_elem(OP_LINESEQ, retval, o);
4142     }
4143
4144     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
4145
4146     LEAVE_SCOPE(floor);
4147     if (needblockscope)
4148         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
4149     o = pad_leavemy();
4150
4151     if (o) {
4152         /* pad_leavemy has created a sequence of introcv ops for all my
4153            subs declared in the block.  We have to replicate that list with
4154            clonecv ops, to deal with this situation:
4155
4156                sub {
4157                    my sub s1;
4158                    my sub s2;
4159                    sub s1 { state sub foo { \&s2 } }
4160                }->()
4161
4162            Originally, I was going to have introcv clone the CV and turn
4163            off the stale flag.  Since &s1 is declared before &s2, the
4164            introcv op for &s1 is executed (on sub entry) before the one for
4165            &s2.  But the &foo sub inside &s1 (which is cloned when &s1 is
4166            cloned, since it is a state sub) closes over &s2 and expects
4167            to see it in its outer CV’s pad.  If the introcv op clones &s1,
4168            then &s2 is still marked stale.  Since &s1 is not active, and
4169            &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
4170            ble will not stay shared’ warning.  Because it is the same stub
4171            that will be used when the introcv op for &s2 is executed, clos-
4172            ing over it is safe.  Hence, we have to turn off the stale flag
4173            on all lexical subs in the block before we clone any of them.
4174            Hence, having introcv clone the sub cannot work.  So we create a
4175            list of ops like this:
4176
4177                lineseq
4178                   |
4179                   +-- introcv
4180                   |
4181                   +-- introcv
4182                   |
4183                   +-- introcv
4184                   |
4185                   .
4186                   .
4187                   .
4188                   |
4189                   +-- clonecv
4190                   |
4191                   +-- clonecv
4192                   |
4193                   +-- clonecv
4194                   |
4195                   .
4196                   .
4197                   .
4198          */
4199         OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
4200         OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
4201         for (;; kid = OpSIBLING(kid)) {
4202             OP *newkid = newOP(OP_CLONECV, 0);
4203             newkid->op_targ = kid->op_targ;
4204             o = op_append_elem(OP_LINESEQ, o, newkid);
4205             if (kid == last) break;
4206         }
4207         retval = op_prepend_elem(OP_LINESEQ, o, retval);
4208     }
4209
4210     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
4211
4212     return retval;
4213 }
4214
4215 /*
4216 =head1 Compile-time scope hooks
4217
4218 =for apidoc Aox||blockhook_register
4219
4220 Register a set of hooks to be called when the Perl lexical scope changes
4221 at compile time.  See L<perlguts/"Compile-time scope hooks">.
4222
4223 =cut
4224 */
4225
4226 void
4227 Perl_blockhook_register(pTHX_ BHK *hk)
4228 {
4229     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
4230
4231     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
4232 }
4233
4234 void
4235 Perl_newPROG(pTHX_ OP *o)
4236 {
4237     OP *start;
4238
4239     PERL_ARGS_ASSERT_NEWPROG;
4240
4241     if (PL_in_eval) {
4242         PERL_CONTEXT *cx;
4243         I32 i;
4244         if (PL_eval_root)
4245                 return;
4246         PL_eval_root = newUNOP(OP_LEAVEEVAL,
4247                                ((PL_in_eval & EVAL_KEEPERR)
4248                                 ? OPf_SPECIAL : 0), o);
4249
4250         cx = CX_CUR();
4251         assert(CxTYPE(cx) == CXt_EVAL);
4252
4253         if ((cx->blk_gimme & G_WANT) == G_VOID)
4254             scalarvoid(PL_eval_root);
4255         else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
4256             list(PL_eval_root);
4257         else
4258             scalar(PL_eval_root);
4259
4260         start = op_linklist(PL_eval_root);
4261         PL_eval_root->op_next = 0;
4262         i = PL_savestack_ix;
4263         SAVEFREEOP(o);
4264         ENTER;
4265         S_process_optree(aTHX_ NULL, PL_eval_root, start);
4266         LEAVE;
4267         PL_savestack_ix = i;
4268     }
4269     else {
4270         if (o->op_type == OP_STUB) {
4271             /* This block is entered if nothing is compiled for the main
4272                program. This will be the case for an genuinely empty main
4273                program, or one which only has BEGIN blocks etc, so already
4274                run and freed.
4275
4276                Historically (5.000) the guard above was !o. However, commit
4277                f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
4278                c71fccf11fde0068, changed perly.y so that newPROG() is now
4279                called with the output of block_end(), which returns a new
4280                OP_STUB for the case of an empty optree. ByteLoader (and
4281                maybe other things) also take this path, because they set up
4282                PL_main_start and PL_main_root directly, without generating an
4283                optree.
4284
4285                If the parsing the main program aborts (due to parse errors,
4286                or due to BEGIN or similar calling exit), then newPROG()
4287                isn't even called, and hence this code path and its cleanups
4288                are skipped. This shouldn't make a make a difference:
4289                * a non-zero return from perl_parse is a failure, and
4290                  perl_destruct() should be called immediately.
4291                * however, if exit(0) is called during the parse, then
4292                  perl_parse() returns 0, and perl_run() is called. As
4293                  PL_main_start will be NULL, perl_run() will return
4294                  promptly, and the exit code will remain 0.
4295             */
4296
4297             PL_comppad_name = 0;
4298             PL_compcv = 0;
4299             S_op_destroy(aTHX_ o);
4300             return;
4301         }
4302         PL_main_root = op_scope(sawparens(scalarvoid(o)));
4303         PL_curcop = &PL_compiling;
4304         start = LINKLIST(PL_main_root);
4305         PL_main_root->op_next = 0;
4306         S_process_optree(aTHX_ NULL, PL_main_root, start);
4307         cv_forget_slab(PL_compcv);
4308         PL_compcv = 0;
4309
4310         /* Register with debugger */
4311         if (PERLDB_INTER) {
4312             CV * const cv = get_cvs("DB::postponed", 0);
4313             if (cv) {
4314                 dSP;
4315                 PUSHMARK(SP);
4316                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
4317                 PUTBACK;
4318                 call_sv(MUTABLE_SV(cv), G_DISCARD);
4319             }
4320         }
4321     }
4322 }
4323
4324 OP *
4325 Perl_localize(pTHX_ OP *o, I32 lex)
4326 {
4327     PERL_ARGS_ASSERT_LOCALIZE;
4328
4329     if (o->op_flags & OPf_PARENS)
4330 /* [perl #17376]: this appears to be premature, and results in code such as
4331    C< our(%x); > executing in list mode rather than void mode */
4332 #if 0
4333         list(o);
4334 #else
4335         NOOP;
4336 #endif
4337     else {
4338         if ( PL_parser->bufptr > PL_parser->oldbufptr
4339             && PL_parser->bufptr[-1] == ','
4340             && ckWARN(WARN_PARENTHESIS))
4341         {
4342             char *s = PL_parser->bufptr;
4343             bool sigil = FALSE;
4344
4345             /* some heuristics to detect a potential error */
4346             while (*s && (strchr(", \t\n", *s)))
4347                 s++;
4348
4349             while (1) {
4350                 if (*s && (strchr("@$%", *s) || (!lex && *s == '*'))
4351                        && *++s
4352                        && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
4353                     s++;
4354                     sigil = TRUE;
4355                     while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
4356                         s++;
4357                     while (*s && (strchr(", \t\n", *s)))
4358                         s++;
4359                 }
4360                 else
4361                     break;
4362             }
4363             if (sigil && (*s == ';' || *s == '=')) {
4364                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
4365                                 "Parentheses missing around \"%s\" list",
4366                                 lex
4367                                     ? (PL_parser->in_my == KEY_our
4368                                         ? "our"
4369                                         : PL_parser->in_my == KEY_state
4370                                             ? "state"
4371                                             : "my")
4372                                     : "local");
4373             }
4374         }
4375     }
4376     if (lex)
4377         o = my(o);
4378     else
4379         o = op_lvalue(o, OP_NULL);              /* a bit kludgey */
4380     PL_parser->in_my = FALSE;
4381     PL_parser->in_my_stash = NULL;
4382     return o;
4383 }
4384
4385 OP *
4386 Perl_jmaybe(pTHX_ OP *o)
4387 {
4388     PERL_ARGS_ASSERT_JMAYBE;
4389
4390     if (o->op_type == OP_LIST) {
4391         OP * const o2
4392             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
4393         o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
4394     }
4395     return o;
4396 }
4397
4398 PERL_STATIC_INLINE OP *
4399 S_op_std_init(pTHX_ OP *o)
4400 {
4401     I32 type = o->op_type;
4402
4403     PERL_ARGS_ASSERT_OP_STD_INIT;
4404
4405     if (PL_opargs[type] & OA_RETSCALAR)
4406         scalar(o);
4407     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
4408         o->op_targ = pad_alloc(type, SVs_PADTMP);
4409
4410     return o;
4411 }
4412
4413 PERL_STATIC_INLINE OP *
4414 S_op_integerize(pTHX_ OP *o)
4415 {
4416     I32 type = o->op_type;
4417
4418     PERL_ARGS_ASSERT_OP_INTEGERIZE;
4419
4420     /* integerize op. */
4421     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
4422     {
4423         dVAR;
4424         o->op_ppaddr = PL_ppaddr[++(o->op_type)];
4425     }
4426
4427     if (type == OP_NEGATE)
4428         /* XXX might want a ck_negate() for this */
4429         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
4430
4431     return o;
4432 }
4433
4434 static OP *
4435 S_fold_constants(pTHX_ OP *const o)
4436 {
4437     dVAR;
4438     OP * VOL curop;
4439     OP *newop;
4440     VOL I32 type = o->op_type;
4441     bool is_stringify;
4442     SV * VOL sv = NULL;
4443     int ret = 0;
4444     OP *old_next;
4445     SV * const oldwarnhook = PL_warnhook;
4446     SV * const olddiehook  = PL_diehook;
4447     COP not_compiling;
4448     U8 oldwarn = PL_dowarn;
4449     I32 old_cxix;
4450     dJMPENV;
4451
4452     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
4453
4454     if (!(PL_opargs[type] & OA_FOLDCONST))
4455         goto nope;
4456
4457     switch (type) {
4458     case OP_UCFIRST:
4459     case OP_LCFIRST:
4460     case OP_UC:
4461     case OP_LC:
4462     case OP_FC:
4463 #ifdef USE_LOCALE_CTYPE
4464         if (IN_LC_COMPILETIME(LC_CTYPE))
4465             goto nope;
4466 #endif
4467         break;
4468     case OP_SLT:
4469     case OP_SGT:
4470     case OP_SLE:
4471     case OP_SGE:
4472     case OP_SCMP:
4473 #ifdef USE_LOCALE_COLLATE
4474         if (IN_LC_COMPILETIME(LC_COLLATE))
4475             goto nope;
4476 #endif
4477         break;
4478     case OP_SPRINTF:
4479         /* XXX what about the numeric ops? */
4480 #ifdef USE_LOCALE_NUMERIC
4481         if (IN_LC_COMPILETIME(LC_NUMERIC))
4482             goto nope;
4483 #endif
4484         break;
4485     case OP_PACK:
4486         if (!OpHAS_SIBLING(cLISTOPo->op_first)
4487           || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
4488             goto nope;
4489         {
4490             SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
4491             if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
4492             {
4493                 const char *s = SvPVX_const(sv);
4494                 while (s < SvEND(sv)) {
4495                     if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
4496                     s++;
4497                 }
4498             }
4499         }
4500         break;
4501     case OP_REPEAT:
4502         if (o->op_private & OPpREPEAT_DOLIST) goto nope;
4503         break;
4504     case OP_SREFGEN:
4505         if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
4506          || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
4507             goto nope;
4508     }
4509
4510     if (PL_parser && PL_parser->error_count)
4511         goto nope;              /* Don't try to run w/ errors */
4512
4513     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4514         switch (curop->op_type) {
4515         case OP_CONST:
4516             if (   (curop->op_private & OPpCONST_BARE)
4517                 && (curop->op_private & OPpCONST_STRICT)) {
4518                 no_bareword_allowed(curop);
4519                 goto nope;
4520             }
4521             /* FALLTHROUGH */
4522         case OP_LIST:
4523         case OP_SCALAR:
4524         case OP_NULL:
4525         case OP_PUSHMARK:
4526             /* Foldable; move to next op in list */
4527             break;
4528
4529         default:
4530             /* No other op types are considered foldable */
4531             goto nope;
4532         }
4533     }
4534
4535     curop = LINKLIST(o);
4536     old_next = o->op_next;
4537     o->op_next = 0;
4538     PL_op = curop;
4539
4540     old_cxix = cxstack_ix;
4541     create_eval_scope(NULL, G_FAKINGEVAL);
4542
4543     /* Verify that we don't need to save it:  */
4544     assert(PL_curcop == &PL_compiling);
4545     StructCopy(&PL_compiling, &not_compiling, COP);
4546     PL_curcop = &not_compiling;
4547     /* The above ensures that we run with all the correct hints of the
4548        currently compiling COP, but that IN_PERL_RUNTIME is true. */
4549     assert(IN_PERL_RUNTIME);
4550     PL_warnhook = PERL_WARNHOOK_FATAL;
4551     PL_diehook  = NULL;
4552     JMPENV_PUSH(ret);
4553
4554     /* Effective $^W=1.  */
4555     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
4556         PL_dowarn |= G_WARN_ON;
4557
4558     switch (ret) {
4559     case 0:
4560         CALLRUNOPS(aTHX);
4561         sv = *(PL_stack_sp--);
4562         if (o->op_targ && sv == PAD_SV(o->op_targ)) {   /* grab pad temp? */
4563             pad_swipe(o->op_targ,  FALSE);
4564         }
4565         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
4566             SvREFCNT_inc_simple_void(sv);
4567             SvTEMP_off(sv);
4568         }
4569         else { assert(SvIMMORTAL(sv)); }
4570         break;
4571     case 3:
4572         /* Something tried to die.  Abandon constant folding.  */
4573         /* Pretend the error never happened.  */
4574         CLEAR_ERRSV();
4575         o->op_next = old_next;
4576         break;
4577     default:
4578         JMPENV_POP;
4579         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
4580         PL_warnhook = oldwarnhook;
4581         PL_diehook  = olddiehook;
4582         /* XXX note that this croak may fail as we've already blown away
4583          * the stack - eg any nested evals */
4584         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
4585     }
4586     JMPENV_POP;
4587     PL_dowarn   = oldwarn;
4588     PL_warnhook = oldwarnhook;
4589     PL_diehook  = olddiehook;
4590     PL_curcop = &PL_compiling;
4591
4592     /* if we croaked, depending on how we croaked the eval scope
4593      * may or may not have already been popped */
4594     if (cxstack_ix > old_cxix) {
4595         assert(cxstack_ix == old_cxix + 1);
4596         assert(CxTYPE(CX_CUR()) == CXt_EVAL);
4597         delete_eval_scope();
4598     }
4599     if (ret)
4600         goto nope;
4601
4602     /* OP_STRINGIFY and constant folding are used to implement qq.
4603        Here the constant folding is an implementation detail that we
4604        want to hide.  If the stringify op is itself already marked
4605        folded, however, then it is actually a folded join.  */
4606     is_stringify = type == OP_STRINGIFY && !o->op_folded;
4607     op_free(o);
4608     assert(sv);
4609     if (is_stringify)
4610         SvPADTMP_off(sv);
4611     else if (!SvIMMORTAL(sv)) {
4612         SvPADTMP_on(sv);
4613         SvREADONLY_on(sv);
4614     }
4615     newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
4616     if (!is_stringify) newop->op_folded = 1;
4617     return newop;
4618
4619  nope:
4620     return o;
4621 }
4622
4623 static OP *
4624 S_gen_constant_list(pTHX_ OP *o)
4625 {
4626     dVAR;
4627     OP *curop, *old_next;
4628     SV * const oldwarnhook = PL_warnhook;
4629     SV * const olddiehook  = PL_diehook;
4630     COP *old_curcop;
4631     U8 oldwarn = PL_dowarn;
4632     SV **svp;
4633     AV *av;
4634     I32 old_cxix;
4635     COP not_compiling;
4636     int ret = 0;
4637     dJMPENV;
4638     bool op_was_null;
4639
4640     list(o);
4641     if (PL_parser && PL_parser->error_count)
4642         return o;               /* Don't attempt to run with errors */
4643
4644     curop = LINKLIST(o);
4645     old_next = o->op_next;
4646     o->op_next = 0;
4647     op_was_null = o->op_type == OP_NULL;
4648     if (op_was_null) /* b3698342565fb462291fba4b432cfcd05b6eb4e1 */
4649         o->op_type = OP_CUSTOM;
4650     CALL_PEEP(curop);
4651     if (op_was_null)
4652         o->op_type = OP_NULL;
4653     S_prune_chain_head(&curop);
4654     PL_op = curop;
4655
4656     old_cxix = cxstack_ix;
4657     create_eval_scope(NULL, G_FAKINGEVAL);
4658
4659     old_curcop = PL_curcop;
4660     StructCopy(old_curcop, &not_compiling, COP);
4661     PL_curcop = &not_compiling;
4662     /* The above ensures that we run with all the correct hints of the
4663        current COP, but that IN_PERL_RUNTIME is true. */
4664     assert(IN_PERL_RUNTIME);
4665     PL_warnhook = PERL_WARNHOOK_FATAL;
4666     PL_diehook  = NULL;
4667     JMPENV_PUSH(ret);
4668
4669     /* Effective $^W=1.  */
4670     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
4671         PL_dowarn |= G_WARN_ON;
4672
4673     switch (ret) {
4674     case 0:
4675 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
4676         PL_curstackinfo->si_stack_hwm = 0; /* stop valgrind complaining */
4677 #endif
4678         Perl_pp_pushmark(aTHX);
4679         CALLRUNOPS(aTHX);
4680         PL_op = curop;
4681         assert (!(curop->op_flags & OPf_SPECIAL));
4682         assert(curop->op_type == OP_RANGE);
4683         Perl_pp_anonlist(aTHX);
4684         break;
4685     case 3:
4686         CLEAR_ERRSV();
4687         o->op_next = old_next;
4688         break;
4689     default:
4690         JMPENV_POP;
4691         PL_warnhook = oldwarnhook;
4692         PL_diehook = olddiehook;
4693         Perl_croak(aTHX_ "panic: gen_constant_list JMPENV_PUSH returned %d",
4694             ret);
4695     }
4696
4697     JMPENV_POP;
4698     PL_dowarn = oldwarn;
4699     PL_warnhook = oldwarnhook;
4700     PL_diehook = olddiehook;
4701     PL_curcop = old_curcop;
4702
4703     if (cxstack_ix > old_cxix) {
4704         assert(cxstack_ix == old_cxix + 1);
4705         assert(CxTYPE(CX_CUR()) == CXt_EVAL);
4706         delete_eval_scope();
4707     }
4708     if (ret)
4709         return o;
4710
4711     OpTYPE_set(o, OP_RV2AV);
4712     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
4713     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
4714     o->op_opt = 0;              /* needs to be revisited in rpeep() */
4715     av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
4716
4717     /* replace subtree with an OP_CONST */
4718     curop = ((UNOP*)o)->op_first;
4719     op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
4720     op_free(curop);
4721
4722     if (AvFILLp(av) != -1)
4723         for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
4724         {
4725             SvPADTMP_on(*svp);
4726             SvREADONLY_on(*svp);
4727         }
4728     LINKLIST(o);
4729     return list(o);
4730 }
4731
4732 /*
4733 =head1 Optree Manipulation Functions
4734 */
4735
4736 /* List constructors */
4737
4738 /*
4739 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
4740
4741 Append an item to the list of ops contained directly within a list-type
4742 op, returning the lengthened list.  C<first> is the list-type op,
4743 and C<last> is the op to append to the list.  C<optype> specifies the
4744 intended opcode for the list.  If C<first> is not already a list of the
4745 right type, it will be upgraded into one.  If either C<first> or C<last>
4746 is null, the other is returned unchanged.
4747
4748 =cut
4749 */
4750
4751 OP *
4752 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
4753 {
4754     if (!first)
4755         return last;
4756
4757     if (!last)
4758         return first;
4759
4760     if (first->op_type != (unsigned)type
4761         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
4762     {
4763         return newLISTOP(type, 0, first, last);
4764     }
4765
4766     op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
4767     first->op_flags |= OPf_KIDS;
4768     return first;
4769 }
4770
4771 /*
4772 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
4773
4774 Concatenate the lists of ops contained directly within two list-type ops,
4775 returning the combined list.  C<first> and C<last> are the list-type ops
4776 to concatenate.  C<optype> specifies the intended opcode for the list.
4777 If either C<first> or C<last> is not already a list of the right type,
4778 it will be upgraded into one.  If either C<first> or C<last> is null,
4779 the other is returned unchanged.
4780
4781 =cut
4782 */
4783
4784 OP *
4785 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
4786 {
4787     if (!first)
4788         return last;
4789
4790     if (!last)
4791         return first;
4792
4793     if (first->op_type != (unsigned)type)
4794         return op_prepend_elem(type, first, last);
4795
4796     if (last->op_type != (unsigned)type)
4797         return op_append_elem(type, first, last);
4798
4799     OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
4800     ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
4801     OpLASTSIB_set(((LISTOP*)first)->op_last, first);
4802     first->op_flags |= (last->op_flags & OPf_KIDS);
4803
4804     S_op_destroy(aTHX_ last);
4805
4806     return first;
4807 }
4808
4809 /*
4810 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
4811
4812 Prepend an item to the list of ops contained directly within a list-type
4813 op, returning the lengthened list.  C<first> is the op to prepend to the
4814 list, and C<last> is the list-type op.  C<optype> specifies the intended
4815 opcode for the list.  If C<last> is not already a list of the right type,
4816 it will be upgraded into one.  If either C<first> or C<last> is null,
4817 the other is returned unchanged.
4818
4819 =cut
4820 */
4821
4822 OP *
4823 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
4824 {
4825     if (!first)
4826         return last;
4827
4828     if (!last)
4829         return first;
4830