op.c

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