op.c

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