op.c

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