op.c

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