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