op.c

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