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