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
3168         if (o->op_targ != OP_LIST) {
3169             OP *sib = OpSIBLING(cLISTOPo->op_first);
3170             /* OP_TRANS and OP_TRANSR with argument have a weird optree
3171              * that looks like
3172              *
3173              *   null
3174              *      arg
3175              *      trans
3176              *
3177              * compared with things like OP_MATCH which have the argument
3178              * as a child:
3179              *
3180              *   match
3181              *      arg
3182              *
3183              * so handle specially to correctly get "Can't modify" croaks etc
3184              */
3185
3186             if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR))
3187             {
3188                 /* this should trigger a "Can't modify transliteration" err */
3189                 op_lvalue(sib, type);
3190             }
3191             op_lvalue(cBINOPo->op_first, type);
3192             break;
3193         }
3194         /* FALLTHROUGH */
3195     case OP_LIST:
3196         localize = 0;
3197         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3198             /* elements might be in void context because the list is
3199                in scalar context or because they are attribute sub calls */
3200             if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
3201                 op_lvalue(kid, type);
3202         break;
3203
3204     case OP_COREARGS:
3205         return o;
3206
3207     case OP_AND:
3208     case OP_OR:
3209         if (type == OP_LEAVESUBLV
3210          || !S_vivifies(cLOGOPo->op_first->op_type))
3211             op_lvalue(cLOGOPo->op_first, type);
3212         if (type == OP_LEAVESUBLV
3213          || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
3214             op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
3215         goto nomod;
3216
3217     case OP_SREFGEN:
3218         if (type == OP_NULL) { /* local */
3219           local_refgen:
3220             if (!FEATURE_MYREF_IS_ENABLED)
3221                 Perl_croak(aTHX_ "The experimental declared_refs "
3222                                  "feature is not enabled");
3223             Perl_ck_warner_d(aTHX_
3224                      packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
3225                     "Declaring references is experimental");
3226             op_lvalue(cUNOPo->op_first, OP_NULL);
3227             return o;
3228         }
3229         if (type != OP_AASSIGN && type != OP_SASSIGN
3230          && type != OP_ENTERLOOP)
3231             goto nomod;
3232         /* Don’t bother applying lvalue context to the ex-list.  */
3233         kid = cUNOPx(cUNOPo->op_first)->op_first;
3234         assert (!OpHAS_SIBLING(kid));
3235         goto kid_2lvref;
3236     case OP_REFGEN:
3237         if (type == OP_NULL) /* local */
3238             goto local_refgen;
3239         if (type != OP_AASSIGN) goto nomod;
3240         kid = cUNOPo->op_first;
3241       kid_2lvref:
3242         {
3243             const U8 ec = PL_parser ? PL_parser->error_count : 0;
3244             S_lvref(aTHX_ kid, type);
3245             if (!PL_parser || PL_parser->error_count == ec) {
3246                 if (!FEATURE_REFALIASING_IS_ENABLED)
3247                     Perl_croak(aTHX_
3248                        "Experimental aliasing via reference not enabled");
3249                 Perl_ck_warner_d(aTHX_
3250                                  packWARN(WARN_EXPERIMENTAL__REFALIASING),
3251                                 "Aliasing via reference is experimental");
3252             }
3253         }
3254         if (o->op_type == OP_REFGEN)
3255             op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
3256         op_null(o);
3257         return o;
3258
3259     case OP_SPLIT:
3260         if ((o->op_private & OPpSPLIT_ASSIGN)) {
3261             /* This is actually @array = split.  */
3262             PL_modcount = RETURN_UNLIMITED_NUMBER;
3263             break;
3264         }
3265         goto nomod;
3266
3267     case OP_SCALAR:
3268         op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
3269         goto nomod;
3270     }
3271
3272     /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
3273        their argument is a filehandle; thus \stat(".") should not set
3274        it. AMS 20011102 */
3275     if (type == OP_REFGEN &&
3276         PL_check[o->op_type] == Perl_ck_ftst)
3277         return o;
3278
3279     if (type != OP_LEAVESUBLV)
3280         o->op_flags |= OPf_MOD;
3281
3282     if (type == OP_AASSIGN || type == OP_SASSIGN)
3283         o->op_flags |= OPf_SPECIAL
3284                       |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF);
3285     else if (!type) { /* local() */
3286         switch (localize) {
3287         case 1:
3288             o->op_private |= OPpLVAL_INTRO;
3289             o->op_flags &= ~OPf_SPECIAL;
3290             PL_hints |= HINT_BLOCK_SCOPE;
3291             break;
3292         case 0:
3293             break;
3294         case -1:
3295             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
3296                            "Useless localization of %s", OP_DESC(o));
3297         }
3298     }
3299     else if (type != OP_GREPSTART && type != OP_ENTERSUB
3300              && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
3301         o->op_flags |= OPf_REF;
3302     return o;
3303 }
3304
3305 STATIC bool
3306 S_scalar_mod_type(const OP *o, I32 type)
3307 {
3308     switch (type) {
3309     case OP_POS:
3310     case OP_SASSIGN:
3311         if (o && o->op_type == OP_RV2GV)
3312             return FALSE;
3313         /* FALLTHROUGH */
3314     case OP_PREINC:
3315     case OP_PREDEC:
3316     case OP_POSTINC:
3317     case OP_POSTDEC:
3318     case OP_I_PREINC:
3319     case OP_I_PREDEC:
3320     case OP_I_POSTINC:
3321     case OP_I_POSTDEC:
3322     case OP_POW:
3323     case OP_MULTIPLY:
3324     case OP_DIVIDE:
3325     case OP_MODULO:
3326     case OP_REPEAT:
3327     case OP_ADD:
3328     case OP_SUBTRACT:
3329     case OP_I_MULTIPLY:
3330     case OP_I_DIVIDE:
3331     case OP_I_MODULO:
3332     case OP_I_ADD:
3333     case OP_I_SUBTRACT:
3334     case OP_LEFT_SHIFT:
3335     case OP_RIGHT_SHIFT:
3336     case OP_BIT_AND:
3337     case OP_BIT_XOR:
3338     case OP_BIT_OR:
3339     case OP_NBIT_AND:
3340     case OP_NBIT_XOR:
3341     case OP_NBIT_OR:
3342     case OP_SBIT_AND:
3343     case OP_SBIT_XOR:
3344     case OP_SBIT_OR:
3345     case OP_CONCAT:
3346     case OP_SUBST:
3347     case OP_TRANS:
3348     case OP_TRANSR:
3349     case OP_READ:
3350     case OP_SYSREAD:
3351     case OP_RECV:
3352     case OP_ANDASSIGN:
3353     case OP_ORASSIGN:
3354     case OP_DORASSIGN:
3355     case OP_VEC:
3356     case OP_SUBSTR:
3357         return TRUE;
3358     default:
3359         return FALSE;
3360     }
3361 }
3362
3363 STATIC bool
3364 S_is_handle_constructor(const OP *o, I32 numargs)
3365 {
3366     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
3367
3368     switch (o->op_type) {
3369     case OP_PIPE_OP:
3370     case OP_SOCKPAIR:
3371         if (numargs == 2)
3372             return TRUE;
3373         /* FALLTHROUGH */
3374     case OP_SYSOPEN:
3375     case OP_OPEN:
3376     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
3377     case OP_SOCKET:
3378     case OP_OPEN_DIR:
3379     case OP_ACCEPT:
3380         if (numargs == 1)
3381             return TRUE;
3382         /* FALLTHROUGH */
3383     default:
3384         return FALSE;
3385     }
3386 }
3387
3388 static OP *
3389 S_refkids(pTHX_ OP *o, I32 type)
3390 {
3391     if (o && o->op_flags & OPf_KIDS) {
3392         OP *kid;
3393         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3394             ref(kid, type);
3395     }
3396     return o;
3397 }
3398
3399 OP *
3400 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
3401 {
3402     dVAR;
3403     OP *kid;
3404
3405     PERL_ARGS_ASSERT_DOREF;
3406
3407     if (PL_parser && PL_parser->error_count)
3408         return o;
3409
3410     switch (o->op_type) {
3411     case OP_ENTERSUB:
3412         if ((type == OP_EXISTS || type == OP_DEFINED) &&
3413             !(o->op_flags & OPf_STACKED)) {
3414             OpTYPE_set(o, OP_RV2CV);             /* entersub => rv2cv */
3415             assert(cUNOPo->op_first->op_type == OP_NULL);
3416             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
3417             o->op_flags |= OPf_SPECIAL;
3418         }
3419         else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
3420             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3421                               : type == OP_RV2HV ? OPpDEREF_HV
3422                               : OPpDEREF_SV);
3423             o->op_flags |= OPf_MOD;
3424         }
3425
3426         break;
3427
3428     case OP_COND_EXPR:
3429         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
3430             doref(kid, type, set_op_ref);
3431         break;
3432     case OP_RV2SV:
3433         if (type == OP_DEFINED)
3434             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
3435         doref(cUNOPo->op_first, o->op_type, set_op_ref);
3436         /* FALLTHROUGH */
3437     case OP_PADSV:
3438         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3439             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3440                               : type == OP_RV2HV ? OPpDEREF_HV
3441                               : OPpDEREF_SV);
3442             o->op_flags |= OPf_MOD;
3443         }
3444         break;
3445
3446     case OP_RV2AV:
3447     case OP_RV2HV:
3448         if (set_op_ref)
3449             o->op_flags |= OPf_REF;
3450         /* FALLTHROUGH */
3451     case OP_RV2GV:
3452         if (type == OP_DEFINED)
3453             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
3454         doref(cUNOPo->op_first, o->op_type, set_op_ref);
3455         break;
3456
3457     case OP_PADAV:
3458     case OP_PADHV:
3459         if (set_op_ref)
3460             o->op_flags |= OPf_REF;
3461         break;
3462
3463     case OP_SCALAR:
3464     case OP_NULL:
3465         if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
3466             break;
3467         doref(cBINOPo->op_first, type, set_op_ref);
3468         break;
3469     case OP_AELEM:
3470     case OP_HELEM:
3471         doref(cBINOPo->op_first, o->op_type, set_op_ref);
3472         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3473             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3474                               : type == OP_RV2HV ? OPpDEREF_HV
3475                               : OPpDEREF_SV);
3476             o->op_flags |= OPf_MOD;
3477         }
3478         break;
3479
3480     case OP_SCOPE:
3481     case OP_LEAVE:
3482         set_op_ref = FALSE;
3483         /* FALLTHROUGH */
3484     case OP_ENTER:
3485     case OP_LIST:
3486         if (!(o->op_flags & OPf_KIDS))
3487             break;
3488         doref(cLISTOPo->op_last, type, set_op_ref);
3489         break;
3490     default:
3491         break;
3492     }
3493     return scalar(o);
3494
3495 }
3496
3497 STATIC OP *
3498 S_dup_attrlist(pTHX_ OP *o)
3499 {
3500     OP *rop;
3501
3502     PERL_ARGS_ASSERT_DUP_ATTRLIST;
3503
3504     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
3505      * where the first kid is OP_PUSHMARK and the remaining ones
3506      * are OP_CONST.  We need to push the OP_CONST values.
3507      */
3508     if (o->op_type == OP_CONST)
3509         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
3510     else {
3511         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
3512         rop = NULL;
3513         for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
3514             if (o->op_type == OP_CONST)
3515                 rop = op_append_elem(OP_LIST, rop,
3516                                   newSVOP(OP_CONST, o->op_flags,
3517                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
3518         }
3519     }
3520     return rop;
3521 }
3522
3523 STATIC void
3524 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
3525 {
3526     PERL_ARGS_ASSERT_APPLY_ATTRS;
3527     {
3528         SV * const stashsv = newSVhek(HvNAME_HEK(stash));
3529
3530         /* fake up C<use attributes $pkg,$rv,@attrs> */
3531
3532 #define ATTRSMODULE "attributes"
3533 #define ATTRSMODULE_PM "attributes.pm"
3534
3535         Perl_load_module(
3536           aTHX_ PERL_LOADMOD_IMPORT_OPS,
3537           newSVpvs(ATTRSMODULE),
3538           NULL,
3539           op_prepend_elem(OP_LIST,
3540                           newSVOP(OP_CONST, 0, stashsv),
3541                           op_prepend_elem(OP_LIST,
3542                                           newSVOP(OP_CONST, 0,
3543                                                   newRV(target)),
3544                                           dup_attrlist(attrs))));
3545     }
3546 }
3547
3548 STATIC void
3549 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
3550 {
3551     OP *pack, *imop, *arg;
3552     SV *meth, *stashsv, **svp;
3553
3554     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
3555
3556     if (!attrs)
3557         return;
3558
3559     assert(target->op_type == OP_PADSV ||
3560            target->op_type == OP_PADHV ||
3561            target->op_type == OP_PADAV);
3562
3563     /* Ensure that attributes.pm is loaded. */
3564     /* Don't force the C<use> if we don't need it. */
3565     svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
3566     if (svp && *svp != &PL_sv_undef)
3567         NOOP;   /* already in %INC */
3568     else
3569         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
3570                                newSVpvs(ATTRSMODULE), NULL);
3571
3572     /* Need package name for method call. */
3573     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
3574
3575     /* Build up the real arg-list. */
3576     stashsv = newSVhek(HvNAME_HEK(stash));
3577
3578     arg = newOP(OP_PADSV, 0);
3579     arg->op_targ = target->op_targ;
3580     arg = op_prepend_elem(OP_LIST,
3581                        newSVOP(OP_CONST, 0, stashsv),
3582                        op_prepend_elem(OP_LIST,
3583                                     newUNOP(OP_REFGEN, 0,
3584                                             arg),
3585                                     dup_attrlist(attrs)));
3586
3587     /* Fake up a method call to import */
3588     meth = newSVpvs_share("import");
3589     imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
3590                    op_append_elem(OP_LIST,
3591                                op_prepend_elem(OP_LIST, pack, arg),
3592                                newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
3593
3594     /* Combine the ops. */
3595     *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
3596 }
3597
3598 /*
3599 =notfor apidoc apply_attrs_string
3600
3601 Attempts to apply a list of attributes specified by the C<attrstr> and
3602 C<len> arguments to the subroutine identified by the C<cv> argument which
3603 is expected to be associated with the package identified by the C<stashpv>
3604 argument (see L<attributes>).  It gets this wrong, though, in that it
3605 does not correctly identify the boundaries of the individual attribute
3606 specifications within C<attrstr>.  This is not really intended for the
3607 public API, but has to be listed here for systems such as AIX which
3608 need an explicit export list for symbols.  (It's called from XS code
3609 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
3610 to respect attribute syntax properly would be welcome.
3611
3612 =cut
3613 */
3614
3615 void
3616 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
3617                         const char *attrstr, STRLEN len)
3618 {
3619     OP *attrs = NULL;
3620
3621     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
3622
3623     if (!len) {
3624         len = strlen(attrstr);
3625     }
3626
3627     while (len) {
3628         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
3629         if (len) {
3630             const char * const sstr = attrstr;
3631             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
3632             attrs = op_append_elem(OP_LIST, attrs,
3633                                 newSVOP(OP_CONST, 0,
3634                                         newSVpvn(sstr, attrstr-sstr)));
3635         }
3636     }
3637
3638     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3639                      newSVpvs(ATTRSMODULE),
3640                      NULL, op_prepend_elem(OP_LIST,
3641                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
3642                                   op_prepend_elem(OP_LIST,
3643                                                newSVOP(OP_CONST, 0,
3644                                                        newRV(MUTABLE_SV(cv))),
3645                                                attrs)));
3646 }
3647
3648 STATIC void
3649 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
3650 {
3651     OP *new_proto = NULL;
3652     STRLEN pvlen;
3653     char *pv;
3654     OP *o;
3655
3656     PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
3657
3658     if (!*attrs)
3659         return;
3660
3661     o = *attrs;
3662     if (o->op_type == OP_CONST) {
3663         pv = SvPV(cSVOPo_sv, pvlen);
3664         if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3665             SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3666             SV ** const tmpo = cSVOPx_svp(o);
3667             SvREFCNT_dec(cSVOPo_sv);
3668             *tmpo = tmpsv;
3669             new_proto = o;
3670             *attrs = NULL;
3671         }
3672     } else if (o->op_type == OP_LIST) {
3673         OP * lasto;
3674         assert(o->op_flags & OPf_KIDS);
3675         lasto = cLISTOPo->op_first;
3676         assert(lasto->op_type == OP_PUSHMARK);
3677         for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
3678             if (o->op_type == OP_CONST) {
3679                 pv = SvPV(cSVOPo_sv, pvlen);
3680                 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3681                     SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3682                     SV ** const tmpo = cSVOPx_svp(o);
3683                     SvREFCNT_dec(cSVOPo_sv);
3684                     *tmpo = tmpsv;
3685                     if (new_proto && ckWARN(WARN_MISC)) {
3686                         STRLEN new_len;
3687                         const char * newp = SvPV(cSVOPo_sv, new_len);
3688                         Perl_warner(aTHX_ packWARN(WARN_MISC),
3689                             "Attribute prototype(%" UTF8f ") discards earlier prototype attribute in same sub",
3690                             UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
3691                         op_free(new_proto);
3692                     }
3693                     else if (new_proto)
3694                         op_free(new_proto);
3695                     new_proto = o;
3696                     /* excise new_proto from the list */
3697                     op_sibling_splice(*attrs, lasto, 1, NULL);
3698                     o = lasto;
3699                     continue;
3700                 }
3701             }
3702             lasto = o;
3703         }
3704         /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
3705            would get pulled in with no real need */
3706         if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
3707             op_free(*attrs);
3708             *attrs = NULL;
3709         }
3710     }
3711
3712     if (new_proto) {
3713         SV *svname;
3714         if (isGV(name)) {
3715             svname = sv_newmortal();
3716             gv_efullname3(svname, name, NULL);
3717         }
3718         else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
3719             svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
3720         else
3721             svname = (SV *)name;
3722         if (ckWARN(WARN_ILLEGALPROTO))
3723             (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
3724         if (*proto && ckWARN(WARN_PROTOTYPE)) {
3725             STRLEN old_len, new_len;
3726             const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
3727             const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
3728
3729             Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3730                 "Prototype '%" UTF8f "' overridden by attribute 'prototype(%" UTF8f ")'"
3731                 " in %" SVf,
3732                 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
3733                 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
3734                 SVfARG(svname));
3735         }
3736         if (*proto)
3737             op_free(*proto);
3738         *proto = new_proto;
3739     }
3740 }
3741
3742 static void
3743 S_cant_declare(pTHX_ OP *o)
3744 {
3745     if (o->op_type == OP_NULL
3746      && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
3747         o = cUNOPo->op_first;
3748     yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
3749                              o->op_type == OP_NULL
3750                                && o->op_flags & OPf_SPECIAL
3751                                  ? "do block"
3752                                  : OP_DESC(o),
3753                              PL_parser->in_my == KEY_our   ? "our"   :
3754                              PL_parser->in_my == KEY_state ? "state" :
3755                                                              "my"));
3756 }
3757
3758 STATIC OP *
3759 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
3760 {
3761     I32 type;
3762     const bool stately = PL_parser && PL_parser->in_my == KEY_state;
3763
3764     PERL_ARGS_ASSERT_MY_KID;
3765
3766     if (!o || (PL_parser && PL_parser->error_count))
3767         return o;
3768
3769     type = o->op_type;
3770
3771     if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
3772         OP *kid;
3773         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3774             my_kid(kid, attrs, imopsp);
3775         return o;
3776     } else if (type == OP_UNDEF || type == OP_STUB) {
3777         return o;
3778     } else if (type == OP_RV2SV ||      /* "our" declaration */
3779                type == OP_RV2AV ||
3780                type == OP_RV2HV) {
3781         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
3782             S_cant_declare(aTHX_ o);
3783         } else if (attrs) {
3784             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
3785             assert(PL_parser);
3786             PL_parser->in_my = FALSE;
3787             PL_parser->in_my_stash = NULL;
3788             apply_attrs(GvSTASH(gv),
3789                         (type == OP_RV2SV ? GvSV(gv) :
3790                          type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
3791                          type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
3792                         attrs);
3793         }
3794         o->op_private |= OPpOUR_INTRO;
3795         return o;
3796     }
3797     else if (type == OP_REFGEN || type == OP_SREFGEN) {
3798         if (!FEATURE_MYREF_IS_ENABLED)
3799             Perl_croak(aTHX_ "The experimental declared_refs "
3800                              "feature is not enabled");
3801         Perl_ck_warner_d(aTHX_
3802              packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
3803             "Declaring references is experimental");
3804         /* Kid is a nulled OP_LIST, handled above.  */
3805         my_kid(cUNOPo->op_first, attrs, imopsp);
3806         return o;
3807     }
3808     else if (type != OP_PADSV &&
3809              type != OP_PADAV &&
3810              type != OP_PADHV &&
3811              type != OP_PUSHMARK)
3812     {
3813         S_cant_declare(aTHX_ o);
3814         return o;
3815     }
3816     else if (attrs && type != OP_PUSHMARK) {
3817         HV *stash;
3818
3819         assert(PL_parser);
3820         PL_parser->in_my = FALSE;
3821         PL_parser->in_my_stash = NULL;
3822
3823         /* check for C<my Dog $spot> when deciding package */
3824         stash = PAD_COMPNAME_TYPE(o->op_targ);
3825         if (!stash)
3826             stash = PL_curstash;
3827         apply_attrs_my(stash, o, attrs, imopsp);
3828     }
3829     o->op_flags |= OPf_MOD;
3830     o->op_private |= OPpLVAL_INTRO;
3831     if (stately)
3832         o->op_private |= OPpPAD_STATE;
3833     return o;
3834 }
3835
3836 OP *
3837 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
3838 {
3839     OP *rops;
3840     int maybe_scalar = 0;
3841
3842     PERL_ARGS_ASSERT_MY_ATTRS;
3843
3844 /* [perl #17376]: this appears to be premature, and results in code such as
3845    C< our(%x); > executing in list mode rather than void mode */
3846 #if 0
3847     if (o->op_flags & OPf_PARENS)
3848         list(o);
3849     else
3850         maybe_scalar = 1;
3851 #else
3852     maybe_scalar = 1;
3853 #endif
3854     if (attrs)
3855         SAVEFREEOP(attrs);
3856     rops = NULL;
3857     o = my_kid(o, attrs, &rops);
3858     if (rops) {
3859         if (maybe_scalar && o->op_type == OP_PADSV) {
3860             o = scalar(op_append_list(OP_LIST, rops, o));
3861             o->op_private |= OPpLVAL_INTRO;
3862         }
3863         else {
3864             /* The listop in rops might have a pushmark at the beginning,
3865                which will mess up list assignment. */
3866             LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
3867             if (rops->op_type == OP_LIST &&
3868                 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
3869             {
3870                 OP * const pushmark = lrops->op_first;
3871                 /* excise pushmark */
3872                 op_sibling_splice(rops, NULL, 1, NULL);
3873                 op_free(pushmark);
3874             }
3875             o = op_append_list(OP_LIST, o, rops);
3876         }
3877     }
3878     PL_parser->in_my = FALSE;
3879     PL_parser->in_my_stash = NULL;
3880     return o;
3881 }
3882
3883 OP *
3884 Perl_sawparens(pTHX_ OP *o)
3885 {
3886     PERL_UNUSED_CONTEXT;
3887     if (o)
3888         o->op_flags |= OPf_PARENS;
3889     return o;
3890 }
3891
3892 OP *
3893 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
3894 {
3895     OP *o;
3896     bool ismatchop = 0;
3897     const OPCODE ltype = left->op_type;
3898     const OPCODE rtype = right->op_type;
3899
3900     PERL_ARGS_ASSERT_BIND_MATCH;
3901
3902     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
3903           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
3904     {
3905       const char * const desc
3906           = PL_op_desc[(
3907                           rtype == OP_SUBST || rtype == OP_TRANS
3908                        || rtype == OP_TRANSR
3909                        )
3910                        ? (int)rtype : OP_MATCH];
3911       const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
3912       SV * const name =
3913         S_op_varname(aTHX_ left);
3914       if (name)
3915         Perl_warner(aTHX_ packWARN(WARN_MISC),
3916              "Applying %s to %" SVf " will act on scalar(%" SVf ")",
3917              desc, SVfARG(name), SVfARG(name));
3918       else {
3919         const char * const sample = (isary
3920              ? "@array" : "%hash");
3921         Perl_warner(aTHX_ packWARN(WARN_MISC),
3922              "Applying %s to %s will act on scalar(%s)",
3923              desc, sample, sample);
3924       }
3925     }
3926
3927     if (rtype == OP_CONST &&
3928         cSVOPx(right)->op_private & OPpCONST_BARE &&
3929         cSVOPx(right)->op_private & OPpCONST_STRICT)
3930     {
3931         no_bareword_allowed(right);
3932     }
3933
3934     /* !~ doesn't make sense with /r, so error on it for now */
3935     if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
3936         type == OP_NOT)
3937         /* diag_listed_as: Using !~ with %s doesn't make sense */
3938         yyerror("Using !~ with s///r doesn't make sense");
3939     if (rtype == OP_TRANSR && type == OP_NOT)
3940         /* diag_listed_as: Using !~ with %s doesn't make sense */
3941         yyerror("Using !~ with tr///r doesn't make sense");
3942
3943     ismatchop = (rtype == OP_MATCH ||
3944                  rtype == OP_SUBST ||
3945                  rtype == OP_TRANS || rtype == OP_TRANSR)
3946              && !(right->op_flags & OPf_SPECIAL);
3947     if (ismatchop && right->op_private & OPpTARGET_MY) {
3948         right->op_targ = 0;
3949         right->op_private &= ~OPpTARGET_MY;
3950     }
3951     if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
3952         if (left->op_type == OP_PADSV
3953          && !(left->op_private & OPpLVAL_INTRO))
3954         {
3955             right->op_targ = left->op_targ;
3956             op_free(left);
3957             o = right;
3958         }
3959         else {
3960             right->op_flags |= OPf_STACKED;
3961             if (rtype != OP_MATCH && rtype != OP_TRANSR &&
3962             ! (rtype == OP_TRANS &&
3963                right->op_private & OPpTRANS_IDENTICAL) &&
3964             ! (rtype == OP_SUBST &&
3965                (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3966                 left = op_lvalue(left, rtype);
3967             if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
3968                 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
3969             else
3970                 o = op_prepend_elem(rtype, scalar(left), right);
3971         }
3972         if (type == OP_NOT)
3973             return newUNOP(OP_NOT, 0, scalar(o));
3974         return o;
3975     }
3976     else
3977         return bind_match(type, left,
3978                 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
3979 }
3980
3981 OP *
3982 Perl_invert(pTHX_ OP *o)
3983 {
3984     if (!o)
3985         return NULL;
3986     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
3987 }
3988
3989 /*
3990 =for apidoc Amx|OP *|op_scope|OP *o
3991
3992 Wraps up an op tree with some additional ops so that at runtime a dynamic
3993 scope will be created.  The original ops run in the new dynamic scope,
3994 and then, provided that they exit normally, the scope will be unwound.
3995 The additional ops used to create and unwind the dynamic scope will
3996 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
3997 instead if the ops are simple enough to not need the full dynamic scope
3998 structure.
3999
4000 =cut
4001 */
4002
4003 OP *
4004 Perl_op_scope(pTHX_ OP *o)
4005 {
4006     dVAR;
4007     if (o) {
4008         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
4009             o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
4010             OpTYPE_set(o, OP_LEAVE);
4011         }
4012         else if (o->op_type == OP_LINESEQ) {
4013             OP *kid;
4014             OpTYPE_set(o, OP_SCOPE);
4015             kid = ((LISTOP*)o)->op_first;
4016             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
4017                 op_null(kid);
4018
4019                 /* The following deals with things like 'do {1 for 1}' */
4020                 kid = OpSIBLING(kid);
4021                 if (kid &&
4022                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
4023                     op_null(kid);
4024             }
4025         }
4026         else
4027             o = newLISTOP(OP_SCOPE, 0, o, NULL);
4028     }
4029     return o;
4030 }
4031
4032 OP *
4033 Perl_op_unscope(pTHX_ OP *o)
4034 {
4035     if (o && o->op_type == OP_LINESEQ) {
4036         OP *kid = cLISTOPo->op_first;
4037         for(; kid; kid = OpSIBLING(kid))
4038             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
4039                 op_null(kid);
4040     }
4041     return o;
4042 }
4043
4044 /*
4045 =for apidoc Am|int|block_start|int full
4046
4047 Handles compile-time scope entry.
4048 Arranges for hints to be restored on block
4049 exit and also handles pad sequence numbers to make lexical variables scope
4050 right.  Returns a savestack index for use with C<block_end>.
4051
4052 =cut
4053 */
4054
4055 int
4056 Perl_block_start(pTHX_ int full)
4057 {
4058     const int retval = PL_savestack_ix;
4059
4060     PL_compiling.cop_seq = PL_cop_seqmax;
4061     COP_SEQMAX_INC;
4062     pad_block_start(full);
4063     SAVEHINTS();
4064     PL_hints &= ~HINT_BLOCK_SCOPE;
4065     SAVECOMPILEWARNINGS();
4066     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
4067     SAVEI32(PL_compiling.cop_seq);
4068     PL_compiling.cop_seq = 0;
4069
4070     CALL_BLOCK_HOOKS(bhk_start, full);
4071
4072     return retval;
4073 }
4074
4075 /*
4076 =for apidoc Am|OP *|block_end|I32 floor|OP *seq
4077
4078 Handles compile-time scope exit.  C<floor>
4079 is the savestack index returned by
4080 C<block_start>, and C<seq> is the body of the block.  Returns the block,
4081 possibly modified.
4082
4083 =cut
4084 */
4085
4086 OP*
4087 Perl_block_end(pTHX_ I32 floor, OP *seq)
4088 {
4089     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
4090     OP* retval = scalarseq(seq);
4091     OP *o;
4092
4093     /* XXX Is the null PL_parser check necessary here? */
4094     assert(PL_parser); /* Let’s find out under debugging builds.  */
4095     if (PL_parser && PL_parser->parsed_sub) {
4096         o = newSTATEOP(0, NULL, NULL);
4097         op_null(o);
4098         retval = op_append_elem(OP_LINESEQ, retval, o);
4099     }
4100
4101     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
4102
4103     LEAVE_SCOPE(floor);
4104     if (needblockscope)
4105         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
4106     o = pad_leavemy();
4107
4108     if (o) {
4109         /* pad_leavemy has created a sequence of introcv ops for all my
4110            subs declared in the block.  We have to replicate that list with
4111            clonecv ops, to deal with this situation:
4112
4113                sub {
4114                    my sub s1;
4115                    my sub s2;
4116                    sub s1 { state sub foo { \&s2 } }
4117                }->()
4118
4119            Originally, I was going to have introcv clone the CV and turn
4120            off the stale flag.  Since &s1 is declared before &s2, the
4121            introcv op for &s1 is executed (on sub entry) before the one for
4122            &s2.  But the &foo sub inside &s1 (which is cloned when &s1 is
4123            cloned, since it is a state sub) closes over &s2 and expects
4124            to see it in its outer CV’s pad.  If the introcv op clones &s1,
4125            then &s2 is still marked stale.  Since &s1 is not active, and
4126            &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
4127            ble will not stay shared’ warning.  Because it is the same stub
4128            that will be used when the introcv op for &s2 is executed, clos-
4129            ing over it is safe.  Hence, we have to turn off the stale flag
4130            on all lexical subs in the block before we clone any of them.
4131            Hence, having introcv clone the sub cannot work.  So we create a
4132            list of ops like this:
4133
4134                lineseq
4135                   |
4136                   +-- introcv
4137                   |
4138                   +-- introcv
4139                   |
4140                   +-- introcv
4141                   |
4142                   .
4143                   .
4144                   .
4145                   |
4146                   +-- clonecv
4147                   |
4148                   +-- clonecv
4149                   |
4150                   +-- clonecv
4151                   |
4152                   .
4153                   .
4154                   .
4155          */
4156         OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
4157         OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
4158         for (;; kid = OpSIBLING(kid)) {
4159             OP *newkid = newOP(OP_CLONECV, 0);
4160             newkid->op_targ = kid->op_targ;
4161             o = op_append_elem(OP_LINESEQ, o, newkid);
4162             if (kid == last) break;
4163         }
4164         retval = op_prepend_elem(OP_LINESEQ, o, retval);
4165     }
4166
4167     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
4168
4169     return retval;
4170 }
4171
4172 /*
4173 =head1 Compile-time scope hooks
4174
4175 =for apidoc Aox||blockhook_register
4176
4177 Register a set of hooks to be called when the Perl lexical scope changes
4178 at compile time.  See L<perlguts/"Compile-time scope hooks">.
4179
4180 =cut
4181 */
4182
4183 void
4184 Perl_blockhook_register(pTHX_ BHK *hk)
4185 {
4186     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
4187
4188     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
4189 }
4190
4191 void
4192 Perl_newPROG(pTHX_ OP *o)
4193 {
4194     PERL_ARGS_ASSERT_NEWPROG;
4195
4196     if (PL_in_eval) {
4197         PERL_CONTEXT *cx;
4198         I32 i;
4199         if (PL_eval_root)
4200                 return;
4201         PL_eval_root = newUNOP(OP_LEAVEEVAL,
4202                                ((PL_in_eval & EVAL_KEEPERR)
4203                                 ? OPf_SPECIAL : 0), o);
4204
4205         cx = CX_CUR();
4206         assert(CxTYPE(cx) == CXt_EVAL);
4207
4208         if ((cx->blk_gimme & G_WANT) == G_VOID)
4209             scalarvoid(PL_eval_root);
4210         else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
4211             list(PL_eval_root);
4212         else
4213             scalar(PL_eval_root);
4214
4215         PL_eval_start = op_linklist(PL_eval_root);
4216         PL_eval_root->op_private |= OPpREFCOUNTED;
4217         OpREFCNT_set(PL_eval_root, 1);
4218         PL_eval_root->op_next = 0;
4219         i = PL_savestack_ix;
4220         SAVEFREEOP(o);
4221         ENTER;
4222         CALL_PEEP(PL_eval_start);
4223         finalize_optree(PL_eval_root);
4224         S_prune_chain_head(&PL_eval_start);
4225         LEAVE;
4226         PL_savestack_ix = i;
4227     }
4228     else {
4229         if (o->op_type == OP_STUB) {
4230             /* This block is entered if nothing is compiled for the main
4231                program. This will be the case for an genuinely empty main
4232                program, or one which only has BEGIN blocks etc, so already
4233                run and freed.
4234
4235                Historically (5.000) the guard above was !o. However, commit
4236                f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
4237                c71fccf11fde0068, changed perly.y so that newPROG() is now
4238                called with the output of block_end(), which returns a new
4239                OP_STUB for the case of an empty optree. ByteLoader (and
4240                maybe other things) also take this path, because they set up
4241                PL_main_start and PL_main_root directly, without generating an
4242                optree.
4243
4244                If the parsing the main program aborts (due to parse errors,
4245                or due to BEGIN or similar calling exit), then newPROG()
4246                isn't even called, and hence this code path and its cleanups
4247                are skipped. This shouldn't make a make a difference:
4248                * a non-zero return from perl_parse is a failure, and
4249                  perl_destruct() should be called immediately.
4250                * however, if exit(0) is called during the parse, then
4251                  perl_parse() returns 0, and perl_run() is called. As
4252                  PL_main_start will be NULL, perl_run() will return
4253                  promptly, and the exit code will remain 0.
4254             */
4255
4256             PL_comppad_name = 0;
4257             PL_compcv = 0;
4258             S_op_destroy(aTHX_ o);
4259             return;
4260         }
4261         PL_main_root = op_scope(sawparens(scalarvoid(o)));
4262         PL_curcop = &PL_compiling;
4263         PL_main_start = LINKLIST(PL_main_root);
4264         PL_main_root->op_private |= OPpREFCOUNTED;
4265         OpREFCNT_set(PL_main_root, 1);
4266         PL_main_root->op_next = 0;
4267         CALL_PEEP(PL_main_start);
4268         finalize_optree(PL_main_root);
4269         S_prune_chain_head(&PL_main_start);
4270         cv_forget_slab(PL_compcv);
4271         PL_compcv = 0;
4272
4273         /* Register with debugger */
4274         if (PERLDB_INTER) {
4275             CV * const cv = get_cvs("DB::postponed", 0);
4276             if (cv) {
4277                 dSP;
4278                 PUSHMARK(SP);
4279                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
4280                 PUTBACK;
4281                 call_sv(MUTABLE_SV(cv), G_DISCARD);
4282             }
4283         }
4284     }
4285 }
4286
4287 OP *
4288 Perl_localize(pTHX_ OP *o, I32 lex)
4289 {
4290     PERL_ARGS_ASSERT_LOCALIZE;
4291
4292     if (o->op_flags & OPf_PARENS)
4293 /* [perl #17376]: this appears to be premature, and results in code such as
4294    C< our(%x); > executing in list mode rather than void mode */
4295 #if 0
4296         list(o);
4297 #else
4298         NOOP;
4299 #endif
4300     else {
4301         if ( PL_parser->bufptr > PL_parser->oldbufptr
4302             && PL_parser->bufptr[-1] == ','
4303             && ckWARN(WARN_PARENTHESIS))
4304         {
4305             char *s = PL_parser->bufptr;
4306             bool sigil = FALSE;
4307
4308             /* some heuristics to detect a potential error */
4309             while (*s && (strchr(", \t\n", *s)))
4310                 s++;
4311
4312             while (1) {
4313                 if (*s && (strchr("@$%", *s) || (!lex && *s == '*'))
4314                        && *++s
4315                        && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
4316                     s++;
4317                     sigil = TRUE;
4318                     while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
4319                         s++;
4320                     while (*s && (strchr(", \t\n", *s)))
4321                         s++;
4322                 }
4323                 else
4324                     break;
4325             }
4326             if (sigil && (*s == ';' || *s == '=')) {
4327                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
4328                                 "Parentheses missing around \"%s\" list",
4329                                 lex
4330                                     ? (PL_parser->in_my == KEY_our
4331                                         ? "our"
4332                                         : PL_parser->in_my == KEY_state
4333                                             ? "state"
4334                                             : "my")
4335                                     : "local");
4336             }
4337         }
4338     }
4339     if (lex)
4340         o = my(o);
4341     else
4342         o = op_lvalue(o, OP_NULL);              /* a bit kludgey */
4343     PL_parser->in_my = FALSE;
4344     PL_parser->in_my_stash = NULL;
4345     return o;
4346 }
4347
4348 OP *
4349 Perl_jmaybe(pTHX_ OP *o)
4350 {
4351     PERL_ARGS_ASSERT_JMAYBE;
4352
4353     if (o->op_type == OP_LIST) {
4354         OP * const o2
4355             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
4356         o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
4357     }
4358     return o;
4359 }
4360
4361 PERL_STATIC_INLINE OP *
4362 S_op_std_init(pTHX_ OP *o)
4363 {
4364     I32 type = o->op_type;
4365
4366     PERL_ARGS_ASSERT_OP_STD_INIT;
4367
4368     if (PL_opargs[type] & OA_RETSCALAR)
4369         scalar(o);
4370     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
4371         o->op_targ = pad_alloc(type, SVs_PADTMP);
4372
4373     return o;
4374 }
4375
4376 PERL_STATIC_INLINE OP *
4377 S_op_integerize(pTHX_ OP *o)
4378 {
4379     I32 type = o->op_type;
4380
4381     PERL_ARGS_ASSERT_OP_INTEGERIZE;
4382
4383     /* integerize op. */
4384     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
4385     {
4386         dVAR;
4387         o->op_ppaddr = PL_ppaddr[++(o->op_type)];
4388     }
4389
4390     if (type == OP_NEGATE)
4391         /* XXX might want a ck_negate() for this */
4392         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
4393
4394     return o;
4395 }
4396
4397 static OP *
4398 S_fold_constants(pTHX_ OP *const o)
4399 {
4400     dVAR;
4401     OP * VOL curop;
4402     OP *newop;
4403     VOL I32 type = o->op_type;
4404     bool is_stringify;
4405     SV * VOL sv = NULL;
4406     int ret = 0;
4407     OP *old_next;
4408     SV * const oldwarnhook = PL_warnhook;
4409     SV * const olddiehook  = PL_diehook;
4410     COP not_compiling;
4411     U8 oldwarn = PL_dowarn;
4412     I32 old_cxix;
4413     dJMPENV;
4414
4415     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
4416
4417     if (!(PL_opargs[type] & OA_FOLDCONST))
4418         goto nope;
4419
4420     switch (type) {
4421     case OP_UCFIRST:
4422     case OP_LCFIRST:
4423     case OP_UC:
4424     case OP_LC:
4425     case OP_FC:
4426 #ifdef USE_LOCALE_CTYPE
4427         if (IN_LC_COMPILETIME(LC_CTYPE))
4428             goto nope;
4429 #endif
4430         break;
4431     case OP_SLT:
4432     case OP_SGT:
4433     case OP_SLE:
4434     case OP_SGE:
4435     case OP_SCMP:
4436 #ifdef USE_LOCALE_COLLATE
4437         if (IN_LC_COMPILETIME(LC_COLLATE))
4438             goto nope;
4439 #endif
4440         break;
4441     case OP_SPRINTF:
4442         /* XXX what about the numeric ops? */
4443 #ifdef USE_LOCALE_NUMERIC
4444         if (IN_LC_COMPILETIME(LC_NUMERIC))
4445             goto nope;
4446 #endif
4447         break;
4448     case OP_PACK:
4449         if (!OpHAS_SIBLING(cLISTOPo->op_first)
4450           || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
4451             goto nope;
4452         {
4453             SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
4454             if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
4455             {
4456                 const char *s = SvPVX_const(sv);
4457                 while (s < SvEND(sv)) {
4458                     if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
4459                     s++;
4460                 }
4461             }
4462         }
4463         break;
4464     case OP_REPEAT:
4465         if (o->op_private & OPpREPEAT_DOLIST) goto nope;
4466         break;
4467     case OP_SREFGEN:
4468         if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
4469          || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
4470             goto nope;
4471     }
4472
4473     if (PL_parser && PL_parser->error_count)
4474         goto nope;              /* Don't try to run w/ errors */
4475
4476     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4477         switch (curop->op_type) {
4478         case OP_CONST:
4479             if (   (curop->op_private & OPpCONST_BARE)
4480                 && (curop->op_private & OPpCONST_STRICT)) {
4481                 no_bareword_allowed(curop);
4482                 goto nope;
4483             }
4484             /* FALLTHROUGH */
4485         case OP_LIST:
4486         case OP_SCALAR:
4487         case OP_NULL:
4488         case OP_PUSHMARK:
4489             /* Foldable; move to next op in list */
4490             break;
4491
4492         default:
4493             /* No other op types are considered foldable */
4494             goto nope;
4495         }
4496     }
4497
4498     curop = LINKLIST(o);
4499     old_next = o->op_next;
4500     o->op_next = 0;
4501     PL_op = curop;
4502
4503     old_cxix = cxstack_ix;
4504     create_eval_scope(NULL, G_FAKINGEVAL);
4505
4506     /* Verify that we don't need to save it:  */
4507     assert(PL_curcop == &PL_compiling);
4508     StructCopy(&PL_compiling, &not_compiling, COP);
4509     PL_curcop = &not_compiling;
4510     /* The above ensures that we run with all the correct hints of the
4511        currently compiling COP, but that IN_PERL_RUNTIME is true. */
4512     assert(IN_PERL_RUNTIME);
4513     PL_warnhook = PERL_WARNHOOK_FATAL;
4514     PL_diehook  = NULL;
4515     JMPENV_PUSH(ret);
4516
4517     /* Effective $^W=1.  */
4518     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
4519         PL_dowarn |= G_WARN_ON;
4520
4521     switch (ret) {
4522     case 0:
4523         CALLRUNOPS(aTHX);
4524         sv = *(PL_stack_sp--);
4525         if (o->op_targ && sv == PAD_SV(o->op_targ)) {   /* grab pad temp? */
4526             pad_swipe(o->op_targ,  FALSE);
4527         }
4528         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
4529             SvREFCNT_inc_simple_void(sv);
4530             SvTEMP_off(sv);
4531         }
4532         else { assert(SvIMMORTAL(sv)); }
4533         break;
4534     case 3:
4535         /* Something tried to die.  Abandon constant folding.  */
4536         /* Pretend the error never happened.  */
4537         CLEAR_ERRSV();
4538         o->op_next = old_next;
4539         break;
4540     default:
4541         JMPENV_POP;
4542         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
4543         PL_warnhook = oldwarnhook;
4544         PL_diehook  = olddiehook;
4545         /* XXX note that this croak may fail as we've already blown away
4546          * the stack - eg any nested evals */
4547         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
4548     }
4549     JMPENV_POP;
4550     PL_dowarn   = oldwarn;
4551     PL_warnhook = oldwarnhook;
4552     PL_diehook  = olddiehook;
4553     PL_curcop = &PL_compiling;
4554
4555     /* if we croaked, depending on how we croaked the eval scope
4556      * may or may not have already been popped */
4557     if (cxstack_ix > old_cxix) {
4558         assert(cxstack_ix == old_cxix + 1);
4559         assert(CxTYPE(CX_CUR()) == CXt_EVAL);
4560         delete_eval_scope();
4561     }
4562     if (ret)
4563         goto nope;
4564
4565     /* OP_STRINGIFY and constant folding are used to implement qq.
4566        Here the constant folding is an implementation detail that we
4567        want to hide.  If the stringify op is itself already marked
4568        folded, however, then it is actually a folded join.  */
4569     is_stringify = type == OP_STRINGIFY && !o->op_folded;
4570     op_free(o);
4571     assert(sv);
4572     if (is_stringify)
4573         SvPADTMP_off(sv);
4574     else if (!SvIMMORTAL(sv)) {
4575         SvPADTMP_on(sv);
4576         SvREADONLY_on(sv);
4577     }
4578     newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
4579     if (!is_stringify) newop->op_folded = 1;
4580     return newop;
4581
4582  nope:
4583     return o;
4584 }
4585
4586 static OP *
4587 S_gen_constant_list(pTHX_ OP *o)
4588 {
4589     dVAR;
4590     OP *curop;
4591     const SSize_t oldtmps_floor = PL_tmps_floor;
4592     SV **svp;
4593     AV *av;
4594
4595     list(o);
4596     if (PL_parser && PL_parser->error_count)
4597         return o;               /* Don't attempt to run with errors */
4598
4599     curop = LINKLIST(o);
4600     o->op_next = 0;
4601     CALL_PEEP(curop);
4602     S_prune_chain_head(&curop);
4603     PL_op = curop;
4604     Perl_pp_pushmark(aTHX);
4605     CALLRUNOPS(aTHX);
4606     PL_op = curop;
4607     assert (!(curop->op_flags & OPf_SPECIAL));
4608     assert(curop->op_type == OP_RANGE);
4609     Perl_pp_anonlist(aTHX);
4610     PL_tmps_floor = oldtmps_floor;
4611
4612     OpTYPE_set(o, OP_RV2AV);
4613     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
4614     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
4615     o->op_opt = 0;              /* needs to be revisited in rpeep() */
4616     av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
4617
4618     /* replace subtree with an OP_CONST */
4619     curop = ((UNOP*)o)->op_first;
4620     op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
4621     op_free(curop);
4622
4623     if (AvFILLp(av) != -1)
4624         for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
4625         {
4626             SvPADTMP_on(*svp);
4627             SvREADONLY_on(*svp);
4628         }
4629     LINKLIST(o);
4630     return list(o);
4631 }
4632
4633 /*
4634 =head1 Optree Manipulation Functions
4635 */
4636
4637 /* List constructors */
4638
4639 /*
4640 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
4641
4642 Append an item to the list of ops contained directly within a list-type
4643 op, returning the lengthened list.  C<first> is the list-type op,
4644 and C<last> is the op to append to the list.  C<optype> specifies the
4645 intended opcode for the list.  If C<first> is not already a list of the
4646 right type, it will be upgraded into one.  If either C<first> or C<last>
4647 is null, the other is returned unchanged.
4648
4649 =cut
4650 */
4651
4652 OP *
4653 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
4654 {
4655     if (!first)
4656         return last;
4657
4658     if (!last)
4659         return first;
4660
4661     if (first->op_type != (unsigned)type
4662         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
4663     {
4664         return newLISTOP(type, 0, first, last);
4665     }
4666
4667     op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
4668     first->op_flags |= OPf_KIDS;
4669     return first;
4670 }
4671
4672 /*
4673 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
4674
4675 Concatenate the lists of ops contained directly within two list-type ops,
4676 returning the combined list.  C<first> and C<last> are the list-type ops
4677 to concatenate.  C<optype> specifies the intended opcode for the list.
4678 If either C<first> or C<last> is not already a list of the right type,
4679 it will be upgraded into one.  If either C<first> or C<last> is null,
4680 the other is returned unchanged.
4681
4682 =cut
4683 */
4684
4685 OP *
4686 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
4687 {
4688     if (!first)
4689         return last;
4690
4691     if (!last)
4692         return first;
4693
4694     if (first->op_type != (unsigned)type)
4695         return op_prepend_elem(type, first, last);
4696
4697     if (last->op_type != (unsigned)type)
4698         return op_append_elem(type, first, last);
4699
4700     OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
4701     ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
4702     OpLASTSIB_set(((LISTOP*)first)->op_last, first);
4703     first->op_flags |= (last->op_flags & OPf_KIDS);
4704
4705     S_op_destroy(aTHX_ last);
4706
4707     return first;
4708 }
4709
4710 /*
4711 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
4712
4713 Prepend an item to the list of ops contained directly within a list-type
4714 op, returning the lengthened list.  C<first> is the op to prepend to the
4715 list, and C<last> is the list-type op.  C<optype> specifies the intended
4716 opcode for the list.  If C<last> is not already a list of the right type,
4717 it will be upgraded into one.  If either C<first> or C<last> is null,
4718 the other is returned unchanged.
4719
4720 =cut
4721 */
4722
4723 OP *
4724 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
4725 {
4726     if (!first)
4727         return last;
4728
4729     if (!last)
4730         return first;
4731
4732     if (last->op_type == (unsigned)type) {
4733         if (type == OP_LIST) {  /* already a PUSHMARK there */
4734             /* insert 'first' after pushmark */
4735             op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
4736             if (!(first->op_flags & OPf_PARENS))
4737                 last->op_flags &= ~OPf_PARENS;
4738         }
4739         else
4740             op_sibling_splice(last, NULL, 0, first);
4741         last->op_flags |= OPf_KIDS;
4742         return last;
4743     }
4744
4745     return newLISTOP(type, 0, first, last);
4746 }
4747
4748 /*
4749 =for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
4750
4751 Converts C<o> into a list op if it is not one already, and then converts it
4752 into the specified C<type>, calling its check function, allocating a target if
4753 it needs one, and folding constants.
4754
4755 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
4756 C<op_prepend_elem> and C<op_append_elem>.  Then finally it is passed to
4757 C<op_convert_list> to make it the right type.
4758
4759 =cut
4760 */
4761
4762 OP *
4763 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
4764 {
4765     dVAR;
4766     if (type < 0) type = -type, flags |= OPf_SPECIAL;
4767     if (!o || o->op_type != OP_LIST)
4768         o = force_list(o, 0);
4769     else
4770     {
4771         o->op_flags &= ~OPf_WANT;
4772         o->op_private &= ~OPpLVAL_INTRO;
4773     }
4774
4775     if (!(PL_opargs[type] & OA_MARK))
4776         op_null(cLISTOPo->op_first);
4777     else {
4778         OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
4779         if (kid2 && kid2->op_type == OP_COREARGS) {
4780             op_null(cLISTOPo->op_first);
4781             kid2->op_private |= OPpCOREARGS_PUSHMARK;
4782         }
4783     }
4784
4785     if (type != OP_SPLIT)
4786         /* At this point o is a LISTOP, but OP_SPLIT is a PMOP; let
4787          * ck_split() create a real PMOP and leave the op's type as listop
4788          * for now. Otherwise op_free() etc will crash.
4789          */
4790         OpTYPE_set(o, type);
4791
4792     o->op_flags |= flags;
4793     if (flags & OPf_FOLDED)
4794         o->op_folded = 1;
4795
4796     o = CHECKOP(type, o);
4797     if (o->op_type != (unsigned)type)
4798         return o;
4799
4800     return fold_constants(op_integerize(op_std_init(o)));
4801 }
4802
4803 /* Constructors */
4804
4805
4806 /*
4807 =head1 Optree construction