op.c

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