op.c

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