op.c

   1 #line 2 "op.c"
   2 /*    op.c
   3  *
   4  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
   5  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
   6  *
   7  *    You may distribute under the terms of either the GNU General Public
   8  *    License or the Artistic License, as specified in the README file.
   9  *
  10  */
  11
  12 /*
  13  * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck.  She was
  14  *  our Mr. Bilbo's first cousin on the mother's side (her mother being the
  15  *  youngest of the Old Took's daughters); and Mr. Drogo was his second
  16  *  cousin.  So Mr. Frodo is his first *and* second cousin, once removed
  17  *  either way, as the saying is, if you follow me.'       --the Gaffer
  18  *
  19  *     [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
  20  */
  21
  22 /* This file contains the functions that create, manipulate and optimize
  23  * the OP structures that hold a compiled perl program.
  24  *
  25  * A Perl program is compiled into a tree of OPs. Each op contains
  26  * structural pointers (eg to its siblings and the next op in the
  27  * execution sequence), a pointer to the function that would execute the
  28  * op, plus any data specific to that op. For example, an OP_CONST op
  29  * points to the pp_const() function and to an SV containing the constant
  30  * value. When pp_const() is executed, its job is to push that SV onto the
  31  * stack.
  32  *
  33  * OPs are mainly created by the newFOO() functions, which are mainly
  34  * called from the parser (in perly.y) as the code is parsed. For example
  35  * the Perl code $a + $b * $c would cause the equivalent of the following
  36  * to be called (oversimplifying a bit):
  37  *
  38  *  newBINOP(OP_ADD, flags,
  39  *      newSVREF($a),
  40  *      newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
  41  *  )
  42  *
  43  * Note that during the build of miniperl, a temporary copy of this file
  44  * is made, called opmini.c.
  45  */
  46
  47 /*
  48 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
  49
  50     A bottom-up pass
  51     A top-down pass
  52     An execution-order pass
  53
  54 The bottom-up pass is represented by all the "newOP" routines and
  55 the ck_ routines.  The bottom-upness is actually driven by yacc.
  56 So at the point that a ck_ routine fires, we have no idea what the
  57 context is, either upward in the syntax tree, or either forward or
  58 backward in the execution order.  (The bottom-up parser builds that
  59 part of the execution order it knows about, but if you follow the "next"
  60 links around, you'll find it's actually a closed loop through the
  61 top level node.)
  62
  63 Whenever the bottom-up parser gets to a node that supplies context to
  64 its components, it invokes that portion of the top-down pass that applies
  65 to that part of the subtree (and marks the top node as processed, so
  66 if a node further up supplies context, it doesn't have to take the
  67 plunge again).  As a particular subcase of this, as the new node is
  68 built, it takes all the closed execution loops of its subcomponents
  69 and links them into a new closed loop for the higher level node.  But
  70 it's still not the real execution order.
  71
  72 The actual execution order is not known till we get a grammar reduction
  73 to a top-level unit like a subroutine or file that will be called by
  74 "name" rather than via a "next" pointer.  At that point, we can call
  75 into peep() to do that code's portion of the 3rd pass.  It has to be
  76 recursive, but it's recursive on basic blocks, not on tree nodes.
  77 */
  78
  79 /* To implement user lexical pragmas, there needs to be a way at run time to
  80    get the compile time state of %^H for that block.  Storing %^H in every
  81    block (or even COP) would be very expensive, so a different approach is
  82    taken.  The (running) state of %^H is serialised into a tree of HE-like
  83    structs.  Stores into %^H are chained onto the current leaf as a struct
  84    refcounted_he * with the key and the value.  Deletes from %^H are saved
  85    with a value of PL_sv_placeholder.  The state of %^H at any point can be
  86    turned back into a regular HV by walking back up the tree from that point's
  87    leaf, ignoring any key you've already seen (placeholder or not), storing
  88    the rest into the HV structure, then removing the placeholders. Hence
  89    memory is only used to store the %^H deltas from the enclosing COP, rather
  90    than the entire %^H on each COP.
  91
  92    To cause actions on %^H to write out the serialisation records, it has
  93    magic type 'H'. This magic (itself) does nothing, but its presence causes
  94    the values to gain magic type 'h', which has entries for set and clear.
  95    C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
  96    record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
  97    saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
  98    it will be correctly restored when any inner compiling scope is exited.
  99 */
 100
 101 #include "EXTERN.h"
 102 #define PERL_IN_OP_C
 103 #include "perl.h"
 104 #include "keywords.h"
 105 #include "feature.h"
 106 #include "regcomp.h"
 107
 108 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
 109 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
 110 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
 111
 112 /* Used to avoid recursion through the op tree in scalarvoid() and
 113    op_free()
 114 */
 115
 116 #define DEFERRED_OP_STEP 100
 117 #define DEFER_OP(o) \
 118   STMT_START { \
 119     if (UNLIKELY(defer_ix == (defer_stack_alloc-1))) {    \
 120         defer_stack_alloc += DEFERRED_OP_STEP; \
 121         assert(defer_stack_alloc > 0); \
 122         Renew(defer_stack, defer_stack_alloc, OP *); \
 123     } \
 124     defer_stack[++defer_ix] = o; \
 125   } STMT_END
 126
 127 #define POP_DEFERRED_OP() (defer_ix >= 0 ? defer_stack[defer_ix--] : (OP *)NULL)
 128
 129 /* remove any leading "empty" ops from the op_next chain whose first
 130  * node's address is stored in op_p. Store the updated address of the
 131  * first node in op_p.
 132  */
 133
 134 STATIC void
 135 S_prune_chain_head(OP** op_p)
 136 {
 137     while (*op_p
 138         && (   (*op_p)->op_type == OP_NULL
 139             || (*op_p)->op_type == OP_SCOPE
 140             || (*op_p)->op_type == OP_SCALAR
 141             || (*op_p)->op_type == OP_LINESEQ)
 142     )
 143         *op_p = (*op_p)->op_next;
 144 }
 145
 146
 147 /* See the explanatory comments above struct opslab in op.h. */
 148
 149 #ifdef PERL_DEBUG_READONLY_OPS
 150 #  define PERL_SLAB_SIZE 128
 151 #  define PERL_MAX_SLAB_SIZE 4096
 152 #  include <sys/mman.h>
 153 #endif
 154
 155 #ifndef PERL_SLAB_SIZE
 156 #  define PERL_SLAB_SIZE 64
 157 #endif
 158 #ifndef PERL_MAX_SLAB_SIZE
 159 #  define PERL_MAX_SLAB_SIZE 2048
 160 #endif
 161
 162 /* rounds up to nearest pointer */
 163 #define SIZE_TO_PSIZE(x)        (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
 164 #define DIFF(o,p)               ((size_t)((I32 **)(p) - (I32**)(o)))
 165
 166 static OPSLAB *
 167 S_new_slab(pTHX_ size_t sz)
 168 {
 169 #ifdef PERL_DEBUG_READONLY_OPS
 170     OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
 171                                    PROT_READ|PROT_WRITE,
 172                                    MAP_ANON|MAP_PRIVATE, -1, 0);
 173     DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
 174                           (unsigned long) sz, slab));
 175     if (slab == MAP_FAILED) {
 176         perror("mmap failed");
 177         abort();
 178     }
 179     slab->opslab_size = (U16)sz;
 180 #else
 181     OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
 182 #endif
 183 #ifndef WIN32
 184     /* The context is unused in non-Windows */
 185     PERL_UNUSED_CONTEXT;
 186 #endif
 187     slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
 188     return slab;
 189 }
 190
 191 /* requires double parens and aTHX_ */
 192 #define DEBUG_S_warn(args)                                             \
 193     DEBUG_S(                                                            \
 194         PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
 195     )
 196
 197 void *
 198 Perl_Slab_Alloc(pTHX_ size_t sz)
 199 {
 200     OPSLAB *slab;
 201     OPSLAB *slab2;
 202     OPSLOT *slot;
 203     OP *o;
 204     size_t opsz, space;
 205
 206     /* We only allocate ops from the slab during subroutine compilation.
 207        We find the slab via PL_compcv, hence that must be non-NULL. It could
 208        also be pointing to a subroutine which is now fully set up (CvROOT()
 209        pointing to the top of the optree for that sub), or a subroutine
 210        which isn't using the slab allocator. If our sanity checks aren't met,
 211        don't use a slab, but allocate the OP directly from the heap.  */
 212     if (!PL_compcv || CvROOT(PL_compcv)
 213      || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
 214     {
 215         o = (OP*)PerlMemShared_calloc(1, sz);
 216         goto gotit;
 217     }
 218
 219     /* While the subroutine is under construction, the slabs are accessed via
 220        CvSTART(), to avoid needing to expand PVCV by one pointer for something
 221        unneeded at runtime. Once a subroutine is constructed, the slabs are
 222        accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
 223        allocated yet.  See the commit message for 8be227ab5eaa23f2 for more
 224        details.  */
 225     if (!CvSTART(PL_compcv)) {
 226         CvSTART(PL_compcv) =
 227             (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
 228         CvSLABBED_on(PL_compcv);
 229         slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
 230     }
 231     else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
 232
 233     opsz = SIZE_TO_PSIZE(sz);
 234     sz = opsz + OPSLOT_HEADER_P;
 235
 236     /* The slabs maintain a free list of OPs. In particular, constant folding
 237        will free up OPs, so it makes sense to re-use them where possible. A
 238        freed up slot is used in preference to a new allocation.  */
 239     if (slab->opslab_freed) {
 240         OP **too = &slab->opslab_freed;
 241         o = *too;
 242         DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", (void*)o, (void*)slab));
 243         while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
 244             DEBUG_S_warn((aTHX_ "Alas! too small"));
 245             o = *(too = &o->op_next);
 246             if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", (void*)o)); }
 247         }
 248         if (o) {
 249             *too = o->op_next;
 250             Zero(o, opsz, I32 *);
 251             o->op_slabbed = 1;
 252             goto gotit;
 253         }
 254     }
 255
 256 #define INIT_OPSLOT \
 257             slot->opslot_slab = slab;                   \
 258             slot->opslot_next = slab2->opslab_first;    \
 259             slab2->opslab_first = slot;                 \
 260             o = &slot->opslot_op;                       \
 261             o->op_slabbed = 1
 262
 263     /* The partially-filled slab is next in the chain. */
 264     slab2 = slab->opslab_next ? slab->opslab_next : slab;
 265     if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
 266         /* Remaining space is too small. */
 267
 268         /* If we can fit a BASEOP, add it to the free chain, so as not
 269            to waste it. */
 270         if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
 271             slot = &slab2->opslab_slots;
 272             INIT_OPSLOT;
 273             o->op_type = OP_FREED;
 274             o->op_next = slab->opslab_freed;
 275             slab->opslab_freed = o;
 276         }
 277
 278         /* Create a new slab.  Make this one twice as big. */
 279         slot = slab2->opslab_first;
 280         while (slot->opslot_next) slot = slot->opslot_next;
 281         slab2 = S_new_slab(aTHX_
 282                             (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
 283                                         ? PERL_MAX_SLAB_SIZE
 284                                         : (DIFF(slab2, slot)+1)*2);
 285         slab2->opslab_next = slab->opslab_next;
 286         slab->opslab_next = slab2;
 287     }
 288     assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
 289
 290     /* Create a new op slot */
 291     slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
 292     assert(slot >= &slab2->opslab_slots);
 293     if (DIFF(&slab2->opslab_slots, slot)
 294          < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
 295         slot = &slab2->opslab_slots;
 296     INIT_OPSLOT;
 297     DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab));
 298
 299   gotit:
 300 #ifdef PERL_OP_PARENT
 301     /* moresib == 0, op_sibling == 0 implies a solitary unattached op */
 302     assert(!o->op_moresib);
 303     assert(!o->op_sibparent);
 304 #endif
 305
 306     return (void *)o;
 307 }
 308
 309 #undef INIT_OPSLOT
 310
 311 #ifdef PERL_DEBUG_READONLY_OPS
 312 void
 313 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
 314 {
 315     PERL_ARGS_ASSERT_SLAB_TO_RO;
 316
 317     if (slab->opslab_readonly) return;
 318     slab->opslab_readonly = 1;
 319     for (; slab; slab = slab->opslab_next) {
 320         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
 321                               (unsigned long) slab->opslab_size, slab));*/
 322         if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
 323             Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
 324                              (unsigned long)slab->opslab_size, errno);
 325     }
 326 }
 327
 328 void
 329 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
 330 {
 331     OPSLAB *slab2;
 332
 333     PERL_ARGS_ASSERT_SLAB_TO_RW;
 334
 335     if (!slab->opslab_readonly) return;
 336     slab2 = slab;
 337     for (; slab2; slab2 = slab2->opslab_next) {
 338         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
 339                               (unsigned long) size, slab2));*/
 340         if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
 341                      PROT_READ|PROT_WRITE)) {
 342             Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
 343                              (unsigned long)slab2->opslab_size, errno);
 344         }
 345     }
 346     slab->opslab_readonly = 0;
 347 }
 348
 349 #else
 350 #  define Slab_to_rw(op)    NOOP
 351 #endif
 352
 353 /* This cannot possibly be right, but it was copied from the old slab
 354    allocator, to which it was originally added, without explanation, in
 355    commit 083fcd5. */
 356 #ifdef NETWARE
 357 #    define PerlMemShared PerlMem
 358 #endif
 359
 360 void
 361 Perl_Slab_Free(pTHX_ void *op)
 362 {
 363     OP * const o = (OP *)op;
 364     OPSLAB *slab;
 365
 366     PERL_ARGS_ASSERT_SLAB_FREE;
 367
 368     if (!o->op_slabbed) {
 369         if (!o->op_static)
 370             PerlMemShared_free(op);
 371         return;
 372     }
 373
 374     slab = OpSLAB(o);
 375     /* If this op is already freed, our refcount will get screwy. */
 376     assert(o->op_type != OP_FREED);
 377     o->op_type = OP_FREED;
 378     o->op_next = slab->opslab_freed;
 379     slab->opslab_freed = o;
 380     DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", (void*)o, (void*)slab));
 381     OpslabREFCNT_dec_padok(slab);
 382 }
 383
 384 void
 385 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
 386 {
 387     const bool havepad = !!PL_comppad;
 388     PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
 389     if (havepad) {
 390         ENTER;
 391         PAD_SAVE_SETNULLPAD();
 392     }
 393     opslab_free(slab);
 394     if (havepad) LEAVE;
 395 }
 396
 397 void
 398 Perl_opslab_free(pTHX_ OPSLAB *slab)
 399 {
 400     OPSLAB *slab2;
 401     PERL_ARGS_ASSERT_OPSLAB_FREE;
 402     PERL_UNUSED_CONTEXT;
 403     DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
 404     assert(slab->opslab_refcnt == 1);
 405     do {
 406         slab2 = slab->opslab_next;
 407 #ifdef DEBUGGING
 408         slab->opslab_refcnt = ~(size_t)0;
 409 #endif
 410 #ifdef PERL_DEBUG_READONLY_OPS
 411         DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
 412                                                (void*)slab));
 413         if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
 414             perror("munmap failed");
 415             abort();
 416         }
 417 #else
 418         PerlMemShared_free(slab);
 419 #endif
 420         slab = slab2;
 421     } while (slab);
 422 }
 423
 424 void
 425 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
 426 {
 427     OPSLAB *slab2;
 428     OPSLOT *slot;
 429 #ifdef DEBUGGING
 430     size_t savestack_count = 0;
 431 #endif
 432     PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
 433     slab2 = slab;
 434     do {
 435         for (slot = slab2->opslab_first;
 436              slot->opslot_next;
 437              slot = slot->opslot_next) {
 438             if (slot->opslot_op.op_type != OP_FREED
 439              && !(slot->opslot_op.op_savefree
 440 #ifdef DEBUGGING
 441                   && ++savestack_count
 442 #endif
 443                  )
 444             ) {
 445                 assert(slot->opslot_op.op_slabbed);
 446                 op_free(&slot->opslot_op);
 447                 if (slab->opslab_refcnt == 1) goto free;
 448             }
 449         }
 450     } while ((slab2 = slab2->opslab_next));
 451     /* > 1 because the CV still holds a reference count. */
 452     if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
 453 #ifdef DEBUGGING
 454         assert(savestack_count == slab->opslab_refcnt-1);
 455 #endif
 456         /* Remove the CV’s reference count. */
 457         slab->opslab_refcnt--;
 458         return;
 459     }
 460    free:
 461     opslab_free(slab);
 462 }
 463
 464 #ifdef PERL_DEBUG_READONLY_OPS
 465 OP *
 466 Perl_op_refcnt_inc(pTHX_ OP *o)
 467 {
 468     if(o) {
 469         OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
 470         if (slab && slab->opslab_readonly) {
 471             Slab_to_rw(slab);
 472             ++o->op_targ;
 473             Slab_to_ro(slab);
 474         } else {
 475             ++o->op_targ;
 476         }
 477     }
 478     return o;
 479
 480 }
 481
 482 PADOFFSET
 483 Perl_op_refcnt_dec(pTHX_ OP *o)
 484 {
 485     PADOFFSET result;
 486     OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
 487
 488     PERL_ARGS_ASSERT_OP_REFCNT_DEC;
 489
 490     if (slab && slab->opslab_readonly) {
 491         Slab_to_rw(slab);
 492         result = --o->op_targ;
 493         Slab_to_ro(slab);
 494     } else {
 495         result = --o->op_targ;
 496     }
 497     return result;
 498 }
 499 #endif
 500 /*
 501  * In the following definition, the ", (OP*)0" is just to make the compiler
 502  * think the expression is of the right type: croak actually does a Siglongjmp.
 503  */
 504 #define CHECKOP(type,o) \
 505     ((PL_op_mask && PL_op_mask[type])                           \
 506      ? ( op_free((OP*)o),                                       \
 507          Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]),  \
 508          (OP*)0 )                                               \
 509      : PL_check[type](aTHX_ (OP*)o))
 510
 511 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
 512
 513 #define OpTYPE_set(o,type) \
 514     STMT_START {                                \
 515         o->op_type = (OPCODE)type;              \
 516         o->op_ppaddr = PL_ppaddr[type];         \
 517     } STMT_END
 518
 519 STATIC OP *
 520 S_no_fh_allowed(pTHX_ OP *o)
 521 {
 522     PERL_ARGS_ASSERT_NO_FH_ALLOWED;
 523
 524     yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
 525                  OP_DESC(o)));
 526     return o;
 527 }
 528
 529 STATIC OP *
 530 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
 531 {
 532     PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
 533     yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
 534     return o;
 535 }
 536
 537 STATIC OP *
 538 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
 539 {
 540     PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
 541
 542     yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
 543     return o;
 544 }
 545
 546 STATIC void
 547 S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid)
 548 {
 549     PERL_ARGS_ASSERT_BAD_TYPE_PV;
 550
 551     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
 552                  (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);
 553 }
 554
 555 /* remove flags var, its unused in all callers, move to to right end since gv
 556   and kid are always the same */
 557 STATIC void
 558 S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)
 559 {
 560     SV * const namesv = cv_name((CV *)gv, NULL, 0);
 561     PERL_ARGS_ASSERT_BAD_TYPE_GV;
 562
 563     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
 564                  (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
 565 }
 566
 567 STATIC void
 568 S_no_bareword_allowed(pTHX_ OP *o)
 569 {
 570     PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
 571
 572     qerror(Perl_mess(aTHX_
 573                      "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
 574                      SVfARG(cSVOPo_sv)));
 575     o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
 576 }
 577
 578 /* "register" allocation */
 579
 580 PADOFFSET
 581 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
 582 {
 583     PADOFFSET off;
 584     const bool is_our = (PL_parser->in_my == KEY_our);
 585
 586     PERL_ARGS_ASSERT_ALLOCMY;
 587
 588     if (flags & ~SVf_UTF8)
 589         Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
 590                    (UV)flags);
 591
 592     /* complain about "my $<special_var>" etc etc */
 593     if (len &&
 594         !(is_our ||
 595           isALPHA(name[1]) ||
 596           ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
 597           (name[1] == '_' && len > 2)))
 598     {
 599         if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
 600          && isASCII(name[1])
 601          && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
 602             yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
 603                               name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
 604                               PL_parser->in_my == KEY_state ? "state" : "my"));
 605         } else {
 606             yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
 607                               PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
 608         }
 609     }
 610
 611     /* allocate a spare slot and store the name in that slot */
 612
 613     off = pad_add_name_pvn(name, len,
 614                        (is_our ? padadd_OUR :
 615                         PL_parser->in_my == KEY_state ? padadd_STATE : 0),
 616                     PL_parser->in_my_stash,
 617                     (is_our
 618                         /* $_ is always in main::, even with our */
 619                         ? (PL_curstash && !memEQs(name,len,"$_")
 620                             ? PL_curstash
 621                             : PL_defstash)
 622                         : NULL
 623                     )
 624     );
 625     /* anon sub prototypes contains state vars should always be cloned,
 626      * otherwise the state var would be shared between anon subs */
 627
 628     if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
 629         CvCLONE_on(PL_compcv);
 630
 631     return off;
 632 }
 633
 634 /*
 635 =head1 Optree Manipulation Functions
 636
 637 =for apidoc alloccopstash
 638
 639 Available only under threaded builds, this function allocates an entry in
 640 C<PL_stashpad> for the stash passed to it.
 641
 642 =cut
 643 */
 644
 645 #ifdef USE_ITHREADS
 646 PADOFFSET
 647 Perl_alloccopstash(pTHX_ HV *hv)
 648 {
 649     PADOFFSET off = 0, o = 1;
 650     bool found_slot = FALSE;
 651
 652     PERL_ARGS_ASSERT_ALLOCCOPSTASH;
 653
 654     if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
 655
 656     for (; o < PL_stashpadmax; ++o) {
 657         if (PL_stashpad[o] == hv) return PL_stashpadix = o;
 658         if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
 659             found_slot = TRUE, off = o;
 660     }
 661     if (!found_slot) {
 662         Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
 663         Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
 664         off = PL_stashpadmax;
 665         PL_stashpadmax += 10;
 666     }
 667
 668     PL_stashpad[PL_stashpadix = off] = hv;
 669     return off;
 670 }
 671 #endif
 672
 673 /* free the body of an op without examining its contents.
 674  * Always use this rather than FreeOp directly */
 675
 676 static void
 677 S_op_destroy(pTHX_ OP *o)
 678 {
 679     FreeOp(o);
 680 }
 681
 682 /* Destructor */
 683
 684 /*
 685 =for apidoc Am|void|op_free|OP *o
 686
 687 Free an op.  Only use this when an op is no longer linked to from any
 688 optree.
 689
 690 =cut
 691 */
 692
 693 void
 694 Perl_op_free(pTHX_ OP *o)
 695 {
 696     dVAR;
 697     OPCODE type;
 698     SSize_t defer_ix = -1;
 699     SSize_t defer_stack_alloc = 0;
 700     OP **defer_stack = NULL;
 701
 702     do {
 703
 704         /* Though ops may be freed twice, freeing the op after its slab is a
 705            big no-no. */
 706         assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
 707         /* During the forced freeing of ops after compilation failure, kidops
 708            may be freed before their parents. */
 709         if (!o || o->op_type == OP_FREED)
 710             continue;
 711
 712         type = o->op_type;
 713
 714         /* an op should only ever acquire op_private flags that we know about.
 715          * If this fails, you may need to fix something in regen/op_private.
 716          * Don't bother testing if:
 717          *   * the op_ppaddr doesn't match the op; someone may have
 718          *     overridden the op and be doing strange things with it;
 719          *   * we've errored, as op flags are often left in an
 720          *     inconsistent state then. Note that an error when
 721          *     compiling the main program leaves PL_parser NULL, so
 722          *     we can't spot faults in the main code, only
 723          *     evaled/required code */
 724 #ifdef DEBUGGING
 725         if (   o->op_ppaddr == PL_ppaddr[o->op_type]
 726             && PL_parser
 727             && !PL_parser->error_count)
 728         {
 729             assert(!(o->op_private & ~PL_op_private_valid[type]));
 730         }
 731 #endif
 732
 733         if (o->op_private & OPpREFCOUNTED) {
 734             switch (type) {
 735             case OP_LEAVESUB:
 736             case OP_LEAVESUBLV:
 737             case OP_LEAVEEVAL:
 738             case OP_LEAVE:
 739             case OP_SCOPE:
 740             case OP_LEAVEWRITE:
 741                 {
 742                 PADOFFSET refcnt;
 743                 OP_REFCNT_LOCK;
 744                 refcnt = OpREFCNT_dec(o);
 745                 OP_REFCNT_UNLOCK;
 746                 if (refcnt) {
 747                     /* Need to find and remove any pattern match ops from the list
 748                        we maintain for reset().  */
 749                     find_and_forget_pmops(o);
 750                     continue;
 751                 }
 752                 }
 753                 break;
 754             default:
 755                 break;
 756             }
 757         }
 758
 759         /* Call the op_free hook if it has been set. Do it now so that it's called
 760          * at the right time for refcounted ops, but still before all of the kids
 761          * are freed. */
 762         CALL_OPFREEHOOK(o);
 763
 764         if (o->op_flags & OPf_KIDS) {
 765             OP *kid, *nextkid;
 766             for (kid = cUNOPo->op_first; kid; kid = nextkid) {
 767                 nextkid = OpSIBLING(kid); /* Get before next freeing kid */
 768                 if (!kid || kid->op_type == OP_FREED)
 769                     /* During the forced freeing of ops after
 770                        compilation failure, kidops may be freed before
 771                        their parents. */
 772                     continue;
 773                 if (!(kid->op_flags & OPf_KIDS))
 774                     /* If it has no kids, just free it now */
 775                     op_free(kid);
 776                 else
 777                     DEFER_OP(kid);
 778             }
 779         }
 780         if (type == OP_NULL)
 781             type = (OPCODE)o->op_targ;
 782
 783         if (o->op_slabbed)
 784             Slab_to_rw(OpSLAB(o));
 785
 786         /* COP* is not cleared by op_clear() so that we may track line
 787          * numbers etc even after null() */
 788         if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
 789             cop_free((COP*)o);
 790         }
 791
 792         op_clear(o);
 793         FreeOp(o);
 794 #ifdef DEBUG_LEAKING_SCALARS
 795         if (PL_op == o)
 796             PL_op = NULL;
 797 #endif
 798     } while ( (o = POP_DEFERRED_OP()) );
 799
 800     Safefree(defer_stack);
 801 }
 802
 803 /* S_op_clear_gv(): free a GV attached to an OP */
 804
 805 STATIC
 806 #ifdef USE_ITHREADS
 807 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
 808 #else
 809 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
 810 #endif
 811 {
 812
 813     GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
 814             || o->op_type == OP_MULTIDEREF)
 815 #ifdef USE_ITHREADS
 816                 && PL_curpad
 817                 ? ((GV*)PAD_SVl(*ixp)) : NULL;
 818 #else
 819                 ? (GV*)(*svp) : NULL;
 820 #endif
 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 (*ixp > 0) {
 841         pad_swipe(*ixp, TRUE);
 842         *ixp = 0;
 843     }
 844 #else
 845     SvREFCNT_dec(*svp);
 846     *svp = 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
 856
 857 void
 858 Perl_op_clear(pTHX_ OP *o)
 859 {
 860
 861     dVAR;
 862
 863     PERL_ARGS_ASSERT_OP_CLEAR;
 864
 865     switch (o->op_type) {
 866     case OP_NULL:       /* Was holding old type, if any. */
 867         /* FALLTHROUGH */
 868     case OP_ENTERTRY:
 869     case OP_ENTEREVAL:  /* Was holding hints. */
 870         o->op_targ = 0;
 871         break;
 872     default:
 873         if (!(o->op_flags & OPf_REF)
 874             || (PL_check[o->op_type] != Perl_ck_ftst))
 875             break;
 876         /* FALLTHROUGH */
 877     case OP_GVSV:
 878     case OP_GV:
 879     case OP_AELEMFAST:
 880 #ifdef USE_ITHREADS
 881             S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
 882 #else
 883             S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
 884 #endif
 885         break;
 886     case OP_METHOD_REDIR:
 887     case OP_METHOD_REDIR_SUPER:
 888 #ifdef USE_ITHREADS
 889         if (cMETHOPx(o)->op_rclass_targ) {
 890             pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
 891             cMETHOPx(o)->op_rclass_targ = 0;
 892         }
 893 #else
 894         SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
 895         cMETHOPx(o)->op_rclass_sv = NULL;
 896 #endif
 897     case OP_METHOD_NAMED:
 898     case OP_METHOD_SUPER:
 899         SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
 900         cMETHOPx(o)->op_u.op_meth_sv = NULL;
 901 #ifdef USE_ITHREADS
 902         if (o->op_targ) {
 903             pad_swipe(o->op_targ, 1);
 904             o->op_targ = 0;
 905         }
 906 #endif
 907         break;
 908     case OP_CONST:
 909     case OP_HINTSEVAL:
 910         SvREFCNT_dec(cSVOPo->op_sv);
 911         cSVOPo->op_sv = NULL;
 912 #ifdef USE_ITHREADS
 913         /** Bug #15654
 914           Even if op_clear does a pad_free for the target of the op,
 915           pad_free doesn't actually remove the sv that exists in the pad;
 916           instead it lives on. This results in that it could be reused as
 917           a target later on when the pad was reallocated.
 918         **/
 919         if(o->op_targ) {
 920           pad_swipe(o->op_targ,1);
 921           o->op_targ = 0;
 922         }
 923 #endif
 924         break;
 925     case OP_DUMP:
 926     case OP_GOTO:
 927     case OP_NEXT:
 928     case OP_LAST:
 929     case OP_REDO:
 930         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
 931             break;
 932         /* FALLTHROUGH */
 933     case OP_TRANS:
 934     case OP_TRANSR:
 935         if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
 936             assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
 937 #ifdef USE_ITHREADS
 938             if (cPADOPo->op_padix > 0) {
 939                 pad_swipe(cPADOPo->op_padix, TRUE);
 940                 cPADOPo->op_padix = 0;
 941             }
 942 #else
 943             SvREFCNT_dec(cSVOPo->op_sv);
 944             cSVOPo->op_sv = NULL;
 945 #endif
 946         }
 947         else {
 948             PerlMemShared_free(cPVOPo->op_pv);
 949             cPVOPo->op_pv = NULL;
 950         }
 951         break;
 952     case OP_SUBST:
 953         op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
 954         goto clear_pmop;
 955     case OP_PUSHRE:
 956 #ifdef USE_ITHREADS
 957         if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
 958             pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
 959         }
 960 #else
 961         SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
 962 #endif
 963         /* FALLTHROUGH */
 964     case OP_MATCH:
 965     case OP_QR:
 966     clear_pmop:
 967         if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
 968             op_free(cPMOPo->op_code_list);
 969         cPMOPo->op_code_list = NULL;
 970         forget_pmop(cPMOPo);
 971         cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
 972         /* we use the same protection as the "SAFE" version of the PM_ macros
 973          * here since sv_clean_all might release some PMOPs
 974          * after PL_regex_padav has been cleared
 975          * and the clearing of PL_regex_padav needs to
 976          * happen before sv_clean_all
 977          */
 978 #ifdef USE_ITHREADS
 979         if(PL_regex_pad) {        /* We could be in destruction */
 980             const IV offset = (cPMOPo)->op_pmoffset;
 981             ReREFCNT_dec(PM_GETRE(cPMOPo));
 982             PL_regex_pad[offset] = &PL_sv_undef;
 983             sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
 984                            sizeof(offset));
 985         }
 986 #else
 987         ReREFCNT_dec(PM_GETRE(cPMOPo));
 988         PM_SETRE(cPMOPo, NULL);
 989 #endif
 990
 991         break;
 992
 993     case OP_MULTIDEREF:
 994         {
 995             UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
 996             UV actions = items->uv;
 997             bool last = 0;
 998             bool is_hash = FALSE;
 999
1000             while (!last) {
1001                 switch (actions & MDEREF_ACTION_MASK) {
1002
1003                 case MDEREF_reload:
1004                     actions = (++items)->uv;
1005                     continue;
1006
1007                 case MDEREF_HV_padhv_helem:
1008                     is_hash = TRUE;
1009                 case MDEREF_AV_padav_aelem:
1010                     pad_free((++items)->pad_offset);
1011                     goto do_elem;
1012
1013                 case MDEREF_HV_gvhv_helem:
1014                     is_hash = TRUE;
1015                 case MDEREF_AV_gvav_aelem:
1016 #ifdef USE_ITHREADS
1017                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1018 #else
1019                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1020 #endif
1021                     goto do_elem;
1022
1023                 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1024                     is_hash = TRUE;
1025                 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1026 #ifdef USE_ITHREADS
1027                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1028 #else
1029                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1030 #endif
1031                     goto do_vivify_rv2xv_elem;
1032
1033                 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1034                     is_hash = TRUE;
1035                 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1036                     pad_free((++items)->pad_offset);
1037                     goto do_vivify_rv2xv_elem;
1038
1039                 case MDEREF_HV_pop_rv2hv_helem:
1040                 case MDEREF_HV_vivify_rv2hv_helem:
1041                     is_hash = TRUE;
1042                 do_vivify_rv2xv_elem:
1043                 case MDEREF_AV_pop_rv2av_aelem:
1044                 case MDEREF_AV_vivify_rv2av_aelem:
1045                 do_elem:
1046                     switch (actions & MDEREF_INDEX_MASK) {
1047                     case MDEREF_INDEX_none:
1048                         last = 1;
1049                         break;
1050                     case MDEREF_INDEX_const:
1051                         if (is_hash) {
1052 #ifdef USE_ITHREADS
1053                             /* see RT #15654 */
1054                             pad_swipe((++items)->pad_offset, 1);
1055 #else
1056                             SvREFCNT_dec((++items)->sv);
1057 #endif
1058                         }
1059                         else
1060                             items++;
1061                         break;
1062                     case MDEREF_INDEX_padsv:
1063                         pad_free((++items)->pad_offset);
1064                         break;
1065                     case MDEREF_INDEX_gvsv:
1066 #ifdef USE_ITHREADS
1067                         S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1068 #else
1069                         S_op_clear_gv(aTHX_ o, &((++items)->sv));
1070 #endif
1071                         break;
1072                     }
1073
1074                     if (actions & MDEREF_FLAG_last)
1075                         last = 1;
1076                     is_hash = FALSE;
1077
1078                     break;
1079
1080                 default:
1081                     assert(0);
1082                     last = 1;
1083                     break;
1084
1085                 } /* switch */
1086
1087                 actions >>= MDEREF_SHIFT;
1088             } /* while */
1089
1090             /* start of malloc is at op_aux[-1], where the length is
1091              * stored */
1092             PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1093         }
1094         break;
1095     }
1096
1097     if (o->op_targ > 0) {
1098         pad_free(o->op_targ);
1099         o->op_targ = 0;
1100     }
1101 }
1102
1103 STATIC void
1104 S_cop_free(pTHX_ COP* cop)
1105 {
1106     PERL_ARGS_ASSERT_COP_FREE;
1107
1108     CopFILE_free(cop);
1109     if (! specialWARN(cop->cop_warnings))
1110         PerlMemShared_free(cop->cop_warnings);
1111     cophh_free(CopHINTHASH_get(cop));
1112     if (PL_curcop == cop)
1113        PL_curcop = NULL;
1114 }
1115
1116 STATIC void
1117 S_forget_pmop(pTHX_ PMOP *const o
1118               )
1119 {
1120     HV * const pmstash = PmopSTASH(o);
1121
1122     PERL_ARGS_ASSERT_FORGET_PMOP;
1123
1124     if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1125         MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1126         if (mg) {
1127             PMOP **const array = (PMOP**) mg->mg_ptr;
1128             U32 count = mg->mg_len / sizeof(PMOP**);
1129             U32 i = count;
1130
1131             while (i--) {
1132                 if (array[i] == o) {
1133                     /* Found it. Move the entry at the end to overwrite it.  */
1134                     array[i] = array[--count];
1135                     mg->mg_len = count * sizeof(PMOP**);
1136                     /* Could realloc smaller at this point always, but probably
1137                        not worth it. Probably worth free()ing if we're the
1138                        last.  */
1139                     if(!count) {
1140                         Safefree(mg->mg_ptr);
1141                         mg->mg_ptr = NULL;
1142                     }
1143                     break;
1144                 }
1145             }
1146         }
1147     }
1148     if (PL_curpm == o)
1149         PL_curpm = NULL;
1150 }
1151
1152 STATIC void
1153 S_find_and_forget_pmops(pTHX_ OP *o)
1154 {
1155     PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1156
1157     if (o->op_flags & OPf_KIDS) {
1158         OP *kid = cUNOPo->op_first;
1159         while (kid) {
1160             switch (kid->op_type) {
1161             case OP_SUBST:
1162             case OP_PUSHRE:
1163             case OP_MATCH:
1164             case OP_QR:
1165                 forget_pmop((PMOP*)kid);
1166             }
1167             find_and_forget_pmops(kid);
1168             kid = OpSIBLING(kid);
1169         }
1170     }
1171 }
1172
1173 /*
1174 =for apidoc Am|void|op_null|OP *o
1175
1176 Neutralizes an op when it is no longer needed, but is still linked to from
1177 other ops.
1178
1179 =cut
1180 */
1181
1182 void
1183 Perl_op_null(pTHX_ OP *o)
1184 {
1185     dVAR;
1186
1187     PERL_ARGS_ASSERT_OP_NULL;
1188
1189     if (o->op_type == OP_NULL)
1190         return;
1191     op_clear(o);
1192     o->op_targ = o->op_type;
1193     OpTYPE_set(o, OP_NULL);
1194 }
1195
1196 void
1197 Perl_op_refcnt_lock(pTHX)
1198   PERL_TSA_ACQUIRE(PL_op_mutex)
1199 {
1200 #ifdef USE_ITHREADS
1201     dVAR;
1202 #endif
1203     PERL_UNUSED_CONTEXT;
1204     OP_REFCNT_LOCK;
1205 }
1206
1207 void
1208 Perl_op_refcnt_unlock(pTHX)
1209   PERL_TSA_RELEASE(PL_op_mutex)
1210 {
1211 #ifdef USE_ITHREADS
1212     dVAR;
1213 #endif
1214     PERL_UNUSED_CONTEXT;
1215     OP_REFCNT_UNLOCK;
1216 }
1217
1218
1219 /*
1220 =for apidoc op_sibling_splice
1221
1222 A general function for editing the structure of an existing chain of
1223 op_sibling nodes.  By analogy with the perl-level C<splice()> function, allows
1224 you to delete zero or more sequential nodes, replacing them with zero or
1225 more different nodes.  Performs the necessary op_first/op_last
1226 housekeeping on the parent node and op_sibling manipulation on the
1227 children.  The last deleted node will be marked as as the last node by
1228 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1229
1230 Note that op_next is not manipulated, and nodes are not freed; that is the
1231 responsibility of the caller.  It also won't create a new list op for an
1232 empty list etc; use higher-level functions like op_append_elem() for that.
1233
1234 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1235 the splicing doesn't affect the first or last op in the chain.
1236
1237 C<start> is the node preceding the first node to be spliced.  Node(s)
1238 following it will be deleted, and ops will be inserted after it.  If it is
1239 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1240 beginning.
1241
1242 C<del_count> is the number of nodes to delete.  If zero, no nodes are deleted.
1243 If -1 or greater than or equal to the number of remaining kids, all
1244 remaining kids are deleted.
1245
1246 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1247 If C<NULL>, no nodes are inserted.
1248
1249 The head of the chain of deleted ops is returned, or C<NULL> if no ops were
1250 deleted.
1251
1252 For example:
1253
1254     action                    before      after         returns
1255     ------                    -----       -----         -------
1256
1257                               P           P
1258     splice(P, A, 2, X-Y-Z)    |           |             B-C
1259                               A-B-C-D     A-X-Y-Z-D
1260
1261                               P           P
1262     splice(P, NULL, 1, X-Y)   |           |             A
1263                               A-B-C-D     X-Y-B-C-D
1264
1265                               P           P
1266     splice(P, NULL, 3, NULL)  |           |             A-B-C
1267                               A-B-C-D     D
1268
1269                               P           P
1270     splice(P, B, 0, X-Y)      |           |             NULL
1271                               A-B-C-D     A-B-X-Y-C-D
1272
1273
1274 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1275 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
1276
1277 =cut
1278 */
1279
1280 OP *
1281 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1282 {
1283     OP *first;
1284     OP *rest;
1285     OP *last_del = NULL;
1286     OP *last_ins = NULL;
1287
1288     if (start)
1289         first = OpSIBLING(start);
1290     else if (!parent)
1291         goto no_parent;
1292     else
1293         first = cLISTOPx(parent)->op_first;
1294
1295     assert(del_count >= -1);
1296
1297     if (del_count && first) {
1298         last_del = first;
1299         while (--del_count && OpHAS_SIBLING(last_del))
1300             last_del = OpSIBLING(last_del);
1301         rest = OpSIBLING(last_del);
1302         OpLASTSIB_set(last_del, NULL);
1303     }
1304     else
1305         rest = first;
1306
1307     if (insert) {
1308         last_ins = insert;
1309         while (OpHAS_SIBLING(last_ins))
1310             last_ins = OpSIBLING(last_ins);
1311         OpMAYBESIB_set(last_ins, rest, NULL);
1312     }
1313     else
1314         insert = rest;
1315
1316     if (start) {
1317         OpMAYBESIB_set(start, insert, NULL);
1318     }
1319     else {
1320         if (!parent)
1321             goto no_parent;
1322         cLISTOPx(parent)->op_first = insert;
1323         if (insert)
1324             parent->op_flags |= OPf_KIDS;
1325         else
1326             parent->op_flags &= ~OPf_KIDS;
1327     }
1328
1329     if (!rest) {
1330         /* update op_last etc */
1331         U32 type;
1332         OP *lastop;
1333
1334         if (!parent)
1335             goto no_parent;
1336
1337         /* ought to use OP_CLASS(parent) here, but that can't handle
1338          * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1339          * either */
1340         type = parent->op_type;
1341         if (type == OP_CUSTOM) {
1342             dTHX;
1343             type = XopENTRYCUSTOM(parent, xop_class);
1344         }
1345         else {
1346             if (type == OP_NULL)
1347                 type = parent->op_targ;
1348             type = PL_opargs[type] & OA_CLASS_MASK;
1349         }
1350
1351         lastop = last_ins ? last_ins : start ? start : NULL;
1352         if (   type == OA_BINOP
1353             || type == OA_LISTOP
1354             || type == OA_PMOP
1355             || type == OA_LOOP
1356         )
1357             cLISTOPx(parent)->op_last = lastop;
1358
1359         if (lastop)
1360             OpLASTSIB_set(lastop, parent);
1361     }
1362     return last_del ? first : NULL;
1363
1364   no_parent:
1365     Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1366 }
1367
1368
1369 #ifdef PERL_OP_PARENT
1370
1371 /*
1372 =for apidoc op_parent
1373
1374 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1375 This function is only available on perls built with C<-DPERL_OP_PARENT>.
1376
1377 =cut
1378 */
1379
1380 OP *
1381 Perl_op_parent(OP *o)
1382 {
1383     PERL_ARGS_ASSERT_OP_PARENT;
1384     while (OpHAS_SIBLING(o))
1385         o = OpSIBLING(o);
1386     return o->op_sibparent;
1387 }
1388
1389 #endif
1390
1391
1392 /* replace the sibling following start with a new UNOP, which becomes
1393  * the parent of the original sibling; e.g.
1394  *
1395  *  op_sibling_newUNOP(P, A, unop-args...)
1396  *
1397  *  P              P
1398  *  |      becomes |
1399  *  A-B-C          A-U-C
1400  *                   |
1401  *                   B
1402  *
1403  * where U is the new UNOP.
1404  *
1405  * parent and start args are the same as for op_sibling_splice();
1406  * type and flags args are as newUNOP().
1407  *
1408  * Returns the new UNOP.
1409  */
1410
1411 STATIC OP *
1412 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1413 {
1414     OP *kid, *newop;
1415
1416     kid = op_sibling_splice(parent, start, 1, NULL);
1417     newop = newUNOP(type, flags, kid);
1418     op_sibling_splice(parent, start, 0, newop);
1419     return newop;
1420 }
1421
1422
1423 /* lowest-level newLOGOP-style function - just allocates and populates
1424  * the struct. Higher-level stuff should be done by S_new_logop() /
1425  * newLOGOP(). This function exists mainly to avoid op_first assignment
1426  * being spread throughout this file.
1427  */
1428
1429 STATIC LOGOP *
1430 S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1431 {
1432     dVAR;
1433     LOGOP *logop;
1434     OP *kid = first;
1435     NewOp(1101, logop, 1, LOGOP);
1436     OpTYPE_set(logop, type);
1437     logop->op_first = first;
1438     logop->op_other = other;
1439     logop->op_flags = OPf_KIDS;
1440     while (kid && OpHAS_SIBLING(kid))
1441         kid = OpSIBLING(kid);
1442     if (kid)
1443         OpLASTSIB_set(kid, (OP*)logop);
1444     return logop;
1445 }
1446
1447
1448 /* Contextualizers */
1449
1450 /*
1451 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1452
1453 Applies a syntactic context to an op tree representing an expression.
1454 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
1455 or C<G_VOID> to specify the context to apply.  The modified op tree
1456 is returned.
1457
1458 =cut
1459 */
1460
1461 OP *
1462 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1463 {
1464     PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1465     switch (context) {
1466         case G_SCALAR: return scalar(o);
1467         case G_ARRAY:  return list(o);
1468         case G_VOID:   return scalarvoid(o);
1469         default:
1470             Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1471                        (long) context);
1472     }
1473 }
1474
1475 /*
1476
1477 =for apidoc Am|OP*|op_linklist|OP *o
1478 This function is the implementation of the L</LINKLIST> macro.  It should
1479 not be called directly.
1480
1481 =cut
1482 */
1483
1484 OP *
1485 Perl_op_linklist(pTHX_ OP *o)
1486 {
1487     OP *first;
1488
1489     PERL_ARGS_ASSERT_OP_LINKLIST;
1490
1491     if (o->op_next)
1492         return o->op_next;
1493
1494     /* establish postfix order */
1495     first = cUNOPo->op_first;
1496     if (first) {
1497         OP *kid;
1498         o->op_next = LINKLIST(first);
1499         kid = first;
1500         for (;;) {
1501             OP *sibl = OpSIBLING(kid);
1502             if (sibl) {
1503                 kid->op_next = LINKLIST(sibl);
1504                 kid = sibl;
1505             } else {
1506                 kid->op_next = o;
1507                 break;
1508             }
1509         }
1510     }
1511     else
1512         o->op_next = o;
1513
1514     return o->op_next;
1515 }
1516
1517 static OP *
1518 S_scalarkids(pTHX_ OP *o)
1519 {
1520     if (o && o->op_flags & OPf_KIDS) {
1521         OP *kid;
1522         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1523             scalar(kid);
1524     }
1525     return o;
1526 }
1527
1528 STATIC OP *
1529 S_scalarboolean(pTHX_ OP *o)
1530 {
1531     PERL_ARGS_ASSERT_SCALARBOOLEAN;
1532
1533     if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
1534      && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
1535         if (ckWARN(WARN_SYNTAX)) {
1536             const line_t oldline = CopLINE(PL_curcop);
1537
1538             if (PL_parser && PL_parser->copline != NOLINE) {
1539                 /* This ensures that warnings are reported at the first line
1540                    of the conditional, not the last.  */
1541                 CopLINE_set(PL_curcop, PL_parser->copline);
1542             }
1543             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1544             CopLINE_set(PL_curcop, oldline);
1545         }
1546     }
1547     return scalar(o);
1548 }
1549
1550 static SV *
1551 S_op_varname(pTHX_ const OP *o)
1552 {
1553     assert(o);
1554     assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1555            o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1556     {
1557         const char funny  = o->op_type == OP_PADAV
1558                          || o->op_type == OP_RV2AV ? '@' : '%';
1559         if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1560             GV *gv;
1561             if (cUNOPo->op_first->op_type != OP_GV
1562              || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1563                 return NULL;
1564             return varname(gv, funny, 0, NULL, 0, 1);
1565         }
1566         return
1567             varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, 1);
1568     }
1569 }
1570
1571 static void
1572 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1573 { /* or not so pretty :-) */
1574     if (o->op_type == OP_CONST) {
1575         *retsv = cSVOPo_sv;
1576         if (SvPOK(*retsv)) {
1577             SV *sv = *retsv;
1578             *retsv = sv_newmortal();
1579             pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1580                       PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1581         }
1582         else if (!SvOK(*retsv))
1583             *retpv = "undef";
1584     }
1585     else *retpv = "...";
1586 }
1587
1588 static void
1589 S_scalar_slice_warning(pTHX_ const OP *o)
1590 {
1591     OP *kid;
1592     const char lbrack =
1593         o->op_type == OP_HSLICE ? '{' : '[';
1594     const char rbrack =
1595         o->op_type == OP_HSLICE ? '}' : ']';
1596     SV *name;
1597     SV *keysv = NULL; /* just to silence compiler warnings */
1598     const char *key = NULL;
1599
1600     if (!(o->op_private & OPpSLICEWARNING))
1601         return;
1602     if (PL_parser && PL_parser->error_count)
1603         /* This warning can be nonsensical when there is a syntax error. */
1604         return;
1605
1606     kid = cLISTOPo->op_first;
1607     kid = OpSIBLING(kid); /* get past pushmark */
1608     /* weed out false positives: any ops that can return lists */
1609     switch (kid->op_type) {
1610     case OP_BACKTICK:
1611     case OP_GLOB:
1612     case OP_READLINE:
1613     case OP_MATCH:
1614     case OP_RV2AV:
1615     case OP_EACH:
1616     case OP_VALUES:
1617     case OP_KEYS:
1618     case OP_SPLIT:
1619     case OP_LIST:
1620     case OP_SORT:
1621     case OP_REVERSE:
1622     case OP_ENTERSUB:
1623     case OP_CALLER:
1624     case OP_LSTAT:
1625     case OP_STAT:
1626     case OP_READDIR:
1627     case OP_SYSTEM:
1628     case OP_TMS:
1629     case OP_LOCALTIME:
1630     case OP_GMTIME:
1631     case OP_ENTEREVAL:
1632         return;
1633     }
1634
1635     /* Don't warn if we have a nulled list either. */
1636     if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1637         return;
1638
1639     assert(OpSIBLING(kid));
1640     name = S_op_varname(aTHX_ OpSIBLING(kid));
1641     if (!name) /* XS module fiddling with the op tree */
1642         return;
1643     S_op_pretty(aTHX_ kid, &keysv, &key);
1644     assert(SvPOK(name));
1645     sv_chop(name,SvPVX(name)+1);
1646     if (key)
1647        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1648         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1649                    "Scalar value @%"SVf"%c%s%c better written as $%"SVf
1650                    "%c%s%c",
1651                     SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1652                     lbrack, key, rbrack);
1653     else
1654        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1655         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1656                    "Scalar value @%"SVf"%c%"SVf"%c better written as $%"
1657                     SVf"%c%"SVf"%c",
1658                     SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1659                     SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1660 }
1661
1662 OP *
1663 Perl_scalar(pTHX_ OP *o)
1664 {
1665     OP *kid;
1666
1667     /* assumes no premature commitment */
1668     if (!o || (PL_parser && PL_parser->error_count)
1669          || (o->op_flags & OPf_WANT)
1670          || o->op_type == OP_RETURN)
1671     {
1672         return o;
1673     }
1674
1675     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1676
1677     switch (o->op_type) {
1678     case OP_REPEAT:
1679         scalar(cBINOPo->op_first);
1680         if (o->op_private & OPpREPEAT_DOLIST) {
1681             kid = cLISTOPx(cUNOPo->op_first)->op_first;
1682             assert(kid->op_type == OP_PUSHMARK);
1683             if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1684                 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1685                 o->op_private &=~ OPpREPEAT_DOLIST;
1686             }
1687         }
1688         break;
1689     case OP_OR:
1690     case OP_AND:
1691     case OP_COND_EXPR:
1692         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
1693             scalar(kid);
1694         break;
1695         /* FALLTHROUGH */
1696     case OP_SPLIT:
1697     case OP_MATCH:
1698     case OP_QR:
1699     case OP_SUBST:
1700     case OP_NULL:
1701     default:
1702         if (o->op_flags & OPf_KIDS) {
1703             for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1704                 scalar(kid);
1705         }
1706         break;
1707     case OP_LEAVE:
1708     case OP_LEAVETRY:
1709         kid = cLISTOPo->op_first;
1710         scalar(kid);
1711         kid = OpSIBLING(kid);
1712     do_kids:
1713         while (kid) {
1714             OP *sib = OpSIBLING(kid);
1715             if (sib && kid->op_type != OP_LEAVEWHEN
1716              && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
1717                 || (  sib->op_targ != OP_NEXTSTATE
1718                    && sib->op_targ != OP_DBSTATE  )))
1719                 scalarvoid(kid);
1720             else
1721                 scalar(kid);
1722             kid = sib;
1723         }
1724         PL_curcop = &PL_compiling;
1725         break;
1726     case OP_SCOPE:
1727     case OP_LINESEQ:
1728     case OP_LIST:
1729         kid = cLISTOPo->op_first;
1730         goto do_kids;
1731     case OP_SORT:
1732         Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1733         break;
1734     case OP_KVHSLICE:
1735     case OP_KVASLICE:
1736     {
1737         /* Warn about scalar context */
1738         const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1739         const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1740         SV *name;
1741         SV *keysv;
1742         const char *key = NULL;
1743
1744         /* This warning can be nonsensical when there is a syntax error. */
1745         if (PL_parser && PL_parser->error_count)
1746             break;
1747
1748         if (!ckWARN(WARN_SYNTAX)) break;
1749
1750         kid = cLISTOPo->op_first;
1751         kid = OpSIBLING(kid); /* get past pushmark */
1752         assert(OpSIBLING(kid));
1753         name = S_op_varname(aTHX_ OpSIBLING(kid));
1754         if (!name) /* XS module fiddling with the op tree */
1755             break;
1756         S_op_pretty(aTHX_ kid, &keysv, &key);
1757         assert(SvPOK(name));
1758         sv_chop(name,SvPVX(name)+1);
1759         if (key)
1760   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1761             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1762                        "%%%"SVf"%c%s%c in scalar context better written "
1763                        "as $%"SVf"%c%s%c",
1764                         SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1765                         lbrack, key, rbrack);
1766         else
1767   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1768             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1769                        "%%%"SVf"%c%"SVf"%c in scalar context better "
1770                        "written as $%"SVf"%c%"SVf"%c",
1771                         SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1772                         SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1773     }
1774     }
1775     return o;
1776 }
1777
1778 OP *
1779 Perl_scalarvoid(pTHX_ OP *arg)
1780 {
1781     dVAR;
1782     OP *kid;
1783     SV* sv;
1784     U8 want;
1785     SSize_t defer_stack_alloc = 0;
1786     SSize_t defer_ix = -1;
1787     OP **defer_stack = NULL;
1788     OP *o = arg;
1789
1790     PERL_ARGS_ASSERT_SCALARVOID;
1791
1792     do {
1793         SV *useless_sv = NULL;
1794         const char* useless = NULL;
1795
1796         if (o->op_type == OP_NEXTSTATE
1797             || o->op_type == OP_DBSTATE
1798             || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1799                                           || o->op_targ == OP_DBSTATE)))
1800             PL_curcop = (COP*)o;                /* for warning below */
1801
1802         /* assumes no premature commitment */
1803         want = o->op_flags & OPf_WANT;
1804         if ((want && want != OPf_WANT_SCALAR)
1805             || (PL_parser && PL_parser->error_count)
1806             || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1807         {
1808             continue;
1809         }
1810
1811         if ((o->op_private & OPpTARGET_MY)
1812             && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1813         {
1814             /* newASSIGNOP has already applied scalar context, which we
1815                leave, as if this op is inside SASSIGN.  */
1816             continue;
1817         }
1818
1819         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1820
1821         switch (o->op_type) {
1822         default:
1823             if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1824                 break;
1825             /* FALLTHROUGH */
1826         case OP_REPEAT:
1827             if (o->op_flags & OPf_STACKED)
1828                 break;
1829             if (o->op_type == OP_REPEAT)
1830                 scalar(cBINOPo->op_first);
1831             goto func_ops;
1832         case OP_SUBSTR:
1833             if (o->op_private == 4)
1834                 break;
1835             /* FALLTHROUGH */
1836         case OP_WANTARRAY:
1837         case OP_GV:
1838         case OP_SMARTMATCH:
1839         case OP_AV2ARYLEN:
1840         case OP_REF:
1841         case OP_REFGEN:
1842         case OP_SREFGEN:
1843         case OP_DEFINED:
1844         case OP_HEX:
1845         case OP_OCT:
1846         case OP_LENGTH:
1847         case OP_VEC:
1848         case OP_INDEX:
1849         case OP_RINDEX:
1850         case OP_SPRINTF:
1851         case OP_KVASLICE:
1852         case OP_KVHSLICE:
1853         case OP_UNPACK:
1854         case OP_PACK:
1855         case OP_JOIN:
1856         case OP_LSLICE:
1857         case OP_ANONLIST:
1858         case OP_ANONHASH:
1859         case OP_SORT:
1860         case OP_REVERSE:
1861         case OP_RANGE:
1862         case OP_FLIP:
1863         case OP_FLOP:
1864         case OP_CALLER:
1865         case OP_FILENO:
1866         case OP_EOF:
1867         case OP_TELL:
1868         case OP_GETSOCKNAME:
1869         case OP_GETPEERNAME:
1870         case OP_READLINK:
1871         case OP_TELLDIR:
1872         case OP_GETPPID:
1873         case OP_GETPGRP:
1874         case OP_GETPRIORITY:
1875         case OP_TIME:
1876         case OP_TMS:
1877         case OP_LOCALTIME:
1878         case OP_GMTIME:
1879         case OP_GHBYNAME:
1880         case OP_GHBYADDR:
1881         case OP_GHOSTENT:
1882         case OP_GNBYNAME:
1883         case OP_GNBYADDR:
1884         case OP_GNETENT:
1885         case OP_GPBYNAME:
1886         case OP_GPBYNUMBER:
1887         case OP_GPROTOENT:
1888         case OP_GSBYNAME:
1889         case OP_GSBYPORT:
1890         case OP_GSERVENT:
1891         case OP_GPWNAM:
1892         case OP_GPWUID:
1893         case OP_GGRNAM:
1894         case OP_GGRGID:
1895         case OP_GETLOGIN:
1896         case OP_PROTOTYPE:
1897         case OP_RUNCV:
1898         func_ops:
1899             useless = OP_DESC(o);
1900             break;
1901
1902         case OP_GVSV:
1903         case OP_PADSV:
1904         case OP_PADAV:
1905         case OP_PADHV:
1906         case OP_PADANY:
1907         case OP_AELEM:
1908         case OP_AELEMFAST:
1909         case OP_AELEMFAST_LEX:
1910         case OP_ASLICE:
1911         case OP_HELEM:
1912         case OP_HSLICE:
1913             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1914                 /* Otherwise it's "Useless use of grep iterator" */
1915                 useless = OP_DESC(o);
1916             break;
1917
1918         case OP_SPLIT:
1919             kid = cLISTOPo->op_first;
1920             if (kid && kid->op_type == OP_PUSHRE
1921                 && !kid->op_targ
1922                 && !(o->op_flags & OPf_STACKED)
1923 #ifdef USE_ITHREADS
1924                 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
1925 #else
1926                 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
1927 #endif
1928                 )
1929                 useless = OP_DESC(o);
1930             break;
1931
1932         case OP_NOT:
1933             kid = cUNOPo->op_first;
1934             if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1935                 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1936                 goto func_ops;
1937             }
1938             useless = "negative pattern binding (!~)";
1939             break;
1940
1941         case OP_SUBST:
1942             if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1943                 useless = "non-destructive substitution (s///r)";
1944             break;
1945
1946         case OP_TRANSR:
1947             useless = "non-destructive transliteration (tr///r)";
1948             break;
1949
1950         case OP_RV2GV:
1951         case OP_RV2SV:
1952         case OP_RV2AV:
1953         case OP_RV2HV:
1954             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1955                 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
1956                 useless = "a variable";
1957             break;
1958
1959         case OP_CONST:
1960             sv = cSVOPo_sv;
1961             if (cSVOPo->op_private & OPpCONST_STRICT)
1962                 no_bareword_allowed(o);
1963             else {
1964                 if (ckWARN(WARN_VOID)) {
1965                     NV nv;
1966                     /* don't warn on optimised away booleans, eg
1967                      * use constant Foo, 5; Foo || print; */
1968                     if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1969                         useless = NULL;
1970                     /* the constants 0 and 1 are permitted as they are
1971                        conventionally used as dummies in constructs like
1972                        1 while some_condition_with_side_effects;  */
1973                     else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
1974                         useless = NULL;
1975                     else if (SvPOK(sv)) {
1976                         SV * const dsv = newSVpvs("");
1977                         useless_sv
1978                             = Perl_newSVpvf(aTHX_
1979                                             "a constant (%s)",
1980                                             pv_pretty(dsv, SvPVX_const(sv),
1981                                                       SvCUR(sv), 32, NULL, NULL,
1982                                                       PERL_PV_PRETTY_DUMP
1983                                                       | PERL_PV_ESCAPE_NOCLEAR
1984                                                       | PERL_PV_ESCAPE_UNI_DETECT));
1985                         SvREFCNT_dec_NN(dsv);
1986                     }
1987                     else if (SvOK(sv)) {
1988                         useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", SVfARG(sv));
1989                     }
1990                     else
1991                         useless = "a constant (undef)";
1992                 }
1993             }
1994             op_null(o);         /* don't execute or even remember it */
1995             break;
1996
1997         case OP_POSTINC:
1998             OpTYPE_set(o, OP_PREINC);  /* pre-increment is faster */
1999             break;
2000
2001         case OP_POSTDEC:
2002             OpTYPE_set(o, OP_PREDEC);  /* pre-decrement is faster */
2003             break;
2004
2005         case OP_I_POSTINC:
2006             OpTYPE_set(o, OP_I_PREINC);        /* pre-increment is faster */
2007             break;
2008
2009         case OP_I_POSTDEC:
2010             OpTYPE_set(o, OP_I_PREDEC);        /* pre-decrement is faster */
2011             break;
2012
2013         case OP_SASSIGN: {
2014             OP *rv2gv;
2015             UNOP *refgen, *rv2cv;
2016             LISTOP *exlist;
2017
2018             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2019                 break;
2020
2021             rv2gv = ((BINOP *)o)->op_last;
2022             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2023                 break;
2024
2025             refgen = (UNOP *)((BINOP *)o)->op_first;
2026
2027             if (!refgen || (refgen->op_type != OP_REFGEN
2028                             && refgen->op_type != OP_SREFGEN))
2029                 break;
2030
2031             exlist = (LISTOP *)refgen->op_first;
2032             if (!exlist || exlist->op_type != OP_NULL
2033                 || exlist->op_targ != OP_LIST)
2034                 break;
2035
2036             if (exlist->op_first->op_type != OP_PUSHMARK
2037                 && exlist->op_first != exlist->op_last)
2038                 break;
2039
2040             rv2cv = (UNOP*)exlist->op_last;
2041
2042             if (rv2cv->op_type != OP_RV2CV)
2043                 break;
2044
2045             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2046             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2047             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2048
2049             o->op_private |= OPpASSIGN_CV_TO_GV;
2050             rv2gv->op_private |= OPpDONT_INIT_GV;
2051             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2052
2053             break;
2054         }
2055
2056         case OP_AASSIGN: {
2057             inplace_aassign(o);
2058             break;
2059         }
2060
2061         case OP_OR:
2062         case OP_AND:
2063             kid = cLOGOPo->op_first;
2064             if (kid->op_type == OP_NOT
2065                 && (kid->op_flags & OPf_KIDS)) {
2066                 if (o->op_type == OP_AND) {
2067                     OpTYPE_set(o, OP_OR);
2068                 } else {
2069                     OpTYPE_set(o, OP_AND);
2070                 }
2071                 op_null(kid);
2072             }
2073             /* FALLTHROUGH */
2074
2075         case OP_DOR:
2076         case OP_COND_EXPR:
2077         case OP_ENTERGIVEN:
2078         case OP_ENTERWHEN:
2079             for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2080                 if (!(kid->op_flags & OPf_KIDS))
2081                     scalarvoid(kid);
2082                 else
2083                     DEFER_OP(kid);
2084         break;
2085
2086         case OP_NULL:
2087             if (o->op_flags & OPf_STACKED)
2088                 break;
2089             /* FALLTHROUGH */
2090         case OP_NEXTSTATE:
2091         case OP_DBSTATE:
2092         case OP_ENTERTRY:
2093         case OP_ENTER:
2094             if (!(o->op_flags & OPf_KIDS))
2095                 break;
2096             /* FALLTHROUGH */
2097         case OP_SCOPE:
2098         case OP_LEAVE:
2099         case OP_LEAVETRY:
2100         case OP_LEAVELOOP:
2101         case OP_LINESEQ:
2102         case OP_LEAVEGIVEN:
2103         case OP_LEAVEWHEN:
2104         kids:
2105             for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2106                 if (!(kid->op_flags & OPf_KIDS))
2107                     scalarvoid(kid);
2108                 else
2109                     DEFER_OP(kid);
2110             break;
2111         case OP_LIST:
2112             /* If the first kid after pushmark is something that the padrange
2113                optimisation would reject, then null the list and the pushmark.
2114             */
2115             if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2116                 && (  !(kid = OpSIBLING(kid))
2117                       || (  kid->op_type != OP_PADSV
2118                             && kid->op_type != OP_PADAV
2119                             && kid->op_type != OP_PADHV)
2120                       || kid->op_private & ~OPpLVAL_INTRO
2121                       || !(kid = OpSIBLING(kid))
2122                       || (  kid->op_type != OP_PADSV
2123                             && kid->op_type != OP_PADAV
2124                             && kid->op_type != OP_PADHV)
2125                       || kid->op_private & ~OPpLVAL_INTRO)
2126             ) {
2127                 op_null(cUNOPo->op_first); /* NULL the pushmark */
2128                 op_null(o); /* NULL the list */
2129             }
2130             goto kids;
2131         case OP_ENTEREVAL:
2132             scalarkids(o);
2133             break;
2134         case OP_SCALAR:
2135             scalar(o);
2136             break;
2137         }
2138
2139         if (useless_sv) {
2140             /* mortalise it, in case warnings are fatal.  */
2141             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2142                            "Useless use of %"SVf" in void context",
2143                            SVfARG(sv_2mortal(useless_sv)));
2144         }
2145         else if (useless) {
2146             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2147                            "Useless use of %s in void context",
2148                            useless);
2149         }
2150     } while ( (o = POP_DEFERRED_OP()) );
2151
2152     Safefree(defer_stack);
2153
2154     return arg;
2155 }
2156
2157 static OP *
2158 S_listkids(pTHX_ OP *o)
2159 {
2160     if (o && o->op_flags & OPf_KIDS) {
2161         OP *kid;
2162         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2163             list(kid);
2164     }
2165     return o;
2166 }
2167
2168 OP *
2169 Perl_list(pTHX_ OP *o)
2170 {
2171     OP *kid;
2172
2173     /* assumes no premature commitment */
2174     if (!o || (o->op_flags & OPf_WANT)
2175          || (PL_parser && PL_parser->error_count)
2176          || o->op_type == OP_RETURN)
2177     {
2178         return o;
2179     }
2180
2181     if ((o->op_private & OPpTARGET_MY)
2182         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2183     {
2184         return o;                               /* As if inside SASSIGN */
2185     }
2186
2187     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2188
2189     switch (o->op_type) {
2190     case OP_FLOP:
2191         list(cBINOPo->op_first);
2192         break;
2193     case OP_REPEAT:
2194         if (o->op_private & OPpREPEAT_DOLIST
2195          && !(o->op_flags & OPf_STACKED))
2196         {
2197             list(cBINOPo->op_first);
2198             kid = cBINOPo->op_last;
2199             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2200              && SvIVX(kSVOP_sv) == 1)
2201             {
2202                 op_null(o); /* repeat */
2203                 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2204                 /* const (rhs): */
2205                 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2206             }
2207         }
2208         break;
2209     case OP_OR:
2210     case OP_AND:
2211     case OP_COND_EXPR:
2212         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2213             list(kid);
2214         break;
2215     default:
2216     case OP_MATCH:
2217     case OP_QR:
2218     case OP_SUBST:
2219     case OP_NULL:
2220         if (!(o->op_flags & OPf_KIDS))
2221             break;
2222         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2223             list(cBINOPo->op_first);
2224             return gen_constant_list(o);
2225         }
2226         listkids(o);
2227         break;
2228     case OP_LIST:
2229         listkids(o);
2230         if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2231             op_null(cUNOPo->op_first); /* NULL the pushmark */
2232             op_null(o); /* NULL the list */
2233         }
2234         break;
2235     case OP_LEAVE:
2236     case OP_LEAVETRY:
2237         kid = cLISTOPo->op_first;
2238         list(kid);
2239         kid = OpSIBLING(kid);
2240     do_kids:
2241         while (kid) {
2242             OP *sib = OpSIBLING(kid);
2243             if (sib && kid->op_type != OP_LEAVEWHEN)
2244                 scalarvoid(kid);
2245             else
2246                 list(kid);
2247             kid = sib;
2248         }
2249         PL_curcop = &PL_compiling;
2250         break;
2251     case OP_SCOPE:
2252     case OP_LINESEQ:
2253         kid = cLISTOPo->op_first;
2254         goto do_kids;
2255     }
2256     return o;
2257 }
2258
2259 static OP *
2260 S_scalarseq(pTHX_ OP *o)
2261 {
2262     if (o) {
2263         const OPCODE type = o->op_type;
2264
2265         if (type == OP_LINESEQ || type == OP_SCOPE ||
2266             type == OP_LEAVE || type == OP_LEAVETRY)
2267         {
2268             OP *kid, *sib;
2269             for (kid = cLISTOPo->op_first; kid; kid = sib) {
2270                 if ((sib = OpSIBLING(kid))
2271                  && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2272                     || (  sib->op_targ != OP_NEXTSTATE
2273                        && sib->op_targ != OP_DBSTATE  )))
2274                 {
2275                     scalarvoid(kid);
2276                 }
2277             }
2278             PL_curcop = &PL_compiling;
2279         }
2280         o->op_flags &= ~OPf_PARENS;
2281         if (PL_hints & HINT_BLOCK_SCOPE)
2282             o->op_flags |= OPf_PARENS;
2283     }
2284     else
2285         o = newOP(OP_STUB, 0);
2286     return o;
2287 }
2288
2289 STATIC OP *
2290 S_modkids(pTHX_ OP *o, I32 type)
2291 {
2292     if (o && o->op_flags & OPf_KIDS) {
2293         OP *kid;
2294         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2295             op_lvalue(kid, type);
2296     }
2297     return o;
2298 }
2299
2300
2301 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2302  * const fields. Also, convert CONST keys to HEK-in-SVs.
2303  * rop is the op that retrieves the hash;
2304  * key_op is the first key
2305  */
2306
2307 STATIC void
2308 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op)
2309 {
2310     PADNAME *lexname;
2311     GV **fields;
2312     bool check_fields;
2313
2314     /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2315     if (rop) {
2316         if (rop->op_first->op_type == OP_PADSV)
2317             /* @$hash{qw(keys here)} */
2318             rop = (UNOP*)rop->op_first;
2319         else {
2320             /* @{$hash}{qw(keys here)} */
2321             if (rop->op_first->op_type == OP_SCOPE
2322                 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2323                 {
2324                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2325                 }
2326             else
2327                 rop = NULL;
2328         }
2329     }
2330
2331     lexname = NULL; /* just to silence compiler warnings */
2332     fields  = NULL; /* just to silence compiler warnings */
2333
2334     check_fields =
2335             rop
2336          && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2337              SvPAD_TYPED(lexname))
2338          && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2339          && isGV(*fields) && GvHV(*fields);
2340
2341     for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2342         SV **svp, *sv;
2343         if (key_op->op_type != OP_CONST)
2344             continue;
2345         svp = cSVOPx_svp(key_op);
2346
2347         /* make sure it's not a bareword under strict subs */
2348         if (key_op->op_private & OPpCONST_BARE &&
2349             key_op->op_private & OPpCONST_STRICT)
2350         {
2351             no_bareword_allowed((OP*)key_op);
2352         }
2353
2354         /* Make the CONST have a shared SV */
2355         if (   !SvIsCOW_shared_hash(sv = *svp)
2356             && SvTYPE(sv) < SVt_PVMG
2357             && SvOK(sv)
2358             && !SvROK(sv))
2359         {
2360             SSize_t keylen;
2361             const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2362             SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2363             SvREFCNT_dec_NN(sv);
2364             *svp = nsv;
2365         }
2366
2367         if (   check_fields
2368             && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2369         {
2370             Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
2371                         "in variable %"PNf" of type %"HEKf,
2372                         SVfARG(*svp), PNfARG(lexname),
2373                         HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2374         }
2375     }
2376 }
2377
2378
2379 /*
2380 =for apidoc finalize_optree
2381
2382 This function finalizes the optree.  Should be called directly after
2383 the complete optree is built.  It does some additional
2384 checking which can't be done in the normal C<ck_>xxx functions and makes
2385 the tree thread-safe.
2386
2387 =cut
2388 */
2389 void
2390 Perl_finalize_optree(pTHX_ OP* o)
2391 {
2392     PERL_ARGS_ASSERT_FINALIZE_OPTREE;
2393
2394     ENTER;
2395     SAVEVPTR(PL_curcop);
2396
2397     finalize_op(o);
2398
2399     LEAVE;
2400 }
2401
2402 #ifdef USE_ITHREADS
2403 /* Relocate sv to the pad for thread safety.
2404  * Despite being a "constant", the SV is written to,
2405  * for reference counts, sv_upgrade() etc. */
2406 PERL_STATIC_INLINE void
2407 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
2408 {
2409     PADOFFSET ix;
2410     PERL_ARGS_ASSERT_OP_RELOCATE_SV;
2411     if (!*svp) return;
2412     ix = pad_alloc(OP_CONST, SVf_READONLY);
2413     SvREFCNT_dec(PAD_SVl(ix));
2414     PAD_SETSV(ix, *svp);
2415     /* XXX I don't know how this isn't readonly already. */
2416     if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
2417     *svp = NULL;
2418     *targp = ix;
2419 }
2420 #endif
2421
2422
2423 STATIC void
2424 S_finalize_op(pTHX_ OP* o)
2425 {
2426     PERL_ARGS_ASSERT_FINALIZE_OP;
2427
2428
2429     switch (o->op_type) {
2430     case OP_NEXTSTATE:
2431     case OP_DBSTATE:
2432         PL_curcop = ((COP*)o);          /* for warnings */
2433         break;
2434     case OP_EXEC:
2435         if (OpHAS_SIBLING(o)) {
2436             OP *sib = OpSIBLING(o);
2437             if ((  sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
2438                 && ckWARN(WARN_EXEC)
2439                 && OpHAS_SIBLING(sib))
2440             {
2441                     const OPCODE type = OpSIBLING(sib)->op_type;
2442                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
2443                         const line_t oldline = CopLINE(PL_curcop);
2444                         CopLINE_set(PL_curcop, CopLINE((COP*)sib));
2445                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
2446                             "Statement unlikely to be reached");
2447                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
2448                             "\t(Maybe you meant system() when you said exec()?)\n");
2449                         CopLINE_set(PL_curcop, oldline);
2450                     }
2451             }
2452         }
2453         break;
2454
2455     case OP_GV:
2456         if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
2457             GV * const gv = cGVOPo_gv;
2458             if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
2459                 /* XXX could check prototype here instead of just carping */
2460                 SV * const sv = sv_newmortal();
2461                 gv_efullname3(sv, gv, NULL);
2462                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
2463                     "%"SVf"() called too early to check prototype",
2464                     SVfARG(sv));
2465             }
2466         }
2467         break;
2468
2469     case OP_CONST:
2470         if (cSVOPo->op_private & OPpCONST_STRICT)
2471             no_bareword_allowed(o);
2472         /* FALLTHROUGH */
2473 #ifdef USE_ITHREADS
2474     case OP_HINTSEVAL:
2475         op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
2476 #endif
2477         break;
2478
2479 #ifdef USE_ITHREADS
2480     /* Relocate all the METHOP's SVs to the pad for thread safety. */
2481     case OP_METHOD_NAMED:
2482     case OP_METHOD_SUPER:
2483     case OP_METHOD_REDIR:
2484     case OP_METHOD_REDIR_SUPER:
2485         op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
2486         break;
2487 #endif
2488
2489     case OP_HELEM: {
2490         UNOP *rop;
2491         SVOP *key_op;
2492         OP *kid;
2493
2494         if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
2495             break;
2496
2497         rop = (UNOP*)((BINOP*)o)->op_first;
2498
2499         goto check_keys;
2500
2501     case OP_HSLICE:
2502         S_scalar_slice_warning(aTHX_ o);
2503         /* FALLTHROUGH */
2504
2505     case OP_KVHSLICE:
2506         kid = OpSIBLING(cLISTOPo->op_first);
2507         if (/* I bet there's always a pushmark... */
2508             OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
2509             && OP_TYPE_ISNT_NN(kid, OP_CONST))
2510         {
2511             break;
2512         }
2513
2514         key_op = (SVOP*)(kid->op_type == OP_CONST
2515                                 ? kid
2516                                 : OpSIBLING(kLISTOP->op_first));
2517
2518         rop = (UNOP*)((LISTOP*)o)->op_last;
2519
2520       check_keys:
2521         if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
2522             rop = NULL;
2523         S_check_hash_fields_and_hekify(aTHX_ rop, key_op);
2524         break;
2525     }
2526     case OP_ASLICE:
2527         S_scalar_slice_warning(aTHX_ o);
2528         break;
2529
2530     case OP_SUBST: {
2531         if (cPMOPo->op_pmreplrootu.op_pmreplroot)
2532             finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
2533         break;
2534     }
2535     default:
2536         break;
2537     }
2538
2539     if (o->op_flags & OPf_KIDS) {
2540         OP *kid;
2541
2542 #ifdef DEBUGGING
2543         /* check that op_last points to the last sibling, and that
2544          * the last op_sibling/op_sibparent field points back to the
2545          * parent, and that the only ops with KIDS are those which are
2546          * entitled to them */
2547         U32 type = o->op_type;
2548         U32 family;
2549         bool has_last;
2550
2551         if (type == OP_NULL) {
2552             type = o->op_targ;
2553             /* ck_glob creates a null UNOP with ex-type GLOB
2554              * (which is a list op. So pretend it wasn't a listop */
2555             if (type == OP_GLOB)
2556                 type = OP_NULL;
2557         }
2558         family = PL_opargs[type] & OA_CLASS_MASK;
2559
2560         has_last = (   family == OA_BINOP
2561                     || family == OA_LISTOP
2562                     || family == OA_PMOP
2563                     || family == OA_LOOP
2564                    );
2565         assert(  has_last /* has op_first and op_last, or ...
2566               ... has (or may have) op_first: */
2567               || family == OA_UNOP
2568               || family == OA_UNOP_AUX
2569               || family == OA_LOGOP
2570               || family == OA_BASEOP_OR_UNOP
2571               || family == OA_FILESTATOP
2572               || family == OA_LOOPEXOP
2573               || family == OA_METHOP
2574               /* I don't know why SASSIGN is tagged as OA_BASEOP - DAPM */
2575               || type == OP_SASSIGN
2576               || type == OP_CUSTOM
2577               || type == OP_NULL /* new_logop does this */
2578               );
2579
2580         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2581 #  ifdef PERL_OP_PARENT
2582             if (!OpHAS_SIBLING(kid)) {
2583                 if (has_last)
2584                     assert(kid == cLISTOPo->op_last);
2585                 assert(kid->op_sibparent == o);
2586             }
2587 #  else
2588             if (has_last && !OpHAS_SIBLING(kid))
2589                 assert(kid == cLISTOPo->op_last);
2590 #  endif
2591         }
2592 #endif
2593
2594         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
2595             finalize_op(kid);
2596     }
2597 }
2598
2599 /*
2600 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
2601
2602 Propagate lvalue ("modifiable") context to an op and its children.
2603 C<type> represents the context type, roughly based on the type of op that
2604 would do the modifying, although C<local()> is represented by C<OP_NULL>,
2605 because it has no op type of its own (it is signalled by a flag on
2606 the lvalue op).
2607
2608 This function detects things that can't be modified, such as C<$x+1>, and
2609 generates errors for them.  For example, C<$x+1 = 2> would cause it to be
2610 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
2611
2612 It also flags things that need to behave specially in an lvalue context,
2613 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
2614
2615 =cut
2616 */
2617
2618 static void
2619 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
2620 {
2621     CV *cv = PL_compcv;
2622     PadnameLVALUE_on(pn);
2623     while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
2624         cv = CvOUTSIDE(cv);
2625         assert(cv);
2626         assert(CvPADLIST(cv));
2627         pn =
2628            PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
2629         assert(PadnameLEN(pn));
2630         PadnameLVALUE_on(pn);
2631     }
2632 }
2633
2634 static bool
2635 S_vivifies(const OPCODE type)
2636 {
2637     switch(type) {
2638     case OP_RV2AV:     case   OP_ASLICE:
2639     case OP_RV2HV:     case OP_KVASLICE:
2640     case OP_RV2SV:     case   OP_HSLICE:
2641     case OP_AELEMFAST: case OP_KVHSLICE:
2642     case OP_HELEM:
2643     case OP_AELEM:
2644         return 1;
2645     }
2646     return 0;
2647 }
2648
2649 static void
2650 S_lvref(pTHX_ OP *o, I32 type)
2651 {
2652     dVAR;
2653     OP *kid;
2654     switch (o->op_type) {
2655     case OP_COND_EXPR:
2656         for (kid = OpSIBLING(cUNOPo->op_first); kid;
2657              kid = OpSIBLING(kid))
2658             S_lvref(aTHX_ kid, type);
2659         /* FALLTHROUGH */
2660     case OP_PUSHMARK:
2661         return;
2662     case OP_RV2AV:
2663         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2664         o->op_flags |= OPf_STACKED;
2665         if (o->op_flags & OPf_PARENS) {
2666             if (o->op_private & OPpLVAL_INTRO) {
2667                  yyerror(Perl_form(aTHX_ "Can't modify reference to "
2668                       "localized parenthesized array in list assignment"));
2669                 return;
2670             }
2671           slurpy:
2672             OpTYPE_set(o, OP_LVAVREF);
2673             o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
2674             o->op_flags |= OPf_MOD|OPf_REF;
2675             return;
2676         }
2677         o->op_private |= OPpLVREF_AV;
2678         goto checkgv;
2679     case OP_RV2CV:
2680         kid = cUNOPo->op_first;
2681         if (kid->op_type == OP_NULL)
2682             kid = cUNOPx(OpSIBLING(kUNOP->op_first))
2683                 ->op_first;
2684         o->op_private = OPpLVREF_CV;
2685         if (kid->op_type == OP_GV)
2686             o->op_flags |= OPf_STACKED;
2687         else if (kid->op_type == OP_PADCV) {
2688             o->op_targ = kid->op_targ;
2689             kid->op_targ = 0;
2690             op_free(cUNOPo->op_first);
2691             cUNOPo->op_first = NULL;
2692             o->op_flags &=~ OPf_KIDS;
2693         }
2694         else goto badref;
2695         break;
2696     case OP_RV2HV:
2697         if (o->op_flags & OPf_PARENS) {
2698           parenhash:
2699             yyerror(Perl_form(aTHX_ "Can't modify reference to "
2700                                  "parenthesized hash in list assignment"));
2701                 return;
2702         }
2703         o->op_private |= OPpLVREF_HV;
2704         /* FALLTHROUGH */
2705     case OP_RV2SV:
2706       checkgv:
2707         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2708         o->op_flags |= OPf_STACKED;
2709         break;
2710     case OP_PADHV:
2711         if (o->op_flags & OPf_PARENS) goto parenhash;
2712         o->op_private |= OPpLVREF_HV;
2713         /* FALLTHROUGH */
2714     case OP_PADSV:
2715         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2716         break;
2717     case OP_PADAV:
2718         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2719         if (o->op_flags & OPf_PARENS) goto slurpy;
2720         o->op_private |= OPpLVREF_AV;
2721         break;
2722     case OP_AELEM:
2723     case OP_HELEM:
2724         o->op_private |= OPpLVREF_ELEM;
2725         o->op_flags   |= OPf_STACKED;
2726         break;
2727     case OP_ASLICE:
2728     case OP_HSLICE:
2729         OpTYPE_set(o, OP_LVREFSLICE);
2730         o->op_private &= OPpLVAL_INTRO|OPpLVREF_ELEM;
2731         return;
2732     case OP_NULL:
2733         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
2734             goto badref;
2735         else if (!(o->op_flags & OPf_KIDS))
2736             return;
2737         if (o->op_targ != OP_LIST) {
2738             S_lvref(aTHX_ cBINOPo->op_first, type);
2739             return;
2740         }
2741         /* FALLTHROUGH */
2742     case OP_LIST:
2743         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
2744             assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
2745             S_lvref(aTHX_ kid, type);
2746         }
2747         return;
2748     case OP_STUB:
2749         if (o->op_flags & OPf_PARENS)
2750             return;
2751         /* FALLTHROUGH */
2752     default:
2753       badref:
2754         /* diag_listed_as: Can't modify reference to %s in %s assignment */
2755         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
2756                      o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
2757                       ? "do block"
2758                       : OP_DESC(o),
2759                      PL_op_desc[type]));
2760     }
2761     OpTYPE_set(o, OP_LVREF);
2762     o->op_private &=
2763         OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
2764     if (type == OP_ENTERLOOP)
2765         o->op_private |= OPpLVREF_ITER;
2766 }
2767
2768 OP *
2769 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
2770 {
2771     dVAR;
2772     OP *kid;
2773     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2774     int localize = -1;
2775
2776     if (!o || (PL_parser && PL_parser->error_count))
2777         return o;
2778
2779     if ((o->op_private & OPpTARGET_MY)
2780         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2781     {
2782         return o;
2783     }
2784
2785     assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2786
2787     if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2788
2789     switch (o->op_type) {
2790     case OP_UNDEF:
2791         PL_modcount++;
2792         return o;
2793     case OP_STUB:
2794         if ((o->op_flags & OPf_PARENS))
2795             break;
2796         goto nomod;
2797     case OP_ENTERSUB:
2798         if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
2799             !(o->op_flags & OPf_STACKED)) {
2800             OpTYPE_set(o, OP_RV2CV);            /* entersub => rv2cv */
2801             assert(cUNOPo->op_first->op_type == OP_NULL);
2802             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
2803             break;
2804         }
2805         else {                          /* lvalue subroutine call */
2806             o->op_private |= OPpLVAL_INTRO;
2807             PL_modcount = RETURN_UNLIMITED_NUMBER;
2808             if (type == OP_GREPSTART || type == OP_ENTERSUB
2809              || type == OP_REFGEN    || type == OP_LEAVESUBLV) {
2810                 /* Potential lvalue context: */
2811                 o->op_private |= OPpENTERSUB_INARGS;
2812                 break;
2813             }
2814             else {                      /* Compile-time error message: */
2815                 OP *kid = cUNOPo->op_first;
2816                 CV *cv;
2817                 GV *gv;
2818                 SV *namesv;
2819
2820                 if (kid->op_type != OP_PUSHMARK) {
2821                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2822                         Perl_croak(aTHX_
2823                                 "panic: unexpected lvalue entersub "
2824                                 "args: type/targ %ld:%"UVuf,
2825                                 (long)kid->op_type, (UV)kid->op_targ);
2826                     kid = kLISTOP->op_first;
2827                 }
2828                 while (OpHAS_SIBLING(kid))
2829                     kid = OpSIBLING(kid);
2830                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
2831                     break;      /* Postpone until runtime */
2832                 }
2833
2834                 kid = kUNOP->op_first;
2835                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2836                     kid = kUNOP->op_first;
2837                 if (kid->op_type == OP_NULL)
2838                     Perl_croak(aTHX_
2839                                "Unexpected constant lvalue entersub "
2840                                "entry via type/targ %ld:%"UVuf,
2841                                (long)kid->op_type, (UV)kid->op_targ);
2842                 if (kid->op_type != OP_GV) {
2843                     break;
2844                 }
2845
2846                 gv = kGVOP_gv;
2847                 cv = isGV(gv)
2848                     ? GvCV(gv)
2849                     : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
2850                         ? MUTABLE_CV(SvRV(gv))
2851                         : NULL;
2852                 if (!cv)
2853                     break;
2854                 if (CvLVALUE(cv))
2855                     break;
2856                 if (flags & OP_LVALUE_NO_CROAK)
2857                     return NULL;
2858
2859                 namesv = cv_name(cv, NULL, 0);
2860                 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
2861                                      "subroutine call of &%"SVf" in %s",
2862                                      SVfARG(namesv), PL_op_desc[type]),
2863                            SvUTF8(namesv));
2864                 return o;
2865             }
2866         }
2867         /* FALLTHROUGH */
2868     default:
2869       nomod:
2870         if (flags & OP_LVALUE_NO_CROAK) return NULL;
2871         /* grep, foreach, subcalls, refgen */
2872         if (type == OP_GREPSTART || type == OP_ENTERSUB
2873          || type == OP_REFGEN    || type == OP_LEAVESUBLV)
2874             break;
2875         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2876                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
2877                       ? "do block"
2878                       : OP_DESC(o)),
2879                      type ? PL_op_desc[type] : "local"));
2880         return o;
2881
2882     case OP_PREINC:
2883     case OP_PREDEC:
2884     case OP_POW:
2885     case OP_MULTIPLY:
2886     case OP_DIVIDE:
2887     case OP_MODULO:
2888     case OP_ADD:
2889     case OP_SUBTRACT:
2890     case OP_CONCAT:
2891     case OP_LEFT_SHIFT:
2892     case OP_RIGHT_SHIFT:
2893     case OP_BIT_AND:
2894     case OP_BIT_XOR:
2895     case OP_BIT_OR:
2896     case OP_I_MULTIPLY:
2897     case OP_I_DIVIDE:
2898     case OP_I_MODULO:
2899     case OP_I_ADD:
2900     case OP_I_SUBTRACT:
2901         if (!(o->op_flags & OPf_STACKED))
2902             goto nomod;
2903         PL_modcount++;
2904         break;
2905
2906     case OP_REPEAT:
2907         if (o->op_flags & OPf_STACKED) {
2908             PL_modcount++;
2909             break;
2910         }
2911         if (!(o->op_private & OPpREPEAT_DOLIST))
2912             goto nomod;
2913         else {
2914             const I32 mods = PL_modcount;
2915             modkids(cBINOPo->op_first, type);
2916             if (type != OP_AASSIGN)
2917                 goto nomod;
2918             kid = cBINOPo->op_last;
2919             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
2920                 const IV iv = SvIV(kSVOP_sv);
2921                 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
2922                     PL_modcount =
2923                         mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
2924             }
2925             else
2926                 PL_modcount = RETURN_UNLIMITED_NUMBER;
2927         }
2928         break;
2929
2930     case OP_COND_EXPR:
2931         localize = 1;
2932         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2933             op_lvalue(kid, type);
2934         break;
2935
2936     case OP_RV2AV:
2937     case OP_RV2HV:
2938         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
2939            PL_modcount = RETURN_UNLIMITED_NUMBER;
2940             return o;           /* Treat \(@foo) like ordinary list. */
2941         }
2942         /* FALLTHROUGH */
2943     case OP_RV2GV:
2944         if (scalar_mod_type(o, type))
2945             goto nomod;
2946         ref(cUNOPo->op_first, o->op_type);
2947         /* FALLTHROUGH */
2948     case OP_ASLICE:
2949     case OP_HSLICE:
2950         localize = 1;
2951         /* FALLTHROUGH */
2952     case OP_AASSIGN:
2953         /* Do not apply the lvsub flag for rv2[ah]v in scalar context.  */
2954         if (type == OP_LEAVESUBLV && (
2955                 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
2956              || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2957            ))
2958             o->op_private |= OPpMAYBE_LVSUB;
2959         /* FALLTHROUGH */
2960     case OP_NEXTSTATE:
2961     case OP_DBSTATE:
2962        PL_modcount = RETURN_UNLIMITED_NUMBER;
2963         break;
2964     case OP_KVHSLICE:
2965     case OP_KVASLICE:
2966         if (type == OP_LEAVESUBLV)
2967             o->op_private |= OPpMAYBE_LVSUB;
2968         goto nomod;
2969     case OP_AV2ARYLEN:
2970         PL_hints |= HINT_BLOCK_SCOPE;
2971         if (type == OP_LEAVESUBLV)
2972             o->op_private |= OPpMAYBE_LVSUB;
2973         PL_modcount++;
2974         break;
2975     case OP_RV2SV:
2976         ref(cUNOPo->op_first, o->op_type);
2977         localize = 1;
2978         /* FALLTHROUGH */
2979     case OP_GV:
2980         PL_hints |= HINT_BLOCK_SCOPE;
2981         /* FALLTHROUGH */
2982     case OP_SASSIGN:
2983     case OP_ANDASSIGN:
2984     case OP_ORASSIGN:
2985     case OP_DORASSIGN:
2986         PL_modcount++;
2987         break;
2988
2989     case OP_AELEMFAST:
2990     case OP_AELEMFAST_LEX:
2991         localize = -1;
2992         PL_modcount++;
2993         break;
2994
2995     case OP_PADAV:
2996     case OP_PADHV:
2997        PL_modcount = RETURN_UNLIMITED_NUMBER;
2998         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
2999             return o;           /* Treat \(@foo) like ordinary list. */
3000         if (scalar_mod_type(o, type))
3001             goto nomod;
3002         if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
3003           && type == OP_LEAVESUBLV)
3004             o->op_private |= OPpMAYBE_LVSUB;
3005         /* FALLTHROUGH */
3006     case OP_PADSV:
3007         PL_modcount++;
3008         if (!type) /* local() */
3009             Perl_croak(aTHX_ "Can't localize lexical variable %"PNf,
3010                               PNfARG(PAD_COMPNAME(o->op_targ)));
3011         if (!(o->op_private & OPpLVAL_INTRO)
3012          || (  type != OP_SASSIGN && type != OP_AASSIGN
3013             && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ))  ))
3014             S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
3015         break;
3016
3017     case OP_PUSHMARK:
3018         localize = 0;
3019         break;
3020
3021     case OP_KEYS:
3022         if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
3023             goto nomod;
3024         goto lvalue_func;
3025     case OP_SUBSTR:
3026         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
3027             goto nomod;
3028         /* FALLTHROUGH */
3029     case OP_POS:
3030     case OP_VEC:
3031       lvalue_func:
3032         if (type == OP_LEAVESUBLV)
3033             o->op_private |= OPpMAYBE_LVSUB;
3034         if (o->op_flags & OPf_KIDS)
3035             op_lvalue(OpSIBLING(cBINOPo->op_first), type);
3036         break;
3037
3038     case OP_AELEM:
3039     case OP_HELEM:
3040         ref(cBINOPo->op_first, o->op_type);
3041         if (type == OP_ENTERSUB &&
3042              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
3043             o->op_private |= OPpLVAL_DEFER;
3044         if (type == OP_LEAVESUBLV)
3045             o->op_private |= OPpMAYBE_LVSUB;
3046         localize = 1;
3047         PL_modcount++;
3048         break;
3049
3050     case OP_LEAVE:
3051     case OP_LEAVELOOP:
3052         o->op_private |= OPpLVALUE;
3053         /* FALLTHROUGH */
3054     case OP_SCOPE:
3055     case OP_ENTER:
3056     case OP_LINESEQ:
3057         localize = 0;
3058         if (o->op_flags & OPf_KIDS)
3059             op_lvalue(cLISTOPo->op_last, type);
3060         break;
3061
3062     case OP_NULL:
3063         localize = 0;
3064         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
3065             goto nomod;
3066         else if (!(o->op_flags & OPf_KIDS))
3067             break;
3068         if (o->op_targ != OP_LIST) {
3069             op_lvalue(cBINOPo->op_first, type);
3070             break;
3071         }
3072         /* FALLTHROUGH */
3073     case OP_LIST:
3074         localize = 0;
3075         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3076             /* elements might be in void context because the list is
3077                in scalar context or because they are attribute sub calls */
3078             if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
3079                 op_lvalue(kid, type);
3080         break;
3081
3082     case OP_COREARGS:
3083         return o;
3084
3085     case OP_AND:
3086     case OP_OR:
3087         if (type == OP_LEAVESUBLV
3088          || !S_vivifies(cLOGOPo->op_first->op_type))
3089             op_lvalue(cLOGOPo->op_first, type);
3090         if (type == OP_LEAVESUBLV
3091          || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
3092             op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
3093         goto nomod;
3094
3095     case OP_SREFGEN:
3096         if (type != OP_AASSIGN && type != OP_SASSIGN
3097          && type != OP_ENTERLOOP)
3098             goto nomod;
3099         /* Don’t bother applying lvalue context to the ex-list.  */
3100         kid = cUNOPx(cUNOPo->op_first)->op_first;
3101         assert (!OpHAS_SIBLING(kid));
3102         goto kid_2lvref;
3103     case OP_REFGEN:
3104         if (type != OP_AASSIGN) goto nomod;
3105         kid = cUNOPo->op_first;
3106       kid_2lvref:
3107         {
3108             const U8 ec = PL_parser ? PL_parser->error_count : 0;
3109             S_lvref(aTHX_ kid, type);
3110             if (!PL_parser || PL_parser->error_count == ec) {
3111                 if (!FEATURE_REFALIASING_IS_ENABLED)
3112                     Perl_croak(aTHX_
3113                        "Experimental aliasing via reference not enabled");
3114                 Perl_ck_warner_d(aTHX_
3115                                  packWARN(WARN_EXPERIMENTAL__REFALIASING),
3116                                 "Aliasing via reference is experimental");
3117             }
3118         }
3119         if (o->op_type == OP_REFGEN)
3120             op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
3121         op_null(o);
3122         return o;
3123
3124     case OP_SPLIT:
3125         kid = cLISTOPo->op_first;
3126         if (kid && kid->op_type == OP_PUSHRE &&
3127                 (  kid->op_targ
3128                 || o->op_flags & OPf_STACKED
3129 #ifdef USE_ITHREADS
3130                 || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
3131 #else
3132                 || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
3133 #endif
3134         )) {
3135             /* This is actually @array = split.  */
3136             PL_modcount = RETURN_UNLIMITED_NUMBER;
3137             break;
3138         }
3139         goto nomod;
3140
3141     case OP_SCALAR:
3142         op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
3143         goto nomod;
3144     }
3145
3146     /* [20011101.069] File test operators interpret OPf_REF to mean that
3147        their argument is a filehandle; thus \stat(".") should not set
3148        it. AMS 20011102 */
3149     if (type == OP_REFGEN &&
3150         PL_check[o->op_type] == Perl_ck_ftst)
3151         return o;
3152
3153     if (type != OP_LEAVESUBLV)
3154         o->op_flags |= OPf_MOD;
3155
3156     if (type == OP_AASSIGN || type == OP_SASSIGN)
3157         o->op_flags |= OPf_SPECIAL|OPf_REF;
3158     else if (!type) { /* local() */
3159         switch (localize) {
3160         case 1:
3161             o->op_private |= OPpLVAL_INTRO;
3162             o->op_flags &= ~OPf_SPECIAL;
3163             PL_hints |= HINT_BLOCK_SCOPE;
3164             break;
3165         case 0:
3166             break;
3167         case -1:
3168             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
3169                            "Useless localization of %s", OP_DESC(o));
3170         }
3171     }
3172     else if (type != OP_GREPSTART && type != OP_ENTERSUB
3173              && type != OP_LEAVESUBLV)
3174         o->op_flags |= OPf_REF;
3175     return o;
3176 }
3177
3178 STATIC bool
3179 S_scalar_mod_type(const OP *o, I32 type)
3180 {
3181     switch (type) {
3182     case OP_POS:
3183     case OP_SASSIGN:
3184         if (o && o->op_type == OP_RV2GV)
3185             return FALSE;
3186         /* FALLTHROUGH */
3187     case OP_PREINC:
3188     case OP_PREDEC:
3189     case OP_POSTINC:
3190     case OP_POSTDEC:
3191     case OP_I_PREINC:
3192     case OP_I_PREDEC:
3193     case OP_I_POSTINC:
3194     case OP_I_POSTDEC:
3195     case OP_POW:
3196     case OP_MULTIPLY:
3197     case OP_DIVIDE:
3198     case OP_MODULO:
3199     case OP_REPEAT:
3200     case OP_ADD:
3201     case OP_SUBTRACT:
3202     case OP_I_MULTIPLY:
3203     case OP_I_DIVIDE:
3204     case OP_I_MODULO:
3205     case OP_I_ADD:
3206     case OP_I_SUBTRACT:
3207     case OP_LEFT_SHIFT:
3208     case OP_RIGHT_SHIFT:
3209     case OP_BIT_AND:
3210     case OP_BIT_XOR:
3211     case OP_BIT_OR:
3212     case OP_CONCAT:
3213     case OP_SUBST:
3214     case OP_TRANS:
3215     case OP_TRANSR:
3216     case OP_READ:
3217     case OP_SYSREAD:
3218     case OP_RECV:
3219     case OP_ANDASSIGN:
3220     case OP_ORASSIGN:
3221     case OP_DORASSIGN:
3222         return TRUE;
3223     default:
3224         return FALSE;
3225     }
3226 }
3227
3228 STATIC bool
3229 S_is_handle_constructor(const OP *o, I32 numargs)
3230 {
3231     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
3232
3233     switch (o->op_type) {
3234     case OP_PIPE_OP:
3235     case OP_SOCKPAIR:
3236         if (numargs == 2)
3237             return TRUE;
3238         /* FALLTHROUGH */
3239     case OP_SYSOPEN:
3240     case OP_OPEN:
3241     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
3242     case OP_SOCKET:
3243     case OP_OPEN_DIR:
3244     case OP_ACCEPT:
3245         if (numargs == 1)
3246             return TRUE;
3247         /* FALLTHROUGH */
3248     default:
3249         return FALSE;
3250     }
3251 }
3252
3253 static OP *
3254 S_refkids(pTHX_ OP *o, I32 type)
3255 {
3256     if (o && o->op_flags & OPf_KIDS) {
3257         OP *kid;
3258         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3259             ref(kid, type);
3260     }
3261     return o;
3262 }
3263
3264 OP *
3265 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
3266 {
3267     dVAR;
3268     OP *kid;
3269
3270     PERL_ARGS_ASSERT_DOREF;
3271
3272     if (PL_parser && PL_parser->error_count)
3273         return o;
3274
3275     switch (o->op_type) {
3276     case OP_ENTERSUB:
3277         if ((type == OP_EXISTS || type == OP_DEFINED) &&
3278             !(o->op_flags & OPf_STACKED)) {
3279             OpTYPE_set(o, OP_RV2CV);             /* entersub => rv2cv */
3280             assert(cUNOPo->op_first->op_type == OP_NULL);
3281             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
3282             o->op_flags |= OPf_SPECIAL;
3283         }
3284         else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
3285             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3286                               : type == OP_RV2HV ? OPpDEREF_HV
3287                               : OPpDEREF_SV);
3288             o->op_flags |= OPf_MOD;
3289         }
3290
3291         break;
3292
3293     case OP_COND_EXPR:
3294         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
3295             doref(kid, type, set_op_ref);
3296         break;
3297     case OP_RV2SV:
3298         if (type == OP_DEFINED)
3299             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
3300         doref(cUNOPo->op_first, o->op_type, set_op_ref);
3301         /* FALLTHROUGH */
3302     case OP_PADSV:
3303         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3304             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3305                               : type == OP_RV2HV ? OPpDEREF_HV
3306                               : OPpDEREF_SV);
3307             o->op_flags |= OPf_MOD;
3308         }
3309         break;
3310
3311     case OP_RV2AV:
3312     case OP_RV2HV:
3313         if (set_op_ref)
3314             o->op_flags |= OPf_REF;
3315         /* FALLTHROUGH */
3316     case OP_RV2GV:
3317         if (type == OP_DEFINED)
3318             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
3319         doref(cUNOPo->op_first, o->op_type, set_op_ref);
3320         break;
3321
3322     case OP_PADAV:
3323     case OP_PADHV:
3324         if (set_op_ref)
3325             o->op_flags |= OPf_REF;
3326         break;
3327
3328     case OP_SCALAR:
3329     case OP_NULL:
3330         if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
3331             break;
3332         doref(cBINOPo->op_first, type, set_op_ref);
3333         break;
3334     case OP_AELEM:
3335     case OP_HELEM:
3336         doref(cBINOPo->op_first, o->op_type, set_op_ref);
3337         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3338             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3339                               : type == OP_RV2HV ? OPpDEREF_HV
3340                               : OPpDEREF_SV);
3341             o->op_flags |= OPf_MOD;
3342         }
3343         break;
3344
3345     case OP_SCOPE:
3346     case OP_LEAVE:
3347         set_op_ref = FALSE;
3348         /* FALLTHROUGH */
3349     case OP_ENTER:
3350     case OP_LIST:
3351         if (!(o->op_flags & OPf_KIDS))
3352             break;
3353         doref(cLISTOPo->op_last, type, set_op_ref);
3354         break;
3355     default:
3356         break;
3357     }
3358     return scalar(o);
3359
3360 }
3361
3362 STATIC OP *
3363 S_dup_attrlist(pTHX_ OP *o)
3364 {
3365     OP *rop;
3366
3367     PERL_ARGS_ASSERT_DUP_ATTRLIST;
3368
3369     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
3370      * where the first kid is OP_PUSHMARK and the remaining ones
3371      * are OP_CONST.  We need to push the OP_CONST values.
3372      */
3373     if (o->op_type == OP_CONST)
3374         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
3375     else {
3376         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
3377         rop = NULL;
3378         for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
3379             if (o->op_type == OP_CONST)
3380                 rop = op_append_elem(OP_LIST, rop,
3381                                   newSVOP(OP_CONST, o->op_flags,
3382                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
3383         }
3384     }
3385     return rop;
3386 }
3387
3388 STATIC void
3389 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
3390 {
3391     PERL_ARGS_ASSERT_APPLY_ATTRS;
3392     {
3393         SV * const stashsv = newSVhek(HvNAME_HEK(stash));
3394
3395         /* fake up C<use attributes $pkg,$rv,@attrs> */
3396
3397 #define ATTRSMODULE "attributes"
3398 #define ATTRSMODULE_PM "attributes.pm"
3399
3400         Perl_load_module(
3401           aTHX_ PERL_LOADMOD_IMPORT_OPS,
3402           newSVpvs(ATTRSMODULE),
3403           NULL,
3404           op_prepend_elem(OP_LIST,
3405                           newSVOP(OP_CONST, 0, stashsv),
3406                           op_prepend_elem(OP_LIST,
3407                                           newSVOP(OP_CONST, 0,
3408                                                   newRV(target)),
3409                                           dup_attrlist(attrs))));
3410     }
3411 }
3412
3413 STATIC void
3414 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
3415 {
3416     OP *pack, *imop, *arg;
3417     SV *meth, *stashsv, **svp;
3418
3419     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
3420
3421     if (!attrs)
3422         return;
3423
3424     assert(target->op_type == OP_PADSV ||
3425            target->op_type == OP_PADHV ||
3426            target->op_type == OP_PADAV);
3427
3428     /* Ensure that attributes.pm is loaded. */
3429     /* Don't force the C<use> if we don't need it. */
3430     svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
3431     if (svp && *svp != &PL_sv_undef)
3432         NOOP;   /* already in %INC */
3433     else
3434         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
3435                                newSVpvs(ATTRSMODULE), NULL);
3436
3437     /* Need package name for method call. */
3438     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
3439
3440     /* Build up the real arg-list. */
3441     stashsv = newSVhek(HvNAME_HEK(stash));
3442
3443     arg = newOP(OP_PADSV, 0);
3444     arg->op_targ = target->op_targ;
3445     arg = op_prepend_elem(OP_LIST,
3446                        newSVOP(OP_CONST, 0, stashsv),
3447                        op_prepend_elem(OP_LIST,
3448                                     newUNOP(OP_REFGEN, 0,
3449                                             arg),
3450                                     dup_attrlist(attrs)));
3451
3452     /* Fake up a method call to import */
3453     meth = newSVpvs_share("import");
3454     imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
3455                    op_append_elem(OP_LIST,
3456                                op_prepend_elem(OP_LIST, pack, arg),
3457                                newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
3458
3459     /* Combine the ops. */
3460     *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
3461 }
3462
3463 /*
3464 =notfor apidoc apply_attrs_string
3465
3466 Attempts to apply a list of attributes specified by the C<attrstr> and
3467 C<len> arguments to the subroutine identified by the C<cv> argument which
3468 is expected to be associated with the package identified by the C<stashpv>
3469 argument (see L<attributes>).  It gets this wrong, though, in that it
3470 does not correctly identify the boundaries of the individual attribute
3471 specifications within C<attrstr>.  This is not really intended for the
3472 public API, but has to be listed here for systems such as AIX which
3473 need an explicit export list for symbols.  (It's called from XS code
3474 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
3475 to respect attribute syntax properly would be welcome.
3476
3477 =cut
3478 */
3479
3480 void
3481 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
3482                         const char *attrstr, STRLEN len)
3483 {
3484     OP *attrs = NULL;
3485
3486     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
3487
3488     if (!len) {
3489         len = strlen(attrstr);
3490     }
3491
3492     while (len) {
3493         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
3494         if (len) {
3495             const char * const sstr = attrstr;
3496             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
3497             attrs = op_append_elem(OP_LIST, attrs,
3498                                 newSVOP(OP_CONST, 0,
3499                                         newSVpvn(sstr, attrstr-sstr)));
3500         }
3501     }
3502
3503     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3504                      newSVpvs(ATTRSMODULE),
3505                      NULL, op_prepend_elem(OP_LIST,
3506                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
3507                                   op_prepend_elem(OP_LIST,
3508                                                newSVOP(OP_CONST, 0,
3509                                                        newRV(MUTABLE_SV(cv))),
3510                                                attrs)));
3511 }
3512
3513 STATIC void
3514 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
3515 {
3516     OP *new_proto = NULL;
3517     STRLEN pvlen;
3518     char *pv;
3519     OP *o;
3520
3521     PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
3522
3523     if (!*attrs)
3524         return;
3525
3526     o = *attrs;
3527     if (o->op_type == OP_CONST) {
3528         pv = SvPV(cSVOPo_sv, pvlen);
3529         if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3530             SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3531             SV ** const tmpo = cSVOPx_svp(o);
3532             SvREFCNT_dec(cSVOPo_sv);
3533             *tmpo = tmpsv;
3534             new_proto = o;
3535             *attrs = NULL;
3536         }
3537     } else if (o->op_type == OP_LIST) {
3538         OP * lasto;
3539         assert(o->op_flags & OPf_KIDS);
3540         lasto = cLISTOPo->op_first;
3541         assert(lasto->op_type == OP_PUSHMARK);
3542         for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
3543             if (o->op_type == OP_CONST) {
3544                 pv = SvPV(cSVOPo_sv, pvlen);
3545                 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3546                     SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3547                     SV ** const tmpo = cSVOPx_svp(o);
3548                     SvREFCNT_dec(cSVOPo_sv);
3549                     *tmpo = tmpsv;
3550                     if (new_proto && ckWARN(WARN_MISC)) {
3551                         STRLEN new_len;
3552                         const char * newp = SvPV(cSVOPo_sv, new_len);
3553                         Perl_warner(aTHX_ packWARN(WARN_MISC),
3554                             "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub",
3555                             UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
3556                         op_free(new_proto);
3557                     }
3558                     else if (new_proto)
3559                         op_free(new_proto);
3560                     new_proto = o;
3561                     /* excise new_proto from the list */
3562                     op_sibling_splice(*attrs, lasto, 1, NULL);
3563                     o = lasto;
3564                     continue;
3565                 }
3566             }
3567             lasto = o;
3568         }
3569         /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
3570            would get pulled in with no real need */
3571         if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
3572             op_free(*attrs);
3573             *attrs = NULL;
3574         }
3575     }
3576
3577     if (new_proto) {
3578         SV *svname;
3579         if (isGV(name)) {
3580             svname = sv_newmortal();
3581             gv_efullname3(svname, name, NULL);
3582         }
3583         else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
3584             svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
3585         else
3586             svname = (SV *)name;
3587         if (ckWARN(WARN_ILLEGALPROTO))
3588             (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
3589         if (*proto && ckWARN(WARN_PROTOTYPE)) {
3590             STRLEN old_len, new_len;
3591             const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
3592             const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
3593
3594             Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3595                 "Prototype '%"UTF8f"' overridden by attribute 'prototype(%"UTF8f")'"
3596                 " in %"SVf,
3597                 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
3598                 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
3599                 SVfARG(svname));
3600         }
3601         if (*proto)
3602             op_free(*proto);
3603         *proto = new_proto;
3604     }
3605 }
3606
3607 static void
3608 S_cant_declare(pTHX_ OP *o)
3609 {
3610     if (o->op_type == OP_NULL
3611      && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
3612         o = cUNOPo->op_first;
3613     yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
3614                              o->op_type == OP_NULL
3615                                && o->op_flags & OPf_SPECIAL
3616                                  ? "do block"
3617                                  : OP_DESC(o),
3618                              PL_parser->in_my == KEY_our   ? "our"   :
3619                              PL_parser->in_my == KEY_state ? "state" :
3620                                                              "my"));
3621 }
3622
3623 STATIC OP *
3624 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
3625 {
3626     I32 type;
3627     const bool stately = PL_parser && PL_parser->in_my == KEY_state;
3628
3629     PERL_ARGS_ASSERT_MY_KID;
3630
3631     if (!o || (PL_parser && PL_parser->error_count))
3632         return o;
3633
3634     type = o->op_type;
3635
3636     if (type == OP_LIST) {
3637         OP *kid;
3638         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3639             my_kid(kid, attrs, imopsp);
3640         return o;
3641     } else if (type == OP_UNDEF || type == OP_STUB) {
3642         return o;
3643     } else if (type == OP_RV2SV ||      /* "our" declaration */
3644                type == OP_RV2AV ||
3645                type == OP_RV2HV) { /* XXX does this let anything illegal in? */
3646         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
3647             S_cant_declare(aTHX_ o);
3648         } else if (attrs) {
3649             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
3650             assert(PL_parser);
3651             PL_parser->in_my = FALSE;
3652             PL_parser->in_my_stash = NULL;
3653             apply_attrs(GvSTASH(gv),
3654                         (type == OP_RV2SV ? GvSV(gv) :
3655                          type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
3656                          type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
3657                         attrs);
3658         }
3659         o->op_private |= OPpOUR_INTRO;
3660         return o;
3661     }
3662     else if (type != OP_PADSV &&
3663              type != OP_PADAV &&
3664              type != OP_PADHV &&
3665              type != OP_PUSHMARK)
3666     {
3667         S_cant_declare(aTHX_ o);
3668         return o;
3669     }
3670     else if (attrs && type != OP_PUSHMARK) {
3671         HV *stash;
3672
3673         assert(PL_parser);
3674         PL_parser->in_my = FALSE;
3675         PL_parser->in_my_stash = NULL;
3676
3677         /* check for C<my Dog $spot> when deciding package */
3678         stash = PAD_COMPNAME_TYPE(o->op_targ);
3679         if (!stash)
3680             stash = PL_curstash;
3681         apply_attrs_my(stash, o, attrs, imopsp);
3682     }
3683     o->op_flags |= OPf_MOD;
3684     o->op_private |= OPpLVAL_INTRO;
3685     if (stately)
3686         o->op_private |= OPpPAD_STATE;
3687     return o;
3688 }
3689
3690 OP *
3691 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
3692 {
3693     OP *rops;
3694     int maybe_scalar = 0;
3695
3696     PERL_ARGS_ASSERT_MY_ATTRS;
3697
3698 /* [perl #17376]: this appears to be premature, and results in code such as
3699    C< our(%x); > executing in list mode rather than void mode */
3700 #if 0
3701     if (o->op_flags & OPf_PARENS)
3702         list(o);
3703     else
3704         maybe_scalar = 1;
3705 #else
3706     maybe_scalar = 1;
3707 #endif
3708     if (attrs)
3709         SAVEFREEOP(attrs);
3710     rops = NULL;
3711     o = my_kid(o, attrs, &rops);
3712     if (rops) {
3713         if (maybe_scalar && o->op_type == OP_PADSV) {
3714             o = scalar(op_append_list(OP_LIST, rops, o));
3715             o->op_private |= OPpLVAL_INTRO;
3716         }
3717         else {
3718             /* The listop in rops might have a pushmark at the beginning,
3719                which will mess up list assignment. */
3720             LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
3721             if (rops->op_type == OP_LIST &&
3722                 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
3723             {
3724                 OP * const pushmark = lrops->op_first;
3725                 /* excise pushmark */
3726                 op_sibling_splice(rops, NULL, 1, NULL);
3727                 op_free(pushmark);
3728             }
3729             o = op_append_list(OP_LIST, o, rops);
3730         }
3731     }
3732     PL_parser->in_my = FALSE;
3733     PL_parser->in_my_stash = NULL;
3734     return o;
3735 }
3736
3737 OP *
3738 Perl_sawparens(pTHX_ OP *o)
3739 {
3740     PERL_UNUSED_CONTEXT;
3741     if (o)
3742         o->op_flags |= OPf_PARENS;
3743     return o;
3744 }
3745
3746 OP *
3747 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
3748 {
3749     OP *o;
3750     bool ismatchop = 0;
3751     const OPCODE ltype = left->op_type;
3752     const OPCODE rtype = right->op_type;
3753
3754     PERL_ARGS_ASSERT_BIND_MATCH;
3755
3756     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
3757           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
3758     {
3759       const char * const desc
3760           = PL_op_desc[(
3761                           rtype == OP_SUBST || rtype == OP_TRANS
3762                        || rtype == OP_TRANSR
3763                        )
3764                        ? (int)rtype : OP_MATCH];
3765       const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
3766       SV * const name =
3767         S_op_varname(aTHX_ left);
3768       if (name)
3769         Perl_warner(aTHX_ packWARN(WARN_MISC),
3770              "Applying %s to %"SVf" will act on scalar(%"SVf")",
3771              desc, SVfARG(name), SVfARG(name));
3772       else {
3773         const char * const sample = (isary
3774              ? "@array" : "%hash");
3775         Perl_warner(aTHX_ packWARN(WARN_MISC),
3776              "Applying %s to %s will act on scalar(%s)",
3777              desc, sample, sample);
3778       }
3779     }
3780
3781     if (rtype == OP_CONST &&
3782         cSVOPx(right)->op_private & OPpCONST_BARE &&
3783         cSVOPx(right)->op_private & OPpCONST_STRICT)
3784     {
3785         no_bareword_allowed(right);
3786     }
3787
3788     /* !~ doesn't make sense with /r, so error on it for now */
3789     if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
3790         type == OP_NOT)
3791         /* diag_listed_as: Using !~ with %s doesn't make sense */
3792         yyerror("Using !~ with s///r doesn't make sense");
3793     if (rtype == OP_TRANSR && type == OP_NOT)
3794         /* diag_listed_as: Using !~ with %s doesn't make sense */
3795         yyerror("Using !~ with tr///r doesn't make sense");
3796
3797     ismatchop = (rtype == OP_MATCH ||
3798                  rtype == OP_SUBST ||
3799                  rtype == OP_TRANS || rtype == OP_TRANSR)
3800              && !(right->op_flags & OPf_SPECIAL);
3801     if (ismatchop && right->op_private & OPpTARGET_MY) {
3802         right->op_targ = 0;
3803         right->op_private &= ~OPpTARGET_MY;
3804     }
3805     if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
3806         if (left->op_type == OP_PADSV
3807          && !(left->op_private & OPpLVAL_INTRO))
3808         {
3809             right->op_targ = left->op_targ;
3810             op_free(left);
3811             o = right;
3812         }
3813         else {
3814             right->op_flags |= OPf_STACKED;
3815             if (rtype != OP_MATCH && rtype != OP_TRANSR &&
3816             ! (rtype == OP_TRANS &&
3817                right->op_private & OPpTRANS_IDENTICAL) &&
3818             ! (rtype == OP_SUBST &&
3819                (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3820                 left = op_lvalue(left, rtype);
3821             if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
3822                 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
3823             else
3824                 o = op_prepend_elem(rtype, scalar(left), right);
3825         }
3826         if (type == OP_NOT)
3827             return newUNOP(OP_NOT, 0, scalar(o));
3828         return o;
3829     }
3830     else
3831         return bind_match(type, left,
3832                 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
3833 }
3834
3835 OP *
3836 Perl_invert(pTHX_ OP *o)
3837 {
3838     if (!o)
3839         return NULL;
3840     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
3841 }
3842
3843 /*
3844 =for apidoc Amx|OP *|op_scope|OP *o
3845
3846 Wraps up an op tree with some additional ops so that at runtime a dynamic
3847 scope will be created.  The original ops run in the new dynamic scope,
3848 and then, provided that they exit normally, the scope will be unwound.
3849 The additional ops used to create and unwind the dynamic scope will
3850 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
3851 instead if the ops are simple enough to not need the full dynamic scope
3852 structure.
3853
3854 =cut
3855 */
3856
3857 OP *
3858 Perl_op_scope(pTHX_ OP *o)
3859 {
3860     dVAR;
3861     if (o) {
3862         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
3863             o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
3864             OpTYPE_set(o, OP_LEAVE);
3865         }
3866         else if (o->op_type == OP_LINESEQ) {
3867             OP *kid;
3868             OpTYPE_set(o, OP_SCOPE);
3869             kid = ((LISTOP*)o)->op_first;
3870             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
3871                 op_null(kid);
3872
3873                 /* The following deals with things like 'do {1 for 1}' */
3874                 kid = OpSIBLING(kid);
3875                 if (kid &&
3876                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
3877                     op_null(kid);
3878             }
3879         }
3880         else
3881             o = newLISTOP(OP_SCOPE, 0, o, NULL);
3882     }
3883     return o;
3884 }
3885
3886 OP *
3887 Perl_op_unscope(pTHX_ OP *o)
3888 {
3889     if (o && o->op_type == OP_LINESEQ) {
3890         OP *kid = cLISTOPo->op_first;
3891         for(; kid; kid = OpSIBLING(kid))
3892             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
3893                 op_null(kid);
3894     }
3895     return o;
3896 }
3897
3898 /*
3899 =for apidoc Am|int|block_start|int full
3900
3901 Handles compile-time scope entry.
3902 Arranges for hints to be restored on block
3903 exit and also handles pad sequence numbers to make lexical variables scope
3904 right.  Returns a savestack index for use with C<block_end>.
3905
3906 =cut
3907 */
3908
3909 int
3910 Perl_block_start(pTHX_ int full)
3911 {
3912     const int retval = PL_savestack_ix;
3913
3914     PL_compiling.cop_seq = PL_cop_seqmax;
3915     COP_SEQMAX_INC;
3916     pad_block_start(full);
3917     SAVEHINTS();
3918     PL_hints &= ~HINT_BLOCK_SCOPE;
3919     SAVECOMPILEWARNINGS();
3920     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
3921     SAVEI32(PL_compiling.cop_seq);
3922     PL_compiling.cop_seq = 0;
3923
3924     CALL_BLOCK_HOOKS(bhk_start, full);
3925
3926     return retval;
3927 }
3928
3929 /*
3930 =for apidoc Am|OP *|block_end|I32 floor|OP *seq
3931
3932 Handles compile-time scope exit.  C<floor>
3933 is the savestack index returned by
3934 C<block_start>, and C<seq> is the body of the block.  Returns the block,
3935 possibly modified.
3936
3937 =cut
3938 */
3939
3940 OP*
3941 Perl_block_end(pTHX_ I32 floor, OP *seq)
3942 {
3943     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
3944     OP* retval = scalarseq(seq);
3945     OP *o;
3946
3947     /* XXX Is the null PL_parser check necessary here? */
3948     assert(PL_parser); /* Let’s find out under debugging builds.  */
3949     if (PL_parser && PL_parser->parsed_sub) {
3950         o = newSTATEOP(0, NULL, NULL);
3951         op_null(o);
3952         retval = op_append_elem(OP_LINESEQ, retval, o);
3953     }
3954
3955     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
3956
3957     LEAVE_SCOPE(floor);
3958     if (needblockscope)
3959         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
3960     o = pad_leavemy();
3961
3962     if (o) {
3963         /* pad_leavemy has created a sequence of introcv ops for all my
3964            subs declared in the block.  We have to replicate that list with
3965            clonecv ops, to deal with this situation:
3966
3967                sub {
3968                    my sub s1;
3969                    my sub s2;
3970                    sub s1 { state sub foo { \&s2 } }
3971                }->()
3972
3973            Originally, I was going to have introcv clone the CV and turn
3974            off the stale flag.  Since &s1 is declared before &s2, the
3975            introcv op for &s1 is executed (on sub entry) before the one for
3976            &s2.  But the &foo sub inside &s1 (which is cloned when &s1 is
3977            cloned, since it is a state sub) closes over &s2 and expects
3978            to see it in its outer CV’s pad.  If the introcv op clones &s1,
3979            then &s2 is still marked stale.  Since &s1 is not active, and
3980            &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
3981            ble will not stay shared’ warning.  Because it is the same stub
3982            that will be used when the introcv op for &s2 is executed, clos-
3983            ing over it is safe.  Hence, we have to turn off the stale flag
3984            on all lexical subs in the block before we clone any of them.
3985            Hence, having introcv clone the sub cannot work.  So we create a
3986            list of ops like this:
3987
3988                lineseq
3989                   |
3990                   +-- introcv
3991                   |
3992                   +-- introcv
3993                   |
3994                   +-- introcv
3995                   |
3996                   .
3997                   .
3998                   .
3999                   |
4000                   +-- clonecv
4001                   |
4002                   +-- clonecv
4003                   |
4004                   +-- clonecv
4005                   |
4006                   .
4007                   .
4008                   .
4009          */
4010         OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
4011         OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
4012         for (;; kid = OpSIBLING(kid)) {
4013             OP *newkid = newOP(OP_CLONECV, 0);
4014             newkid->op_targ = kid->op_targ;
4015             o = op_append_elem(OP_LINESEQ, o, newkid);
4016             if (kid == last) break;
4017         }
4018         retval = op_prepend_elem(OP_LINESEQ, o, retval);
4019     }
4020
4021     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
4022
4023     return retval;
4024 }
4025
4026 /*
4027 =head1 Compile-time scope hooks
4028
4029 =for apidoc Aox||blockhook_register
4030
4031 Register a set of hooks to be called when the Perl lexical scope changes
4032 at compile time.  See L<perlguts/"Compile-time scope hooks">.
4033
4034 =cut
4035 */
4036
4037 void
4038 Perl_blockhook_register(pTHX_ BHK *hk)
4039 {
4040     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
4041
4042     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
4043 }
4044
4045 void
4046 Perl_newPROG(pTHX_ OP *o)
4047 {
4048     PERL_ARGS_ASSERT_NEWPROG;
4049
4050     if (PL_in_eval) {
4051         PERL_CONTEXT *cx;
4052         I32 i;
4053         if (PL_eval_root)
4054                 return;
4055         PL_eval_root = newUNOP(OP_LEAVEEVAL,
4056                                ((PL_in_eval & EVAL_KEEPERR)
4057                                 ? OPf_SPECIAL : 0), o);
4058
4059         cx = &cxstack[cxstack_ix];
4060         assert(CxTYPE(cx) == CXt_EVAL);
4061
4062         if ((cx->blk_gimme & G_WANT) == G_VOID)
4063             scalarvoid(PL_eval_root);
4064         else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
4065             list(PL_eval_root);
4066         else
4067             scalar(PL_eval_root);
4068
4069         PL_eval_start = op_linklist(PL_eval_root);
4070         PL_eval_root->op_private |= OPpREFCOUNTED;
4071         OpREFCNT_set(PL_eval_root, 1);
4072         PL_eval_root->op_next = 0;
4073         i = PL_savestack_ix;
4074         SAVEFREEOP(o);
4075         ENTER;
4076         CALL_PEEP(PL_eval_start);
4077         finalize_optree(PL_eval_root);
4078         S_prune_chain_head(&PL_eval_start);
4079         LEAVE;
4080         PL_savestack_ix = i;
4081     }
4082     else {
4083         if (o->op_type == OP_STUB) {
4084             /* This block is entered if nothing is compiled for the main
4085                program. This will be the case for an genuinely empty main
4086                program, or one which only has BEGIN blocks etc, so already
4087                run and freed.
4088
4089                Historically (5.000) the guard above was !o. However, commit
4090                f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
4091                c71fccf11fde0068, changed perly.y so that newPROG() is now
4092                called with the output of block_end(), which returns a new
4093                OP_STUB for the case of an empty optree. ByteLoader (and
4094                maybe other things) also take this path, because they set up
4095                PL_main_start and PL_main_root directly, without generating an
4096                optree.
4097
4098                If the parsing the main program aborts (due to parse errors,
4099                or due to BEGIN or similar calling exit), then newPROG()
4100                isn't even called, and hence this code path and its cleanups
4101                are skipped. This shouldn't make a make a difference:
4102                * a non-zero return from perl_parse is a failure, and
4103                  perl_destruct() should be called immediately.
4104                * however, if exit(0) is called during the parse, then
4105                  perl_parse() returns 0, and perl_run() is called. As
4106                  PL_main_start will be NULL, perl_run() will return
4107                  promptly, and the exit code will remain 0.
4108             */
4109
4110             PL_comppad_name = 0;
4111             PL_compcv = 0;
4112             S_op_destroy(aTHX_ o);
4113             return;
4114         }
4115         PL_main_root = op_scope(sawparens(scalarvoid(o)));
4116         PL_curcop = &PL_compiling;
4117         PL_main_start = LINKLIST(PL_main_root);
4118         PL_main_root->op_private |= OPpREFCOUNTED;
4119         OpREFCNT_set(PL_main_root, 1);
4120         PL_main_root->op_next = 0;
4121         CALL_PEEP(PL_main_start);
4122         finalize_optree(PL_main_root);
4123         S_prune_chain_head(&PL_main_start);
4124         cv_forget_slab(PL_compcv);
4125         PL_compcv = 0;
4126
4127         /* Register with debugger */
4128         if (PERLDB_INTER) {
4129             CV * const cv = get_cvs("DB::postponed", 0);
4130             if (cv) {
4131                 dSP;
4132                 PUSHMARK(SP);
4133                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
4134                 PUTBACK;
4135                 call_sv(MUTABLE_SV(cv), G_DISCARD);
4136             }
4137         }
4138     }
4139 }
4140
4141 OP *
4142 Perl_localize(pTHX_ OP *o, I32 lex)
4143 {
4144     PERL_ARGS_ASSERT_LOCALIZE;
4145
4146     if (o->op_flags & OPf_PARENS)
4147 /* [perl #17376]: this appears to be premature, and results in code such as
4148    C< our(%x); > executing in list mode rather than void mode */
4149 #if 0
4150         list(o);
4151 #else
4152         NOOP;
4153 #endif
4154     else {
4155         if ( PL_parser->bufptr > PL_parser->oldbufptr
4156             && PL_parser->bufptr[-1] == ','
4157             && ckWARN(WARN_PARENTHESIS))
4158         {
4159             char *s = PL_parser->bufptr;
4160             bool sigil = FALSE;
4161
4162             /* some heuristics to detect a potential error */
4163             while (*s && (strchr(", \t\n", *s)))
4164                 s++;
4165
4166             while (1) {
4167                 if (*s && (strchr("@$%", *s) || (!lex && *s == '*'))
4168                        && *++s
4169                        && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
4170                     s++;
4171                     sigil = TRUE;
4172                     while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
4173                         s++;
4174                     while (*s && (strchr(", \t\n", *s)))
4175                         s++;
4176                 }
4177                 else
4178                     break;
4179             }
4180             if (sigil && (*s == ';' || *s == '=')) {
4181                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
4182                                 "Parentheses missing around \"%s\" list",
4183                                 lex
4184                                     ? (PL_parser->in_my == KEY_our
4185                                         ? "our"
4186                                         : PL_parser->in_my == KEY_state
4187                                             ? "state"
4188                                             : "my")
4189                                     : "local");
4190             }
4191         }
4192     }
4193     if (lex)
4194         o = my(o);
4195     else
4196         o = op_lvalue(o, OP_NULL);              /* a bit kludgey */
4197     PL_parser->in_my = FALSE;
4198     PL_parser->in_my_stash = NULL;
4199     return o;
4200 }
4201
4202 OP *
4203 Perl_jmaybe(pTHX_ OP *o)
4204 {
4205     PERL_ARGS_ASSERT_JMAYBE;
4206
4207     if (o->op_type == OP_LIST) {
4208         OP * const o2
4209             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
4210         o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
4211     }
4212     return o;
4213 }
4214
4215 PERL_STATIC_INLINE OP *
4216 S_op_std_init(pTHX_ OP *o)
4217 {
4218     I32 type = o->op_type;
4219
4220     PERL_ARGS_ASSERT_OP_STD_INIT;
4221
4222     if (PL_opargs[type] & OA_RETSCALAR)
4223         scalar(o);
4224     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
4225         o->op_targ = pad_alloc(type, SVs_PADTMP);
4226
4227     return o;
4228 }
4229
4230 PERL_STATIC_INLINE OP *
4231 S_op_integerize(pTHX_ OP *o)
4232 {
4233     I32 type = o->op_type;
4234
4235     PERL_ARGS_ASSERT_OP_INTEGERIZE;
4236
4237     /* integerize op. */
4238     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
4239     {
4240         dVAR;
4241         o->op_ppaddr = PL_ppaddr[++(o->op_type)];
4242     }
4243
4244     if (type == OP_NEGATE)
4245         /* XXX might want a ck_negate() for this */
4246         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
4247
4248     return o;
4249 }
4250
4251 static OP *
4252 S_fold_constants(pTHX_ OP *o)
4253 {
4254     dVAR;
4255     OP * VOL curop;
4256     OP *newop;
4257     VOL I32 type = o->op_type;
4258     bool is_stringify;
4259     SV * VOL sv = NULL;
4260     int ret = 0;
4261     I32 oldscope;
4262     OP *old_next;
4263     SV * const oldwarnhook = PL_warnhook;
4264     SV * const olddiehook  = PL_diehook;
4265     COP not_compiling;
4266     U8 oldwarn = PL_dowarn;
4267     dJMPENV;
4268
4269     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
4270
4271     if (!(PL_opargs[type] & OA_FOLDCONST))
4272         goto nope;
4273
4274     switch (type) {
4275     case OP_UCFIRST:
4276     case OP_LCFIRST:
4277     case OP_UC:
4278     case OP_LC:
4279     case OP_FC:
4280 #ifdef USE_LOCALE_CTYPE
4281         if (IN_LC_COMPILETIME(LC_CTYPE))
4282             goto nope;
4283 #endif
4284         break;
4285     case OP_SLT:
4286     case OP_SGT:
4287     case OP_SLE:
4288     case OP_SGE:
4289     case OP_SCMP:
4290 #ifdef USE_LOCALE_COLLATE
4291         if (IN_LC_COMPILETIME(LC_COLLATE))
4292             goto nope;
4293 #endif
4294         break;
4295     case OP_SPRINTF:
4296         /* XXX what about the numeric ops? */
4297 #ifdef USE_LOCALE_NUMERIC
4298         if (IN_LC_COMPILETIME(LC_NUMERIC))
4299             goto nope;
4300 #endif
4301         break;
4302     case OP_PACK:
4303         if (!OpHAS_SIBLING(cLISTOPo->op_first)
4304           || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
4305             goto nope;
4306         {
4307             SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
4308             if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
4309             {
4310                 const char *s = SvPVX_const(sv);
4311                 while (s < SvEND(sv)) {
4312                     if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
4313                     s++;
4314                 }
4315             }
4316         }
4317         break;
4318     case OP_REPEAT:
4319         if (o->op_private & OPpREPEAT_DOLIST) goto nope;
4320         break;
4321     case OP_SREFGEN:
4322         if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
4323          || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
4324             goto nope;
4325     }
4326
4327     if (PL_parser && PL_parser->error_count)
4328         goto nope;              /* Don't try to run w/ errors */
4329
4330     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4331         const OPCODE type = curop->op_type;
4332         if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
4333             type != OP_LIST &&
4334             type != OP_SCALAR &&
4335             type != OP_NULL &&
4336             type != OP_PUSHMARK)
4337         {
4338             goto nope;
4339         }
4340     }
4341
4342     curop = LINKLIST(o);
4343     old_next = o->op_next;
4344     o->op_next = 0;
4345     PL_op = curop;
4346
4347     oldscope = PL_scopestack_ix;
4348     create_eval_scope(G_FAKINGEVAL);
4349
4350     /* Verify that we don't need to save it:  */
4351     assert(PL_curcop == &PL_compiling);
4352     StructCopy(&PL_compiling, &not_compiling, COP);
4353     PL_curcop = &not_compiling;
4354     /* The above ensures that we run with all the correct hints of the
4355        currently compiling COP, but that IN_PERL_RUNTIME is true. */
4356     assert(IN_PERL_RUNTIME);
4357     PL_warnhook = PERL_WARNHOOK_FATAL;
4358     PL_diehook  = NULL;
4359     JMPENV_PUSH(ret);
4360
4361     /* Effective $^W=1.  */
4362     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
4363         PL_dowarn |= G_WARN_ON;
4364
4365     switch (ret) {
4366     case 0:
4367         CALLRUNOPS(aTHX);
4368         sv = *(PL_stack_sp--);
4369         if (o->op_targ && sv == PAD_SV(o->op_targ)) {   /* grab pad temp? */
4370             pad_swipe(o->op_targ,  FALSE);
4371         }
4372         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
4373             SvREFCNT_inc_simple_void(sv);
4374             SvTEMP_off(sv);
4375         }
4376         else { assert(SvIMMORTAL(sv)); }
4377         break;
4378     case 3:
4379         /* Something tried to die.  Abandon constant folding.  */
4380         /* Pretend the error never happened.  */
4381         CLEAR_ERRSV();
4382         o->op_next = old_next;
4383         break;
4384     default:
4385         JMPENV_POP;
4386         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
4387         PL_warnhook = oldwarnhook;
4388         PL_diehook  = olddiehook;
4389         /* XXX note that this croak may fail as we've already blown away
4390          * the stack - eg any nested evals */
4391         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
4392     }
4393     JMPENV_POP;
4394     PL_dowarn   = oldwarn;
4395     PL_warnhook = oldwarnhook;
4396     PL_diehook  = olddiehook;
4397     PL_curcop = &PL_compiling;
4398
4399     if (PL_scopestack_ix > oldscope)
4400         delete_eval_scope();
4401
4402     if (ret)
4403         goto nope;
4404
4405     /* OP_STRINGIFY and constant folding are used to implement qq.
4406        Here the constant folding is an implementation detail that we
4407        want to hide.  If the stringify op is itself already marked
4408        folded, however, then it is actually a folded join.  */
4409     is_stringify = type == OP_STRINGIFY && !o->op_folded;
4410     op_free(o);
4411     assert(sv);
4412     if (is_stringify)
4413         SvPADTMP_off(sv);
4414     else if (!SvIMMORTAL(sv)) {
4415         SvPADTMP_on(sv);
4416         SvREADONLY_on(sv);
4417     }
4418     newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
4419     if (!is_stringify) newop->op_folded = 1;
4420     return newop;
4421
4422  nope:
4423     return o;
4424 }
4425
4426 static OP *
4427 S_gen_constant_list(pTHX_ OP *o)
4428 {
4429     dVAR;
4430     OP *curop;
4431     const SSize_t oldtmps_floor = PL_tmps_floor;
4432     SV **svp;
4433     AV *av;
4434
4435     list(o);
4436     if (PL_parser && PL_parser->error_count)
4437         return o;               /* Don't attempt to run with errors */
4438
4439     curop = LINKLIST(o);
4440     o->op_next = 0;
4441     CALL_PEEP(curop);
4442     S_prune_chain_head(&curop);
4443     PL_op = curop;
4444     Perl_pp_pushmark(aTHX);
4445     CALLRUNOPS(aTHX);
4446     PL_op = curop;
4447     assert (!(curop->op_flags & OPf_SPECIAL));
4448     assert(curop->op_type == OP_RANGE);
4449     Perl_pp_anonlist(aTHX);
4450     PL_tmps_floor = oldtmps_floor;
4451
4452     OpTYPE_set(o, OP_RV2AV);
4453     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
4454     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
4455     o->op_opt = 0;              /* needs to be revisited in rpeep() */
4456     av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
4457
4458     /* replace subtree with an OP_CONST */
4459     curop = ((UNOP*)o)->op_first;
4460     op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
4461     op_free(curop);
4462
4463     if (AvFILLp(av) != -1)
4464         for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
4465         {
4466             SvPADTMP_on(*svp);
4467             SvREADONLY_on(*svp);
4468         }
4469     LINKLIST(o);
4470     return list(o);
4471 }
4472
4473 /*
4474 =head1 Optree Manipulation Functions
4475 */
4476
4477 /* List constructors */
4478
4479 /*
4480 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
4481
4482 Append an item to the list of ops contained directly within a list-type
4483 op, returning the lengthened list.  C<first> is the list-type op,
4484 and C<last> is the op to append to the list.  C<optype> specifies the
4485 intended opcode for the list.  If C<first> is not already a list of the
4486 right type, it will be upgraded into one.  If either C<first> or C<last>
4487 is null, the other is returned unchanged.
4488
4489 =cut
4490 */
4491
4492 OP *
4493 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
4494 {
4495     if (!first)
4496         return last;
4497
4498     if (!last)
4499         return first;
4500
4501     if (first->op_type != (unsigned)type
4502         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
4503     {
4504         return newLISTOP(type, 0, first, last);
4505     }
4506
4507     op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
4508     first->op_flags |= OPf_KIDS;
4509     return first;
4510 }
4511
4512 /*
4513 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
4514
4515 Concatenate the lists of ops contained directly within two list-type ops,
4516 returning the combined list.  C<first> and C<last> are the list-type ops
4517 to concatenate.  C<optype> specifies the intended opcode for the list.
4518 If either C<first> or C<last> is not already a list of the right type,
4519 it will be upgraded into one.  If either C<first> or C<last> is null,
4520 the other is returned unchanged.
4521
4522 =cut
4523 */
4524
4525 OP *
4526 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
4527 {
4528     if (!first)
4529         return last;
4530
4531     if (!last)
4532         return first;
4533
4534     if (first->op_type != (unsigned)type)
4535         return op_prepend_elem(type, first, last);
4536
4537     if (last->op_type != (unsigned)type)
4538         return op_append_elem(type, first, last);
4539
4540     OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
4541     ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
4542     OpLASTSIB_set(((LISTOP*)first)->op_last, first);
4543     first->op_flags |= (last->op_flags & OPf_KIDS);
4544
4545     S_op_destroy(aTHX_ last);
4546
4547     return first;
4548 }
4549
4550 /*
4551 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
4552
4553 Prepend an item to the list of ops contained directly within a list-type
4554 op, returning the lengthened list.  C<first> is the op to prepend to the
4555 list, and C<last> is the list-type op.  C<optype> specifies the intended
4556 opcode for the list.  If C<last> is not already a list of the right type,
4557 it will be upgraded into one.  If either C<first> or C<last> is null,
4558 the other is returned unchanged.
4559
4560 =cut
4561 */
4562
4563 OP *
4564 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
4565 {
4566     if (!first)
4567         return last;
4568
4569     if (!last)
4570         return first;
4571
4572     if (last->op_type == (unsigned)type) {
4573         if (type == OP_LIST) {  /* already a PUSHMARK there */
4574             /* insert 'first' after pushmark */
4575             op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
4576             if (!(first->op_flags & OPf_PARENS))
4577                 last->op_flags &= ~OPf_PARENS;
4578         }
4579         else
4580             op_sibling_splice(last, NULL, 0, first);
4581         last->op_flags |= OPf_KIDS;
4582         return last;
4583     }
4584
4585     return newLISTOP(type, 0, first, last);
4586 }
4587
4588 /*
4589 =for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
4590
4591 Converts C<o> into a list op if it is not one already, and then converts it
4592 into the specified C<type>, calling its check function, allocating a target if
4593 it needs one, and folding constants.
4594
4595 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
4596 C<op_prepend_elem> and C<op_append_elem>.  Then finally it is passed to
4597 C<op_convert_list> to make it the right type.
4598
4599 =cut
4600 */
4601
4602 OP *
4603 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
4604 {
4605     dVAR;
4606     if (type < 0) type = -type, flags |= OPf_SPECIAL;
4607     if (!o || o->op_type != OP_LIST)
4608         o = force_list(o, 0);
4609     else
4610     {
4611         o->op_flags &= ~OPf_WANT;
4612         o->op_private &= ~OPpLVAL_INTRO;
4613     }
4614
4615     if (!(PL_opargs[type] & OA_MARK))
4616         op_null(cLISTOPo->op_first);
4617     else {
4618         OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
4619         if (kid2 && kid2->op_type == OP_COREARGS) {
4620             op_null(cLISTOPo->op_first);
4621             kid2->op_private |= OPpCOREARGS_PUSHMARK;
4622         }
4623     }
4624
4625     OpTYPE_set(o, type);
4626     o->op_flags |= flags;
4627     if (flags & OPf_FOLDED)
4628         o->op_folded = 1;
4629
4630     o = CHECKOP(type, o);
4631     if (o->op_type != (unsigned)type)
4632         return o;
4633
4634     return fold_constants(op_integerize(op_std_init(o)));
4635 }
4636
4637 /* Constructors */
4638
4639
4640 /*
4641 =head1 Optree construction
4642
4643 =for apidoc Am|OP *|newNULLLIST
4644
4645 Constructs, checks, and returns a new C<stub> op, which represents an
4646 empty list expression.
4647
4648 =cut
4649 */
4650
4651 OP *
4652 Perl_newNULLLIST(pTHX)
4653 {
4654     return newOP(OP_STUB, 0);
4655 }
4656
4657 /* promote o and any siblings to be a list if its not already; i.e.
4658  *
4659  *  o - A - B
4660  *
4661  * becomes
4662  *
4663  *  list
4664  *    |
4665  *  pushmark - o - A - B
4666  *
4667  * If nullit it true, the list op is nulled.
4668  */
4669
4670 static OP *
4671 S_force_list(pTHX_ OP *o, bool nullit)
4672 {
4673     if (!o || o->op_type != OP_LIST) {
4674         OP *rest = NULL;
4675         if (o) {
4676             /* manually detach any siblings then add them back later */
4677             rest = OpSIBLING(o);
4678             OpLASTSIB_set(o, NULL);
4679         }
4680         o = newLISTOP(OP_LIST, 0, o, NULL);
4681         if (rest)
4682             op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
4683     }
4684     if (nullit)
4685         op_null(o);
4686     return o;
4687 }
4688
4689 /*
4690 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
4691
4692 Constructs, checks, and returns an op of any list type.  C<type> is
4693 the opcode.  C<flags> gives the eight bits of C<op_flags>, except that
4694 C<OPf_KIDS> will be set automatically if required.  C<first> and C<last>
4695 supply up to two ops to be direct children of the list op; they are
4696 consumed by this function and become part of the constructed op tree.
4697
4698 For most list operators, the check function expects all the kid ops to be
4699 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
4700 appropriate.  What you want to do in that case is create an op of type
4701 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
4702 See L</op_convert_list> for more information.
4703
4704
4705 =cut
4706 */
4707
4708 OP *
4709 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4710 {
4711     dVAR;
4712     LISTOP *listop;
4713
4714     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
4715         || type == OP_CUSTOM);
4716
4717     NewOp(1101, listop, 1, LISTOP);
4718
4719     OpTYPE_set(listop, type);
4720     if (first || last)
4721         flags |= OPf_KIDS;
4722     listop->op_flags = (U8)flags;
4723
4724     if (!last && first)
4725         last = first;
4726     else if (!first && last)
4727         first = last;
4728     else if (first)
4729         OpMORESIB_set(first, last);
4730     listop->op_first = first;
4731     listop->op_last = last;
4732     if (type == OP_LIST) {
4733         OP* const pushop = newOP(OP_PUSHMARK, 0);
4734         OpMORESIB_set(pushop, first);
4735         listop->op_first = pushop;
4736         listop->op_flags |= OPf_KIDS;
4737         if (!last)
4738             listop->op_last = pushop;
4739     }
4740     if (listop->op_last)
4741         OpLASTSIB_set(listop->op_last, (OP*)listop);
4742
4743     return CHECKOP(type, listop);
4744 }
4745
4746 /*
4747 =for apidoc Am|OP *|newOP|I32 type|I32 flags
4748
4749 Constructs, checks, and returns an op of any base type (any type that
4750 has no extra fields).  C<type> is the opcode.  C<flags> gives the
4751 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
4752 of C<op_private>.
4753
4754 =cut
4755 */
4756
4757 OP *
4758 Perl_newOP(pTHX_ I32 type, I32 flags)
4759 {
4760     dVAR;
4761     OP *o;
4762
4763     if (type == -OP_ENTEREVAL) {
4764         type = OP_ENTEREVAL;
4765         flags |= OPpEVAL_BYTES<<8;
4766     }
4767
4768     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
4769         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4770         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4771         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4772
4773     NewOp(1101, o, 1, OP);
4774     OpTYPE_set(o, type);
4775     o->op_flags = (U8)flags;
4776
4777     o->op_next = o;
4778     o->op_private = (U8)(0 | (flags >> 8));
4779     if (PL_opargs[type] & OA_RETSCALAR)
4780         scalar(o);
4781     if (PL_opargs[type] & OA_TARGET)
4782         o->op_targ = pad_alloc(type, SVs_PADTMP);
4783     return CHECKOP(type, o);
4784 }
4785
4786 /*
4787 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
4788
4789 Constructs, checks, and returns an op of any unary type.  C<type> is
4790 the opcode.  C<flags> gives the eight bits of C<op_flags>, except that
4791 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
4792 bits, the eight bits of C<op_private>, except that the bit with value 1
4793 is automatically set.  C<first> supplies an optional op to be the direct
4794 child of the unary op; it is consumed by this function and become part
4795 of the constructed op tree.
4796
4797 =cut
4798 */
4799
4800 OP *
4801 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
4802 {
4803     dVAR;
4804     UNOP *unop;
4805
4806     if (type == -OP_ENTEREVAL) {
4807         type = OP_ENTEREVAL;
4808         flags |= OPpEVAL_BYTES<<8;
4809     }
4810
4811     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
4812         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4813         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4814         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
4815         || type == OP_SASSIGN
4816         || type == OP_ENTERTRY
4817         || type == OP_CUSTOM
4818         || type == OP_NULL );
4819
4820     if (!first)
4821         first = newOP(OP_STUB, 0);
4822     if (PL_opargs[type] & OA_MARK)
4823         first = force_list(first, 1);
4824
4825     NewOp(1101, unop, 1, UNOP);
4826     OpTYPE_set(unop, type);
4827     unop->op_first = first;
4828     unop->op_flags = (U8)(flags | OPf_KIDS);
4829     unop->op_private = (U8)(1 | (flags >> 8));
4830
4831     if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
4832         OpLASTSIB_set(first, (OP*)unop);
4833
4834     unop = (UNOP*) CHECKOP(type, unop);
4835     if (unop->op_next)
4836         return (OP*)unop;
4837
4838     return fold_constants(op_integerize(op_std_init((OP *) unop)));
4839 }
4840
4841 /*
4842 =for apidoc newUNOP_AUX
4843
4844 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
4845 initialised to C<aux>
4846
4847 =cut
4848 */
4849
4850 OP *
4851 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
4852 {
4853     dVAR;
4854     UNOP_AUX *unop;
4855
4856     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
4857         || type == OP_CUSTOM);
4858
4859     NewOp(1101, unop, 1, UNOP_AUX);
4860     unop->op_type = (OPCODE)type;
4861     unop->op_ppaddr = PL_ppaddr[type];
4862     unop->op_first = first;
4863     unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
4864     unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
4865     unop->op_aux = aux;
4866
4867     if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
4868         OpLASTSIB_set(first, (OP*)unop);
4869
4870     unop = (UNOP_AUX*) CHECKOP(type, unop);
4871
4872     return op_std_init((OP *) unop);
4873 }
4874
4875 /*
4876 =for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
4877
4878 Constructs, checks, and returns an op of method type with a method name
4879 evaluated at runtime.  C<type> is the opcode.  C<flags> gives the eight
4880 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
4881 and, shifted up eight bits, the eight bits of C<op_private>, except that
4882 the bit with value 1 is automatically set.  C<dynamic_meth> supplies an
4883 op which evaluates method name; it is consumed by this function and
4884 become part of the constructed op tree.
4885 Supported optypes: C<OP_METHOD>.
4886
4887 =cut
4888 */
4889
4890 static OP*
4891 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
4892     dVAR;
4893     METHOP *methop;
4894
4895     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
4896         || type == OP_CUSTOM);
4897
4898     NewOp(1101, methop, 1, METHOP);
4899     if (dynamic_meth) {
4900         if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
4901         methop->op_flags = (U8)(flags | OPf_KIDS);
4902         methop->op_u.op_first = dynamic_meth;
4903         methop->op_private = (U8)(1 | (flags >> 8));
4904
4905         if (!OpHAS_SIBLING(dynamic_meth))
4906             OpLASTSIB_set(dynamic_meth, (OP*)methop);
4907     }
4908     else {
4909         assert(const_meth);
4910         methop->op_flags = (U8)(flags & ~OPf_KIDS);
4911         methop->op_u.op_meth_sv = const_meth;
4912         methop->op_private = (U8)(0 | (flags >> 8));
4913         methop->op_next = (OP*)methop;
4914     }
4915
4916 #ifdef USE_ITHREADS
4917     methop->op_rclass_targ = 0;
4918 #else
4919     methop->op_rclass_sv = NULL;
4920 #endif
4921
4922     OpTYPE_set(methop, type);
4923     return CHECKOP(type, methop);
4924 }
4925
4926 OP *
4927 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
4928     PERL_ARGS_ASSERT_NEWMETHOP;
4929     return newMETHOP_internal(type, flags, dynamic_meth, NULL);
4930 }
4931
4932 /*
4933 =for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
4934
4935 Constructs, checks, and returns an op of method type with a constant
4936 method name.  C<type> is the opcode.  C<flags> gives the eight bits of
4937 C<op_flags>, and, shifted up eight bits, the eight bits of
4938 C<op_private>.  C<const_meth> supplies a constant method name;
4939 it must be a shared COW string.
4940 Supported optypes: C<OP_METHOD_NAMED>.
4941
4942 =cut
4943 */
4944
4945 OP *
4946 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
4947     PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
4948     return newMETHOP_internal(type, flags, NULL, const_meth);
4949 }
4950
4951 /*
4952 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
4953
4954 Constructs, checks, and returns an op of any binary type.  C<type>
4955 is the opcode.  C<flags> gives the eight bits of C<op_flags>, except
4956 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4957 the eight bits of C<op_private>, except that the bit with value 1 or
4958 2 is automatically set as required.  C<first> and C<last> supply up to
4959 two ops to be the direct children of the binary op; they are consumed
4960 by this function and become part of the constructed op tree.
4961
4962 =cut
4963 */
4964
4965 OP *
4966 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4967 {
4968     dVAR;
4969     BINOP *binop;
4970
4971     ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
4972         || type == OP_SASSIGN || type == OP_NULL || type == OP_CUSTOM);
4973
4974     NewOp(1101, binop, 1, BINOP);
4975
4976     if (!first)
4977         first = newOP(OP_NULL, 0);
4978
4979     OpTYPE_set(binop, type);
4980     binop->op_first = first;
4981     binop->op_flags = (U8)(flags | OPf_KIDS);
4982     if (!last) {
4983         last = first;
4984         binop->op_private = (U8)(1 | (flags >> 8));
4985     }
4986     else {
4987         binop->op_private = (U8)(2 | (flags >> 8));
4988         OpMORESIB_set(first, last);
4989     }
4990
4991     if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
4992         OpLASTSIB_set(last, (OP*)binop);
4993
4994     binop->op_last = OpSIBLING(binop->op_first);
4995     if (binop->op_last)
4996         OpLASTSIB_set(binop->op_last, (OP*)binop);
4997
4998     binop = (BINOP*)CHECKOP(type, binop);
4999     if (binop->op_next || binop->op_type != (OPCODE)type)
5000         return (OP*)binop;
5001
5002     return fold_constants(op_integerize(op_std_init((OP *)binop)));
5003 }
5004
5005 static int uvcompare(const void *a, const void *b)
5006     __attribute__nonnull__(1)
5007     __attribute__nonnull__(2)
5008     __attribute__pure__;
5009 static int uvcompare(const void *a, const void *b)
5010 {
5011     if (*((const UV *)a) < (*(const UV *)b))
5012         return -1;
5013     if (*((const UV *)a) > (*(const UV *)b))
5014         return 1;
5015     if (*((const UV *)a+1) < (*(const UV *)b+1))
5016         return -1;
5017     if (*((const UV *)a+1) > (*(const UV *)b+1))
5018         return 1;
5019     return 0;
5020 }
5021
5022 static OP *
5023 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
5024 {
5025     SV * const tstr = ((SVOP*)expr)->op_sv;
5026     SV * const rstr =
5027                               ((SVOP*)repl)->op_sv;
5028     STRLEN tlen;
5029     STRLEN rlen;
5030     const U8 *t = (U8*)SvPV_const(tstr, tlen);
5031     const U8 *r = (U8*)SvPV_const(rstr, rlen);
5032     I32 i;
5033     I32 j;
5034     I32 grows = 0;
5035     short *tbl;
5036
5037     const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
5038     const I32 squash     = o->op_private & OPpTRANS_SQUASH;
5039     I32 del              = o->op_private & OPpTRANS_DELETE;
5040     SV* swash;
5041
5042     PERL_ARGS_ASSERT_PMTRANS;
5043
5044     PL_hints |= HINT_BLOCK_SCOPE;
5045
5046     if (SvUTF8(tstr))
5047         o->op_private |= OPpTRANS_FROM_UTF;
5048
5049     if (SvUTF8(rstr))
5050         o->op_private |= OPpTRANS_TO_UTF;
5051
5052     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
5053         SV* const listsv = newSVpvs("# comment\n");
5054         SV* transv = NULL;
5055         const U8* tend = t + tlen;
5056         const U8* rend = r + rlen;
5057         STRLEN ulen;
5058         UV tfirst = 1;
5059         UV tlast = 0;
5060         IV tdiff;
5061         STRLEN tcount = 0;
5062         UV rfirst = 1;
5063         UV rlast = 0;
5064         IV rdiff;
5065         STRLEN rcount = 0;
5066         IV diff;
5067         I32 none = 0;
5068         U32 max = 0;
5069         I32 bits;
5070         I32 havefinal = 0;
5071         U32 final = 0;
5072         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
5073         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
5074         U8* tsave = NULL;
5075         U8* rsave = NULL;
5076         const U32 flags = UTF8_ALLOW_DEFAULT;
5077
5078         if (!from_utf) {
5079             STRLEN len = tlen;
5080             t = tsave = bytes_to_utf8(t, &len);
5081             tend = t + len;
5082         }
5083         if (!to_utf && rlen) {
5084             STRLEN len = rlen;
5085             r = rsave = bytes_to_utf8(r, &len);
5086             rend = r + len;
5087         }
5088
5089 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
5090  * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
5091  * odd.  */
5092
5093         if (complement) {
5094             U8 tmpbuf[UTF8_MAXBYTES+1];
5095             UV *cp;
5096             UV nextmin = 0;
5097             Newx(cp, 2*tlen, UV);
5098             i = 0;
5099             transv = newSVpvs("");
5100             while (t < tend) {
5101                 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
5102                 t += ulen;
5103                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
5104                     t++;
5105                     cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
5106                     t += ulen;
5107                 }
5108                 else {
5109                  cp[2*i+1] = cp[2*i];
5110                 }
5111                 i++;
5112             }
5113             qsort(cp, i, 2*sizeof(UV), uvcompare);
5114             for (j = 0; j < i; j++) {
5115                 UV  val = cp[2*j];
5116                 diff = val - nextmin;
5117                 if (diff > 0) {
5118                     t = uvchr_to_utf8(tmpbuf,nextmin);
5119                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5120                     if (diff > 1) {
5121                         U8  range_mark = ILLEGAL_UTF8_BYTE;
5122                         t = uvchr_to_utf8(tmpbuf, val - 1);
5123                         sv_catpvn(transv, (char *)&range_mark, 1);
5124                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5125                     }
5126                 }
5127                 val = cp[2*j+1];
5128                 if (val >= nextmin)
5129                     nextmin = val + 1;
5130             }
5131             t = uvchr_to_utf8(tmpbuf,nextmin);
5132             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5133             {
5134                 U8 range_mark = ILLEGAL_UTF8_BYTE;
5135                 sv_catpvn(transv, (char *)&range_mark, 1);
5136             }
5137             t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
5138             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5139             t = (const U8*)SvPVX_const(transv);
5140             tlen = SvCUR(transv);
5141             tend = t + tlen;
5142             Safefree(cp);
5143         }
5144         else if (!rlen && !del) {
5145             r = t; rlen = tlen; rend = tend;
5146         }
5147         if (!squash) {
5148                 if ((!rlen && !del) || t == r ||
5149                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
5150                 {
5151                     o->op_private |= OPpTRANS_IDENTICAL;
5152                 }
5153         }
5154
5155         while (t < tend || tfirst <= tlast) {
5156             /* see if we need more "t" chars */
5157             if (tfirst > tlast) {
5158                 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
5159                 t += ulen;
5160                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {      /* illegal utf8 val indicates range */
5161                     t++;
5162                     tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
5163                     t += ulen;
5164                 }
5165                 else
5166                     tlast = tfirst;
5167             }
5168
5169             /* now see if we need more "r" chars */
5170             if (rfirst > rlast) {
5171                 if (r < rend) {
5172                     rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
5173                     r += ulen;
5174                     if (r < rend && *r == ILLEGAL_UTF8_BYTE) {  /* illegal utf8 val indicates range */
5175                         r++;
5176                         rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
5177                         r += ulen;
5178                     }
5179                     else
5180                         rlast = rfirst;
5181                 }
5182                 else {
5183                     if (!havefinal++)
5184                         final = rlast;
5185                     rfirst = rlast = 0xffffffff;
5186                 }
5187             }
5188
5189             /* now see which range will peter out first, if either. */
5190             tdiff = tlast - tfirst;
5191             rdiff = rlast - rfirst;
5192             tcount += tdiff + 1;
5193             rcount += rdiff + 1;
5194
5195             if (tdiff <= rdiff)
5196                 diff = tdiff;
5197             else
5198                 diff = rdiff;
5199
5200             if (rfirst == 0xffffffff) {
5201                 diff = tdiff;   /* oops, pretend rdiff is infinite */
5202                 if (diff > 0)
5203                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
5204                                    (long)tfirst, (long)tlast);
5205                 else
5206                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
5207             }
5208             else {
5209                 if (diff > 0)
5210                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
5211                                    (long)tfirst, (long)(tfirst + diff),
5212                                    (long)rfirst);
5213                 else
5214                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
5215                                    (long)tfirst, (long)rfirst);
5216
5217                 if (rfirst + diff > max)
5218                     max = rfirst + diff;
5219                 if (!grows)
5220                     grows = (tfirst < rfirst &&
5221                              UVCHR_SKIP(tfirst) < UVCHR_SKIP(rfirst + diff));
5222                 rfirst += diff + 1;
5223             }
5224             tfirst += diff + 1;
5225         }
5226
5227         none = ++max;
5228         if (del)
5229             del = ++max;
5230
5231         if (max > 0xffff)
5232             bits = 32;
5233         else if (max > 0xff)
5234             bits = 16;
5235         else
5236             bits = 8;
5237
5238         swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
5239 #ifdef USE_ITHREADS
5240         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
5241         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
5242         PAD_SETSV(cPADOPo->op_padix, swash);
5243         SvPADTMP_on(swash);
5244         SvREADONLY_on(swash);
5245 #else
5246         cSVOPo->op_sv = swash;
5247 #endif
5248         SvREFCNT_dec(listsv);
5249         SvREFCNT_dec(transv);
5250
5251         if (!del && havefinal && rlen)
5252             (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
5253                            newSVuv((UV)final), 0);
5254
5255         Safefree(tsave);
5256         Safefree(rsave);
5257
5258         tlen = tcount;
5259         rlen = rcount;
5260         if (r < rend)
5261             rlen++;
5262         else if (rlast == 0xffffffff)
5263             rlen = 0;
5264
5265         goto warnins;
5266     }
5267
5268     tbl = (short*)PerlMemShared_calloc(
5269         (o->op_private & OPpTRANS_COMPLEMENT) &&
5270             !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
5271         sizeof(short));
5272     cPVOPo->op_pv = (char*)tbl;
5273     if (complement) {
5274         for (i = 0; i < (I32)tlen; i++)
5275             tbl[t[i]] = -1;
5276         for (i = 0, j = 0; i < 256; i++) {
5277             if (!tbl[i]) {
5278                 if (j >= (I32)rlen) {
5279                     if (del)
5280                         tbl[i] = -2;
5281                     else if (rlen)
5282                         tbl[i] = r[j-1];
5283                     else
5284                         tbl[i] = (short)i;
5285                 }
5286                 else {
5287                     if (i < 128 && r[j] >= 128)
5288                         grows = 1;
5289                     tbl[i] = r[j++];
5290                 }
5291             }
5292         }
5293         if (!del) {
5294             if (!rlen) {
5295                 j = rlen;
5296                 if (!squash)
5297                     o->op_private |= OPpTRANS_IDENTICAL;
5298             }
5299             else if (j >= (I32)rlen)
5300                 j = rlen - 1;
5301             else {
5302                 tbl =
5303                     (short *)
5304                     PerlMemShared_realloc(tbl,
5305                                           (0x101+rlen-j) * sizeof(short));
5306                 cPVOPo->op_pv = (char*)tbl;
5307             }
5308             tbl[0x100] = (short)(rlen - j);
5309             for (i=0; i < (I32)rlen - j; i++)
5310                 tbl[0x101+i] = r[j+i];
5311         }
5312     }
5313     else {
5314         if (!rlen && !del) {
5315             r = t; rlen = tlen;
5316             if (!squash)
5317                 o->op_private |= OPpTRANS_IDENTICAL;
5318         }
5319         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
5320             o->op_private |= OPpTRANS_IDENTICAL;
5321         }
5322         for (i = 0; i < 256; i++)
5323             tbl[i] = -1;
5324         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
5325             if (j >= (I32)rlen) {
5326                 if (del) {
5327                     if (tbl[t[i]] == -1)
5328                         tbl[t[i]] = -2;
5329                     continue;
5330                 }
5331                 --j;
5332             }
5333             if (tbl[t[i]] == -1) {
5334                 if (t[i] < 128 && r[j] >= 128)
5335                     grows = 1;
5336                 tbl[t[i]] = r[j];
5337             }
5338         }
5339     }
5340
5341   warnins:
5342     if(del && rlen == tlen) {
5343         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
5344     } else if(rlen > tlen && !complement) {
5345         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
5346     }
5347
5348     if (grows)
5349         o->op_private |= OPpTRANS_GROWS;
5350     op_free(expr);
5351     op_free(repl);
5352
5353     return o;
5354 }
5355
5356 /*
5357 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
5358
5359 Constructs, checks, and returns an op of any pattern matching type.
5360 C<type> is the opcode.  C<flags> gives the eight bits of C<op_flags>
5361 and, shifted up eight bits, the eight bits of C<op_private>.
5362
5363 =cut
5364 */
5365
5366 OP *
5367 Perl_newPMOP(pTHX_ I32 type, I32 flags)
5368 {
5369     dVAR;
5370     PMOP *pmop;
5371
5372     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
5373         || type == OP_CUSTOM);
5374
5375     NewOp(1101, pmop, 1, PMOP);
5376     OpTYPE_set(pmop, type);
5377     pmop->op_flags = (U8)flags;
5378     pmop->op_private = (U8)(0 | (flags >> 8));
5379     if (PL_opargs[type] & OA_RETSCALAR)
5380         scalar((OP *)pmop);
5381
5382     if (PL_hints & HINT_RE_TAINT)
5383         pmop->op_pmflags |= PMf_RETAINT;
5384 #ifdef USE_LOCALE_CTYPE
5385     if (IN_LC_COMPILETIME(LC_CTYPE)) {
5386         set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
5387     }
5388     else
5389 #endif
5390          if (IN_UNI_8_BIT) {
5391         set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
5392     }
5393     if (PL_hints & HINT_RE_FLAGS) {
5394         SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5395          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
5396         );
5397         if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
5398         reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5399          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
5400         );
5401         if (reflags && SvOK(reflags)) {
5402             set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
5403         }
5404     }
5405
5406
5407 #ifdef USE_ITHREADS
5408     assert(SvPOK(PL_regex_pad[0]));
5409     if (SvCUR(PL_regex_pad[0])) {
5410         /* Pop off the "packed" IV from the end.  */
5411         SV *const repointer_list = PL_regex_pad[0];
5412         const char *p = SvEND(repointer_list) - sizeof(IV);
5413         const IV offset = *((IV*)p);
5414
5415         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
5416
5417         SvEND_set(repointer_list, p);
5418
5419         pmop->op_pmoffset = offset;
5420         /* This slot should be free, so assert this:  */
5421         assert(PL_regex_pad[offset] == &PL_sv_undef);
5422     } else {
5423         SV * const repointer = &PL_sv_undef;
5424         av_push(PL_regex_padav, repointer);
5425         pmop->op_pmoffset = av_tindex(PL_regex_padav);
5426         PL_regex_pad = AvARRAY(PL_regex_padav);
5427     }
5428 #endif
5429
5430     return CHECKOP(type, pmop);
5431 }
5432
5433 static void
5434 S_set_haseval(pTHX)
5435 {
5436     PADOFFSET i = 1;
5437     PL_cv_has_eval = 1;
5438     /* Any pad names in scope are potentially lvalues.  */
5439     for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
5440         PADNAME *pn = PAD_COMPNAME_SV(i);
5441         if (!pn || !PadnameLEN(pn))
5442             continue;
5443         if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
5444             S_mark_padname_lvalue(aTHX_ pn);
5445     }
5446 }
5447
5448 /* Given some sort of match op o, and an expression expr containing a
5449  * pattern, either compile expr into a regex and attach it to o (if it's
5450  * constant), or convert expr into a runtime regcomp op sequence (if it's
5451  * not)
5452  *
5453  * isreg indicates that the pattern is part of a regex construct, eg
5454  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
5455  * split "pattern", which aren't. In the former case, expr will be a list
5456  * if the pattern contains more than one term (eg /a$b/).
5457  *
5458  * When the pattern has been compiled within a new anon CV (for
5459  * qr/(?{...})/ ), then floor indicates the savestack level just before
5460  * the new sub was created
5461  */
5462
5463 OP *
5464 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, bool isreg, I32 floor)
5465 {
5466     PMOP *pm;
5467     LOGOP *rcop;
5468     I32 repl_has_vars = 0;
5469     bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
5470     bool is_compiletime;
5471     bool has_code;
5472
5473     PERL_ARGS_ASSERT_PMRUNTIME;
5474
5475     if (is_trans) {
5476         return pmtrans(o, expr, repl);
5477     }
5478
5479     /* find whether we have any runtime or code elements;
5480      * at the same time, temporarily set the op_next of each DO block;
5481      * then when we LINKLIST, this will cause the DO blocks to be excluded
5482      * from the op_next chain (and from having LINKLIST recursively
5483      * applied to them). We fix up the DOs specially later */
5484
5485     is_compiletime = 1;
5486     has_code = 0;
5487     if (expr->op_type == OP_LIST) {
5488         OP *o;
5489         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
5490             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
5491                 has_code = 1;
5492                 assert(!o->op_next);
5493                 if (UNLIKELY(!OpHAS_SIBLING(o))) {
5494                     assert(PL_parser && PL_parser->error_count);
5495                     /* This can happen with qr/ (?{(^{})/.  Just fake up
5496                        the op we were expecting to see, to avoid crashing
5497                        elsewhere.  */
5498                     op_sibling_splice(expr, o, 0,
5499                                       newSVOP(OP_CONST, 0, &PL_sv_no));
5500                 }
5501                 o->op_next = OpSIBLING(o);
5502             }
5503             else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
5504                 is_compiletime = 0;
5505         }
5506     }
5507     else if (expr->op_type != OP_CONST)
5508         is_compiletime = 0;
5509
5510     LINKLIST(expr);
5511
5512     /* fix up DO blocks; treat each one as a separate little sub;
5513      * also, mark any arrays as LIST/REF */
5514
5515     if (expr->op_type == OP_LIST) {
5516         OP *o;
5517         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
5518
5519             if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
5520                 assert( !(o->op_flags  & OPf_WANT));
5521                 /* push the array rather than its contents. The regex
5522                  * engine will retrieve and join the elements later */
5523                 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
5524                 continue;
5525             }
5526
5527             if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
5528                 continue;
5529             o->op_next = NULL; /* undo temporary hack from above */
5530             scalar(o);
5531             LINKLIST(o);
5532             if (cLISTOPo->op_first->op_type == OP_LEAVE) {
5533                 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
5534                 /* skip ENTER */
5535                 assert(leaveop->op_first->op_type == OP_ENTER);
5536                 assert(OpHAS_SIBLING(leaveop->op_first));
5537                 o->op_next = OpSIBLING(leaveop->op_first);
5538                 /* skip leave */
5539                 assert(leaveop->op_flags & OPf_KIDS);
5540                 assert(leaveop->op_last->op_next == (OP*)leaveop);
5541                 leaveop->op_next = NULL; /* stop on last op */
5542                 op_null((OP*)leaveop);
5543             }
5544             else {
5545                 /* skip SCOPE */
5546                 OP *scope = cLISTOPo->op_first;
5547                 assert(scope->op_type == OP_SCOPE);
5548                 assert(scope->op_flags & OPf_KIDS);
5549                 scope->op_next = NULL; /* stop on last op */
5550                 op_null(scope);
5551             }
5552             /* have to peep the DOs individually as we've removed it from
5553              * the op_next chain */
5554             CALL_PEEP(o);
5555             S_prune_chain_head(&(o->op_next));
5556             if (is_compiletime)
5557                 /* runtime finalizes as part of finalizing whole tree */
5558                 finalize_optree(o);
5559         }
5560     }
5561     else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
5562         assert( !(expr->op_flags  & OPf_WANT));
5563         /* push the array rather than its contents. The regex
5564          * engine will retrieve and join the elements later */
5565         expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
5566     }
5567
5568     PL_hints |= HINT_BLOCK_SCOPE;
5569     pm = (PMOP*)o;
5570     assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
5571
5572     if (is_compiletime) {
5573         U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
5574         regexp_engine const *eng = current_re_engine();
5575
5576         if (o->op_flags & OPf_SPECIAL)
5577             rx_flags |= RXf_SPLIT;
5578
5579         if (!has_code || !eng->op_comp) {
5580             /* compile-time simple constant pattern */
5581
5582             if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
5583                 /* whoops! we guessed that a qr// had a code block, but we
5584                  * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
5585                  * that isn't required now. Note that we have to be pretty
5586                  * confident that nothing used that CV's pad while the
5587                  * regex was parsed, except maybe op targets for \Q etc.
5588                  * If there were any op targets, though, they should have
5589                  * been stolen by constant folding.
5590                  */
5591 #ifdef DEBUGGING
5592                 SSize_t i = 0;
5593                 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
5594                 while (++i <= AvFILLp(PL_comppad)) {
5595                     assert(!PL_curpad[i]);
5596                 }
5597 #endif
5598                 /* But we know that one op is using this CV's slab. */
5599                 cv_forget_slab(PL_compcv);
5600                 LEAVE_SCOPE(floor);
5601                 pm->op_pmflags &= ~PMf_HAS_CV;
5602             }
5603
5604             PM_SETRE(pm,
5605                 eng->op_comp
5606                     ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5607                                         rx_flags, pm->op_pmflags)
5608                     : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5609                                         rx_flags, pm->op_pmflags)
5610             );
5611             op_free(expr);
5612         }
5613         else {
5614             /* compile-time pattern that includes literal code blocks */
5615             REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5616                         rx_flags,
5617                         (pm->op_pmflags |
5618                             ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
5619                     );
5620             PM_SETRE(pm, re);
5621             if (pm->op_pmflags & PMf_HAS_CV) {
5622                 CV *cv;
5623                 /* this QR op (and the anon sub we embed it in) is never
5624                  * actually executed. It's just a placeholder where we can
5625                  * squirrel away expr in op_code_list without the peephole
5626                  * optimiser etc processing it for a second time */
5627                 OP *qr = newPMOP(OP_QR, 0);
5628                 ((PMOP*)qr)->op_code_list = expr;
5629
5630                 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
5631                 SvREFCNT_inc_simple_void(PL_compcv);
5632                 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
5633                 ReANY(re)->qr_anoncv = cv;
5634
5635                 /* attach the anon CV to the pad so that
5636                  * pad_fixup_inner_anons() can find it */
5637                 (void)pad_add_anon(cv, o->op_type);
5638                 SvREFCNT_inc_simple_void(cv);
5639             }
5640             else {
5641                 pm->op_code_list = expr;
5642             }
5643         }
5644     }
5645     else {
5646         /* runtime pattern: build chain of regcomp etc ops */
5647         bool reglist;
5648         PADOFFSET cv_targ = 0;
5649
5650         reglist = isreg && expr->op_type == OP_LIST;
5651         if (reglist)
5652             op_null(expr);
5653
5654         if (has_code) {
5655             pm->op_code_list = expr;
5656             /* don't free op_code_list; its ops are embedded elsewhere too */
5657             pm->op_pmflags |= PMf_CODELIST_PRIVATE;
5658         }
5659
5660         if (o->op_flags & OPf_SPECIAL)
5661             pm->op_pmflags |= PMf_SPLIT;
5662
5663         /* the OP_REGCMAYBE is a placeholder in the non-threaded case
5664          * to allow its op_next to be pointed past the regcomp and
5665          * preceding stacking ops;
5666          * OP_REGCRESET is there to reset taint before executing the
5667          * stacking ops */
5668         if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
5669             expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
5670
5671         if (pm->op_pmflags & PMf_HAS_CV) {
5672             /* we have a runtime qr with literal code. This means
5673              * that the qr// has been wrapped in a new CV, which
5674              * means that runtime consts, vars etc will have been compiled
5675              * against a new pad. So... we need to execute those ops
5676              * within the environment of the new CV. So wrap them in a call
5677              * to a new anon sub. i.e. for
5678              *
5679              *     qr/a$b(?{...})/,
5680              *
5681              * we build an anon sub that looks like
5682              *
5683              *     sub { "a", $b, '(?{...})' }
5684              *
5685              * and call it, passing the returned list to regcomp.
5686              * Or to put it another way, the list of ops that get executed
5687              * are:
5688              *
5689              *     normal              PMf_HAS_CV
5690              *     ------              -------------------
5691              *                         pushmark (for regcomp)
5692              *                         pushmark (for entersub)
5693              *                         anoncode
5694              *                         srefgen
5695              *                         entersub
5696              *     regcreset                  regcreset
5697              *     pushmark                   pushmark
5698              *     const("a")                 const("a")
5699              *     gvsv(b)                    gvsv(b)
5700              *     const("(?{...})")          const("(?{...})")
5701              *                                leavesub
5702              *     regcomp             regcomp
5703              */
5704
5705             SvREFCNT_inc_simple_void(PL_compcv);
5706             CvLVALUE_on(PL_compcv);
5707             /* these lines are just an unrolled newANONATTRSUB */
5708             expr = newSVOP(OP_ANONCODE, 0,
5709                     MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
5710             cv_targ = expr->op_targ;
5711             expr = newUNOP(OP_REFGEN, 0, expr);
5712
5713             expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
5714         }
5715
5716         rcop = S_alloc_LOGOP(aTHX_ OP_REGCOMP, scalar(expr), o);
5717         rcop->op_flags |=  ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
5718                            | (reglist ? OPf_STACKED : 0);
5719         rcop->op_targ = cv_targ;
5720
5721         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
5722         if (PL_hints & HINT_RE_EVAL)
5723             S_set_haseval(aTHX);
5724
5725         /* establish postfix order */
5726         if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
5727             LINKLIST(expr);
5728             rcop->op_next = expr;
5729             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
5730         }
5731         else {
5732             rcop->op_next = LINKLIST(expr);
5733             expr->op_next = (OP*)rcop;
5734         }
5735
5736         op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
5737     }
5738
5739     if (repl) {
5740         OP *curop = repl;
5741         bool konst;
5742         /* If we are looking at s//.../e with a single statement, get past
5743            the implicit do{}. */
5744         if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
5745              && cUNOPx(curop)->op_first->op_type == OP_SCOPE
5746              && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
5747          {
5748             OP *sib;
5749             OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
5750             if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
5751              && !OpHAS_SIBLING(sib))
5752                 curop = sib;
5753         }
5754         if (curop->op_type == OP_CONST)
5755             konst = TRUE;
5756         else if (( (curop->op_type == OP_RV2SV ||
5757                     curop->op_type == OP_RV2AV ||
5758                     curop->op_type == OP_RV2HV ||
5759                     curop->op_type == OP_RV2GV)
5760                    && cUNOPx(curop)->op_first
5761                    && cUNOPx(curop)->op_first->op_type == OP_GV )
5762                 || curop->op_type == OP_PADSV
5763                 || curop->op_type == OP_PADAV
5764                 || curop->op_type == OP_PADHV
5765                 || curop->op_type == OP_PADANY) {
5766             repl_has_vars = 1;
5767             konst = TRUE;
5768         }
5769         else konst = FALSE;
5770         if (konst
5771             && !(repl_has_vars
5772                  && (!PM_GETRE(pm)
5773                      || !RX_PRELEN(PM_GETRE(pm))
5774                      || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
5775         {
5776             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
5777             op_prepend_elem(o->op_type, scalar(repl), o);
5778         }
5779         else {
5780             rcop = S_alloc_LOGOP(aTHX_ OP_SUBSTCONT, scalar(repl), o);
5781             rcop->op_private = 1;
5782
5783             /* establish postfix order */
5784             rcop->op_next = LINKLIST(repl);
5785             repl->op_next = (OP*)rcop;
5786
5787             pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
5788             assert(!(pm->op_pmflags & PMf_ONCE));
5789             pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
5790             rcop->op_next = 0;
5791         }
5792     }
5793
5794     return (OP*)pm;
5795 }
5796
5797 /*
5798 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
5799
5800 Constructs, checks, and returns an op of any type that involves an
5801 embedded SV.  C<type> is the opcode.  C<flags> gives the eight bits
5802 of C<op_flags>.  C<sv> gives the SV to embed in the op; this function
5803 takes ownership of one reference to it.
5804
5805 =cut
5806 */
5807
5808 OP *
5809 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
5810 {
5811     dVAR;
5812     SVOP *svop;
5813
5814     PERL_ARGS_ASSERT_NEWSVOP;
5815
5816     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5817         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5818         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5819         || type == OP_CUSTOM);
5820
5821     NewOp(1101, svop, 1, SVOP);
5822     OpTYPE_set(svop, type);
5823     svop->op_sv = sv;
5824     svop->op_next = (OP*)svop;
5825     svop->op_flags = (U8)flags;
5826     svop->op_private = (U8)(0 | (flags >> 8));
5827     if (PL_opargs[type] & OA_RETSCALAR)
5828         scalar((OP*)svop);
5829     if (PL_opargs[type] & OA_TARGET)
5830         svop->op_targ = pad_alloc(type, SVs_PADTMP);
5831     return CHECKOP(type, svop);
5832 }
5833
5834 /*
5835 =for apidoc Am|OP *|newDEFSVOP|
5836
5837 Constructs and returns an op to access C<$_>.
5838
5839 =cut
5840 */
5841
5842 OP *
5843 Perl_newDEFSVOP(pTHX)
5844 {
5845         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
5846 }
5847
5848 #ifdef USE_ITHREADS
5849
5850 /*
5851 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
5852
5853 Constructs, checks, and returns an op of any type that involves a
5854 reference to a pad element.  C<type> is the opcode.  C<flags> gives the
5855 eight bits of C<op_flags>.  A pad slot is automatically allocated, and
5856 is populated with C<sv>; this function takes ownership of one reference
5857 to it.
5858
5859 This function only exists if Perl has been compiled to use ithreads.
5860
5861 =cut
5862 */
5863
5864 OP *
5865 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
5866 {
5867     dVAR;
5868     PADOP *padop;
5869
5870     PERL_ARGS_ASSERT_NEWPADOP;
5871
5872     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5873         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5874         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5875         || type == OP_CUSTOM);
5876
5877     NewOp(1101, padop, 1, PADOP);
5878     OpTYPE_set(padop, type);
5879     padop->op_padix =
5880         pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
5881     SvREFCNT_dec(PAD_SVl(padop->op_padix));
5882     PAD_SETSV(padop->op_padix, sv);
5883     assert(sv);
5884     padop->op_next = (OP*)padop;
5885     padop->op_flags = (U8)flags;
5886     if (PL_opargs[type] & OA_RETSCALAR)
5887         scalar((OP*)padop);
5888     if (PL_opargs[type] & OA_TARGET)
5889         padop->op_targ = pad_alloc(type, SVs_PADTMP);
5890     return CHECKOP(type, padop);
5891 }
5892
5893 #endif /* USE_ITHREADS */
5894
5895 /*
5896 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
5897
5898 Constructs, checks, and returns an op of any type that involves an
5899 embedded reference to a GV.  C<type> is the opcode.  C<flags> gives the
5900 eight bits of C<op_flags>.  C<gv> identifies the GV that the op should
5901 reference; calling this function does not transfer ownership of any
5902 reference to it.
5903
5904 =cut
5905 */
5906
5907 OP *
5908 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
5909 {
5910     PERL_ARGS_ASSERT_NEWGVOP;
5911
5912 #ifdef USE_ITHREADS
5913     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5914 #else
5915     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5916 #endif
5917 }
5918
5919 /*
5920 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
5921
5922 Constructs, checks, and returns an op of any type that involves an
5923 embedded C-level pointer (PV).  C<type> is the opcode.  C<flags> gives
5924 the eight bits of C<op_flags>.  C<pv> supplies the C-level pointer, which
5925 must have been allocated using C<PerlMemShared_malloc>; the memory will
5926 be freed when the op is destroyed.
5927
5928 =cut
5929 */
5930
5931 OP *
5932 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
5933 {
5934     dVAR;
5935     const bool utf8 = cBOOL(flags & SVf_UTF8);
5936     PVOP *pvop;
5937
5938     flags &= ~SVf_UTF8;
5939
5940     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5941         || type == OP_RUNCV || type == OP_CUSTOM
5942         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5943
5944     NewOp(1101, pvop, 1, PVOP);
5945     OpTYPE_set(pvop, type);
5946     pvop->op_pv = pv;
5947     pvop->op_next = (OP*)pvop;
5948     pvop->op_flags = (U8)flags;
5949     pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
5950     if (PL_opargs[type] & OA_RETSCALAR)
5951         scalar((OP*)pvop);
5952     if (PL_opargs[type] & OA_TARGET)
5953         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
5954     return CHECKOP(type, pvop);
5955 }
5956
5957 void
5958 Perl_package(pTHX_ OP *o)
5959 {
5960     SV *const sv = cSVOPo->op_sv;
5961
5962     PERL_ARGS_ASSERT_PACKAGE;
5963
5964     SAVEGENERICSV(PL_curstash);
5965     save_item(PL_curstname);
5966
5967     PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
5968
5969     sv_setsv(PL_curstname, sv);
5970
5971     PL_hints |= HINT_BLOCK_SCOPE;
5972     PL_parser->copline = NOLINE;
5973
5974     op_free(o);
5975 }
5976
5977 void
5978 Perl_package_version( pTHX_ OP *v )
5979 {
5980     U32 savehints = PL_hints;
5981     PERL_ARGS_ASSERT_PACKAGE_VERSION;
5982     PL_hints &= ~HINT_STRICT_VARS;
5983     sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
5984     PL_hints = savehints;
5985     op_free(v);
5986 }
5987
5988 void
5989 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
5990 {
5991     OP *pack;
5992     OP *imop;
5993     OP *veop;
5994     SV *use_version = NULL;
5995
5996     PERL_ARGS_ASSERT_UTILIZE;
5997
5998     if (idop->op_type != OP_CONST)
5999         Perl_croak(aTHX_ "Module name must be constant");
6000
6001     veop = NULL;
6002
6003     if (version) {
6004         SV * const vesv = ((SVOP*)version)->op_sv;
6005
6006         if (!arg && !SvNIOKp(vesv)) {
6007             arg = version;
6008         }
6009         else {
6010             OP *pack;
6011             SV *meth;
6012
6013             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
6014                 Perl_croak(aTHX_ "Version number must be a constant number");
6015
6016             /* Make copy of idop so we don't free it twice */
6017             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
6018
6019             /* Fake up a method call to VERSION */
6020             meth = newSVpvs_share("VERSION");
6021             veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
6022                             op_append_elem(OP_LIST,
6023                                         op_prepend_elem(OP_LIST, pack, version),
6024                                         newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
6025         }
6026     }
6027
6028     /* Fake up an import/unimport */
6029     if (arg && arg->op_type == OP_STUB) {
6030         imop = arg;             /* no import on explicit () */
6031     }
6032     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
6033         imop = NULL;            /* use 5.0; */
6034         if (aver)
6035             use_version = ((SVOP*)idop)->op_sv;
6036         else
6037             idop->op_private |= OPpCONST_NOVER;
6038     }
6039     else {
6040         SV *meth;
6041
6042         /* Make copy of idop so we don't free it twice */
6043         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
6044
6045         /* Fake up a method call to import/unimport */
6046         meth = aver
6047             ? newSVpvs_share("import") : newSVpvs_share("unimport");
6048         imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
6049                        op_append_elem(OP_LIST,
6050                                    op_prepend_elem(OP_LIST, pack, arg),
6051                                    newMETHOP_named(OP_METHOD_NAMED, 0, meth)
6052                        ));
6053     }
6054
6055     /* Fake up the BEGIN {}, which does its thing immediately. */
6056     newATTRSUB(floor,
6057         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
6058         NULL,
6059         NULL,
6060         op_append_elem(OP_LINESEQ,
6061             op_append_elem(OP_LINESEQ,
6062                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
6063                 newSTATEOP(0, NULL, veop)),
6064             newSTATEOP(0, NULL, imop) ));
6065
6066     if (use_version) {
6067         /* Enable the
6068          * feature bundle that corresponds to the required version. */
6069         use_version = sv_2mortal(new_version(use_version));
6070         S_enable_feature_bundle(aTHX_ use_version);
6071
6072         /* If a version >= 5.11.0 is requested, strictures are on by default! */
6073         if (vcmp(use_version,
6074                  sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
6075             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
6076                 PL_hints |= HINT_STRICT_REFS;
6077             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
6078                 PL_hints |= HINT_STRICT_SUBS;
6079             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
6080                 PL_hints |= HINT_STRICT_VARS;
6081         }
6082         /* otherwise they are off */
6083         else {
6084             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
6085                 PL_hints &= ~HINT_STRICT_REFS;
6086             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
6087                 PL_hints &= ~HINT_STRICT_SUBS;
6088             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
6089                 PL_hints &= ~HINT_STRICT_VARS;
6090         }
6091     }
6092
6093     /* The "did you use incorrect case?" warning used to be here.
6094      * The problem is that on case-insensitive filesystems one
6095      * might get false positives for "use" (and "require"):
6096      * "use Strict" or "require CARP" will work.  This causes
6097      * portability problems for the script: in case-strict
6098      * filesystems the script will stop working.
6099      *
6100      * The "incorrect case" warning checked whether "use Foo"
6101      * imported "Foo" to your namespace, but that is wrong, too:
6102      * there is no requirement nor promise in the language that
6103      * a Foo.pm should or would contain anything in package "Foo".
6104      *
6105      * There is very little Configure-wise that can be done, either:
6106      * the case-sensitivity of the build filesystem of Perl does not
6107      * help in guessing the case-sensitivity of the runtime environment.
6108      */
6109
6110     PL_hints |= HINT_BLOCK_SCOPE;
6111     PL_parser->copline = NOLINE;
6112     COP_SEQMAX_INC; /* Purely for B::*'s benefit */
6113 }
6114
6115 /*
6116 =head1 Embedding Functions
6117
6118 =for apidoc load_module
6119
6120 Loads the module whose name is pointed to by the string part of name.
6121 Note that the actual module name, not its filename, should be given.
6122 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
6123 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
6124 (or 0 for no flags).  ver, if specified
6125 and not NULL, provides version semantics
6126 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
6127 arguments can be used to specify arguments to the module's C<import()>
6128 method, similar to C<use Foo::Bar VERSION LIST>.  They must be
6129 terminated with a final C<NULL> pointer.  Note that this list can only
6130 be omitted when the C<PERL_LOADMOD_NOIMPORT> flag has been used.
6131 Otherwise at least a single C<NULL> pointer to designate the default
6132 import list is required.
6133
6134 The reference count for each specified C<SV*> parameter is decremented.
6135
6136 =cut */
6137
6138 void
6139 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
6140 {
6141     va_list args;
6142
6143     PERL_ARGS_ASSERT_LOAD_MODULE;
6144
6145     va_start(args, ver);
6146     vload_module(flags, name, ver, &args);
6147     va_end(args);
6148 }
6149
6150 #ifdef PERL_IMPLICIT_CONTEXT
6151 void
6152 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
6153 {
6154     dTHX;
6155     va_list args;
6156     PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
6157     va_start(args, ver);
6158     vload_module(flags, name, ver, &args);
6159     va_end(args);
6160 }
6161 #endif
6162
6163 void
6164 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
6165 {
6166     OP *veop, *imop;
6167     OP * const modname = newSVOP(OP_CONST, 0, name);
6168
6169     PERL_ARGS_ASSERT_VLOAD_MODULE;
6170
6171     modname->op_private |= OPpCONST_BARE;
6172     if (ver) {
6173         veop = newSVOP(OP_CONST, 0, ver);
6174     }
6175     else
6176         veop = NULL;
6177     if (flags & PERL_LOADMOD_NOIMPORT) {
6178         imop = sawparens(newNULLLIST());
6179     }
6180     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
6181         imop = va_arg(*args, OP*);
6182     }
6183     else {
6184         SV *sv;
6185         imop = NULL;
6186         sv = va_arg(*args, SV*);
6187         while (sv) {
6188             imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
6189             sv = va_arg(*args, SV*);
6190         }
6191     }
6192
6193     /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
6194      * that it has a PL_parser to play with while doing that, and also
6195      * that it doesn't mess with any existing parser, by creating a tmp
6196      * new parser with lex_start(). This won't actually be used for much,
6197      * since pp_require() will create another parser for the real work.
6198      * The ENTER/LEAVE pair protect callers from any side effects of use.  */
6199
6200     ENTER;
6201     SAVEVPTR(PL_curcop);
6202     lex_start(NULL, NULL, LEX_START_SAME_FILTER);
6203     utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
6204             veop, modname, imop);
6205     LEAVE;
6206 }
6207
6208 PERL_STATIC_INLINE OP *
6209 S_new_entersubop(pTHX_ GV *gv, OP *arg)
6210 {
6211     return newUNOP(OP_ENTERSUB, OPf_STACKED,
6212                    newLISTOP(OP_LIST, 0, arg,
6213                              newUNOP(OP_RV2CV, 0,
6214                                      newGVOP(OP_GV, 0, gv))));
6215 }
6216
6217 OP *
6218 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
6219 {
6220     OP *doop;
6221     GV *gv;
6222
6223     PERL_ARGS_ASSERT_DOFILE;
6224
6225     if (!force_builtin && (gv = gv_override("do", 2))) {
6226         doop = S_new_entersubop(aTHX_ gv, term);
6227     }
6228     else {
6229         doop = newUNOP(OP_DOFILE, 0, scalar(term));
6230     }
6231     return doop;
6232 }
6233
6234 /*
6235 =head1 Optree construction
6236
6237 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
6238
6239 Constructs, checks, and returns an C<lslice> (list slice) op.  C<flags>
6240 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
6241 be set automatically, and, shifted up eight bits, the eight bits of
6242 C<op_private>, except that the bit with value 1 or 2 is automatically
6243 set as required.  C<listval> and C<subscript> supply the parameters of
6244 the slice; they are consumed by this function and become part of the
6245 constructed op tree.
6246
6247 =cut
6248 */
6249
6250 OP *
6251 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
6252 {
6253     return newBINOP(OP_LSLICE, flags,
6254             list(force_list(subscript, 1)),
6255             list(force_list(listval,   1)) );
6256 }
6257
6258 #define ASSIGN_LIST   1
6259 #define ASSIGN_REF    2
6260
6261 STATIC I32
6262 S_assignment_type(pTHX_ const OP *o)
6263 {
6264     unsigned type;
6265     U8 flags;
6266     U8 ret;
6267
6268     if (!o)
6269         return TRUE;
6270
6271     if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
6272         o = cUNOPo->op_first;
6273
6274     flags = o->op_flags;
6275     type = o->op_type;
6276     if (type == OP_COND_EXPR) {
6277         OP * const sib = OpSIBLING(cLOGOPo->op_first);
6278         const I32 t = assignment_type(sib);
6279         const I32 f = assignment_type(OpSIBLING(sib));
6280
6281         if (t == ASSIGN_LIST && f == ASSIGN_LIST)
6282             return ASSIGN_LIST;
6283         if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
6284             yyerror("Assignment to both a list and a scalar");
6285         return FALSE;
6286     }
6287
6288     if (type == OP_SREFGEN)
6289     {
6290         OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
6291         type = kid->op_type;
6292         flags |= kid->op_flags;
6293         if (!(flags & OPf_PARENS)
6294           && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
6295               kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
6296             return ASSIGN_REF;
6297         ret = ASSIGN_REF;
6298     }
6299     else ret = 0;
6300
6301     if (type == OP_LIST &&
6302         (flags & OPf_WANT) == OPf_WANT_SCALAR &&
6303         o->op_private & OPpLVAL_INTRO)
6304         return ret;
6305
6306     if (type == OP_LIST || flags & OPf_PARENS ||
6307         type == OP_RV2AV || type == OP_RV2HV ||
6308         type == OP_ASLICE || type == OP_HSLICE ||
6309         type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
6310         return TRUE;
6311
6312     if (type == OP_PADAV || type == OP_PADHV)
6313         return TRUE;
6314
6315     if (type == OP_RV2SV)
6316         return ret;
6317
6318     return ret;
6319 }
6320
6321
6322 /*
6323 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
6324
6325 Constructs, checks, and returns an assignment op.  C<left> and C<right>
6326 supply the parameters of the assignment; they are consumed by this
6327 function and become part of the constructed op tree.
6328
6329 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
6330 a suitable conditional optree is constructed.  If C<optype> is the opcode
6331 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
6332 performs the binary operation and assigns the result to the left argument.
6333 Either way, if C<optype> is non-zero then C<flags> has no effect.
6334
6335 If C<optype> is zero, then a plain scalar or list assignment is
6336 constructed.  Which type of assignment it is is automatically determined.
6337 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6338 will be set automatically, and, shifted up eight bits, the eight bits
6339 of C<op_private>, except that the bit with value 1 or 2 is automatically
6340 set as required.
6341
6342 =cut
6343 */
6344
6345 OP *
6346 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
6347 {
6348     OP *o;
6349     I32 assign_type;
6350
6351     if (optype) {
6352         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
6353             return newLOGOP(optype, 0,
6354                 op_lvalue(scalar(left), optype),
6355                 newUNOP(OP_SASSIGN, 0, scalar(right)));
6356         }
6357         else {
6358             return newBINOP(optype, OPf_STACKED,
6359                 op_lvalue(scalar(left), optype), scalar(right));
6360         }
6361     }
6362
6363     if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
6364         static const char no_list_state[] = "Initialization of state variables"
6365             " in list context currently forbidden";
6366         OP *curop;
6367
6368         if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
6369             left->op_private &= ~ OPpSLICEWARNING;
6370
6371         PL_modcount = 0;
6372         left = op_lvalue(left, OP_AASSIGN);
6373         curop = list(force_list(left, 1));
6374         o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
6375         o->op_private = (U8)(0 | (flags >> 8));
6376
6377         if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
6378         {
6379             OP* lop = ((LISTOP*)left)->op_first;
6380             while (lop) {
6381                 if ((lop->op_type == OP_PADSV ||
6382                      lop->op_type == OP_PADAV ||
6383                      lop->op_type == OP_PADHV ||
6384                      lop->op_type == OP_PADANY)
6385                   && (lop->op_private & OPpPAD_STATE)
6386                 )
6387                     yyerror(no_list_state);
6388                 lop = OpSIBLING(lop);
6389             }
6390         }
6391         else if (  (left->op_private & OPpLVAL_INTRO)
6392                 && (left->op_private & OPpPAD_STATE)
6393                 && (   left->op_type == OP_PADSV
6394                     || left->op_type == OP_PADAV
6395                     || left->op_type == OP_PADHV
6396                     || left->op_type == OP_PADANY)
6397         ) {
6398                 /* All single variable list context state assignments, hence
6399                    state ($a) = ...
6400                    (state $a) = ...
6401                    state @a = ...
6402                    state (@a) = ...
6403                    (state @a) = ...
6404                    state %a = ...
6405                    state (%a) = ...
6406                    (state %a) = ...
6407                 */
6408                 yyerror(no_list_state);
6409         }
6410
6411         if (right && right->op_type == OP_SPLIT
6412          && !(right->op_flags & OPf_STACKED)) {
6413             OP* tmpop = ((LISTOP*)right)->op_first;
6414             PMOP * const pm = (PMOP*)tmpop;
6415             assert (tmpop && (tmpop->op_type == OP_PUSHRE));
6416             if (
6417 #ifdef USE_ITHREADS
6418                     !pm->op_pmreplrootu.op_pmtargetoff
6419 #else
6420                     !pm->op_pmreplrootu.op_pmtargetgv
6421 #endif
6422                  && !pm->op_targ
6423                 ) {
6424                     if (!(left->op_private & OPpLVAL_INTRO) &&
6425                         ( (left->op_type == OP_RV2AV &&
6426                           (tmpop=((UNOP*)left)->op_first)->op_type==OP_GV)
6427                         || left->op_type == OP_PADAV )
6428                         ) {
6429                         if (tmpop != (OP *)pm) {
6430 #ifdef USE_ITHREADS
6431                           pm->op_pmreplrootu.op_pmtargetoff
6432                             = cPADOPx(tmpop)->op_padix;
6433                           cPADOPx(tmpop)->op_padix = 0; /* steal it */
6434 #else
6435                           pm->op_pmreplrootu.op_pmtargetgv
6436                             = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
6437                           cSVOPx(tmpop)->op_sv = NULL;  /* steal it */
6438 #endif
6439                           right->op_private |=
6440                             left->op_private & OPpOUR_INTRO;
6441                         }
6442                         else {
6443                             pm->op_targ = left->op_targ;
6444                             left->op_targ = 0; /* filch it */
6445                         }
6446                       detach_split:
6447                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
6448                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
6449                         /* detach rest of siblings from o subtree,
6450                          * and free subtree */
6451                         op_sibling_splice(cUNOPo->op_first, tmpop, -1, NULL);
6452                         op_free(o);                     /* blow off assign */
6453                         right->op_flags &= ~OPf_WANT;
6454                                 /* "I don't know and I don't care." */
6455                         return right;
6456                     }
6457                     else if (left->op_type == OP_RV2AV
6458                           || left->op_type == OP_PADAV)
6459                     {
6460                         /* Detach the array.  */
6461 #ifdef DEBUGGING
6462                         OP * const ary =
6463 #endif
6464                         op_sibling_splice(cBINOPo->op_last,
6465                                           cUNOPx(cBINOPo->op_last)
6466                                                 ->op_first, 1, NULL);
6467                         assert(ary == left);
6468                         /* Attach it to the split.  */
6469                         op_sibling_splice(right, cLISTOPx(right)->op_last,
6470                                           0, left);
6471                         right->op_flags |= OPf_STACKED;
6472                         /* Detach split and expunge aassign as above.  */
6473                         goto detach_split;
6474                     }
6475                     else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
6476                             ((LISTOP*)right)->op_last->op_type == OP_CONST)
6477                     {
6478                         SV ** const svp =
6479                             &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
6480                         SV * const sv = *svp;
6481                         if (SvIOK(sv) && SvIVX(sv) == 0)
6482                         {
6483                           if (right->op_private & OPpSPLIT_IMPLIM) {
6484                             /* our own SV, created in ck_split */
6485                             SvREADONLY_off(sv);
6486                             sv_setiv(sv, PL_modcount+1);
6487                           }
6488                           else {
6489                             /* SV may belong to someone else */
6490                             SvREFCNT_dec(sv);
6491                             *svp = newSViv(PL_modcount+1);
6492                           }
6493                         }
6494                     }
6495             }
6496         }
6497         return o;
6498     }
6499     if (assign_type == ASSIGN_REF)
6500         return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
6501     if (!right)
6502         right = newOP(OP_UNDEF, 0);
6503     if (right->op_type == OP_READLINE) {
6504         right->op_flags |= OPf_STACKED;
6505         return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
6506                 scalar(right));
6507     }
6508     else {
6509         o = newBINOP(OP_SASSIGN, flags,
6510             scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
6511     }
6512     return o;
6513 }
6514
6515 /*
6516 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
6517
6518 Constructs a state op (COP).  The state op is normally a C<nextstate> op,
6519 but will be a C<dbstate> op if debugging is enabled for currently-compiled
6520 code.  The state op is populated from C<PL_curcop> (or C<PL_compiling>).
6521 If C<label> is non-null, it supplies the name of a label to attach to
6522 the state op; this function takes ownership of the memory pointed at by
6523 C<label>, and will free it.  C<flags> gives the eight bits of C<op_flags>
6524 for the state op.
6525
6526 If C<o> is null, the state op is returned.  Otherwise the state op is
6527 combined with C<o> into a C<lineseq> list op, which is returned.  C<o>
6528 is consumed by this function and becomes part of the returned op tree.
6529
6530 =cut
6531 */
6532
6533 OP *
6534 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
6535 {
6536     dVAR;
6537     const U32 seq = intro_my();
6538     const U32 utf8 = flags & SVf_UTF8;
6539     COP *cop;
6540
6541     PL_parser->parsed_sub = 0;
6542
6543     flags &= ~SVf_UTF8;
6544
6545     NewOp(1101, cop, 1, COP);
6546     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
6547         OpTYPE_set(cop, OP_DBSTATE);
6548     }
6549     else {
6550         OpTYPE_set(cop, OP_NEXTSTATE);
6551     }
6552     cop->op_flags = (U8)flags;
6553     CopHINTS_set(cop, PL_hints);
6554 #ifdef VMS
6555     if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
6556 #endif
6557     cop->op_next = (OP*)cop;
6558
6559     cop->cop_seq = seq;
6560     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
6561     CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
6562     if (label) {
6563         Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
6564
6565         PL_hints |= HINT_BLOCK_SCOPE;
6566         /* It seems that we need to defer freeing this pointer, as other parts
6567            of the grammar end up wanting to copy it after this op has been
6568            created. */
6569         SAVEFREEPV(label);
6570     }
6571
6572     if (PL_parser->preambling != NOLINE) {
6573         CopLINE_set(cop, PL_parser->preambling);
6574         PL_parser->copline = NOLINE;
6575     }
6576     else if (PL_parser->copline == NOLINE)
6577         CopLINE_set(cop, CopLINE(PL_curcop));
6578     else {
6579         CopLINE_set(cop, PL_parser->copline);
6580         PL_parser->copline = NOLINE;
6581     }
6582 #ifdef USE_ITHREADS
6583     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
6584 #else
6585     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
6586 #endif
6587     CopSTASH_set(cop, PL_curstash);
6588
6589     if (cop->op_type == OP_DBSTATE) {
6590         /* this line can have a breakpoint - store the cop in IV */
6591         AV *av = CopFILEAVx(PL_curcop);
6592         if (av) {
6593             SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
6594             if (svp && *svp != &PL_sv_undef ) {
6595                 (void)SvIOK_on(*svp);
6596                 SvIV_set(*svp, PTR2IV(cop));
6597             }
6598         }
6599     }
6600
6601     if (flags & OPf_SPECIAL)
6602         op_null((OP*)cop);
6603     return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
6604 }
6605
6606 /*
6607 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
6608
6609 Constructs, checks, and returns a logical (flow control) op.  C<type>
6610 is the opcode.  C<flags> gives the eight bits of C<op_flags>, except
6611 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6612 the eight bits of C<op_private>, except that the bit with value 1 is
6613 automatically set.  C<first> supplies the expression controlling the
6614 flow, and C<other> supplies the side (alternate) chain of ops; they are
6615 consumed by this function and become part of the constructed op tree.
6616
6617 =cut
6618 */
6619
6620 OP *
6621 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
6622 {
6623     PERL_ARGS_ASSERT_NEWLOGOP;
6624
6625     return new_logop(type, flags, &first, &other);
6626 }
6627
6628 STATIC OP *
6629 S_search_const(pTHX_ OP *o)
6630 {
6631     PERL_ARGS_ASSERT_SEARCH_CONST;
6632
6633     switch (o->op_type) {
6634         case OP_CONST:
6635             return o;
6636         case OP_NULL:
6637             if (o->op_flags & OPf_KIDS)
6638                 return search_const(cUNOPo->op_first);
6639             break;
6640         case OP_LEAVE:
6641         case OP_SCOPE:
6642         case OP_LINESEQ:
6643         {
6644             OP *kid;
6645             if (!(o->op_flags & OPf_KIDS))
6646                 return NULL;
6647             kid = cLISTOPo->op_first;
6648             do {
6649                 switch (kid->op_type) {
6650                     case OP_ENTER:
6651                     case OP_NULL:
6652                     case OP_NEXTSTATE:
6653                         kid = OpSIBLING(kid);
6654                         break;
6655                     default:
6656                         if (kid != cLISTOPo->op_last)
6657                             return NULL;
6658                         goto last;
6659                 }
6660             } while (kid);
6661             if (!kid)
6662                 kid = cLISTOPo->op_last;
6663           last:
6664             return search_const(kid);
6665         }
6666     }
6667
6668     return NULL;
6669 }
6670
6671 STATIC OP *
6672 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
6673 {
6674     dVAR;
6675     LOGOP *logop;
6676     OP *o;
6677     OP *first;
6678     OP *other;
6679     OP *cstop = NULL;
6680     int prepend_not = 0;
6681
6682     PERL_ARGS_ASSERT_NEW_LOGOP;
6683
6684     first = *firstp;
6685     other = *otherp;
6686
6687     /* [perl #59802]: Warn about things like "return $a or $b", which
6688        is parsed as "(return $a) or $b" rather than "return ($a or
6689        $b)".  NB: This also applies to xor, which is why we do it
6690        here.
6691      */
6692     switch (first->op_type) {
6693     case OP_NEXT:
6694     case OP_LAST:
6695     case OP_REDO:
6696         /* XXX: Perhaps we should emit a stronger warning for these.
6697            Even with the high-precedence operator they don't seem to do
6698            anything sensible.
6699
6700            But until we do, fall through here.
6701          */
6702     case OP_RETURN:
6703     case OP_EXIT:
6704     case OP_DIE:
6705     case OP_GOTO:
6706         /* XXX: Currently we allow people to "shoot themselves in the
6707            foot" by explicitly writing "(return $a) or $b".
6708
6709            Warn unless we are looking at the result from folding or if
6710            the programmer explicitly grouped the operators like this.
6711            The former can occur with e.g.
6712
6713                 use constant FEATURE => ( $] >= ... );
6714                 sub { not FEATURE and return or do_stuff(); }
6715          */
6716         if (!first->op_folded && !(first->op_flags & OPf_PARENS))
6717             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6718                            "Possible precedence issue with control flow operator");
6719         /* XXX: Should we optimze this to "return $a;" (i.e. remove
6720            the "or $b" part)?
6721         */
6722         break;
6723     }
6724
6725     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
6726         return newBINOP(type, flags, scalar(first), scalar(other));
6727
6728     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
6729         || type == OP_CUSTOM);
6730
6731     scalarboolean(first);
6732     /* optimize AND and OR ops that have NOTs as children */
6733     if (first->op_type == OP_NOT
6734         && (first->op_flags & OPf_KIDS)
6735         && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
6736             || (other->op_type == OP_NOT))  /* if (!$x && !$y) { } */
6737         ) {
6738         if (type == OP_AND || type == OP_OR) {
6739             if (type == OP_AND)
6740                 type = OP_OR;
6741             else
6742                 type = OP_AND;
6743             op_null(first);
6744             if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
6745                 op_null(other);
6746                 prepend_not = 1; /* prepend a NOT op later */
6747             }
6748         }
6749     }
6750     /* search for a constant op that could let us fold the test */
6751     if ((cstop = search_const(first))) {
6752         if (cstop->op_private & OPpCONST_STRICT)
6753             no_bareword_allowed(cstop);
6754         else if ((cstop->op_private & OPpCONST_BARE))
6755                 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
6756         if ((type == OP_AND &&  SvTRUE(((SVOP*)cstop)->op_sv)) ||
6757             (type == OP_OR  && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
6758             (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
6759             *firstp = NULL;
6760             if (other->op_type == OP_CONST)
6761                 other->op_private |= OPpCONST_SHORTCIRCUIT;
6762             op_free(first);
6763             if (other->op_type == OP_LEAVE)
6764                 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
6765             else if (other->op_type == OP_MATCH
6766                   || other->op_type == OP_SUBST
6767                   || other->op_type == OP_TRANSR
6768                   || other->op_type == OP_TRANS)
6769                 /* Mark the op as being unbindable with =~ */
6770                 other->op_flags |= OPf_SPECIAL;
6771
6772             other->op_folded = 1;
6773             return other;
6774         }
6775         else {
6776             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
6777             const OP *o2 = other;
6778             if ( ! (o2->op_type == OP_LIST
6779                     && (( o2 = cUNOPx(o2)->op_first))
6780                     && o2->op_type == OP_PUSHMARK
6781                     && (( o2 = OpSIBLING(o2))) )
6782             )
6783                 o2 = other;
6784             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
6785                         || o2->op_type == OP_PADHV)
6786                 && o2->op_private & OPpLVAL_INTRO
6787                 && !(o2->op_private & OPpPAD_STATE))
6788             {
6789                 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6790                                  "Deprecated use of my() in false conditional");
6791             }
6792
6793             *otherp = NULL;
6794             if (cstop->op_type == OP_CONST)
6795                 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
6796                 op_free(other);
6797             return first;
6798         }
6799     }
6800     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
6801         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
6802     {
6803         const OP * const k1 = ((UNOP*)first)->op_first;
6804         const OP * const k2 = OpSIBLING(k1);
6805         OPCODE warnop = 0;
6806         switch (first->op_type)
6807         {
6808         case OP_NULL:
6809             if (k2 && k2->op_type == OP_READLINE
6810                   && (k2->op_flags & OPf_STACKED)
6811                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6812             {
6813                 warnop = k2->op_type;
6814             }
6815             break;
6816
6817         case OP_SASSIGN:
6818             if (k1->op_type == OP_READDIR
6819                   || k1->op_type == OP_GLOB
6820                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6821                  || k1->op_type == OP_EACH
6822                  || k1->op_type == OP_AEACH)
6823             {
6824                 warnop = ((k1->op_type == OP_NULL)
6825                           ? (OPCODE)k1->op_targ : k1->op_type);
6826             }
6827             break;
6828         }
6829         if (warnop) {
6830             const line_t oldline = CopLINE(PL_curcop);
6831             /* This ensures that warnings are reported at the first line
6832                of the construction, not the last.  */
6833             CopLINE_set(PL_curcop, PL_parser->copline);
6834             Perl_warner(aTHX_ packWARN(WARN_MISC),
6835                  "Value of %s%s can be \"0\"; test with defined()",
6836                  PL_op_desc[warnop],
6837                  ((warnop == OP_READLINE || warnop == OP_GLOB)
6838                   ? " construct" : "() operator"));
6839             CopLINE_set(PL_curcop, oldline);
6840         }
6841     }
6842
6843     if (!other)
6844         return first;
6845
6846     if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
6847         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
6848
6849     logop = S_alloc_LOGOP(aTHX_ type, first, LINKLIST(other));
6850     logop->op_flags |= (U8)flags;
6851     logop->op_private = (U8)(1 | (flags >> 8));
6852
6853     /* establish postfix order */
6854     logop->op_next = LINKLIST(first);
6855     first->op_next = (OP*)logop;
6856     assert(!OpHAS_SIBLING(first));
6857     op_sibling_splice((OP*)logop, first, 0, other);
6858
6859     CHECKOP(type,logop);
6860
6861     o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
6862                 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
6863                 (OP*)logop);
6864     other->op_next = o;
6865
6866     return o;
6867 }
6868
6869 /*
6870 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
6871
6872 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
6873 op.  C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6874 will be set automatically, and, shifted up eight bits, the eight bits of
6875 C<op_private>, except that the bit with value 1 is automatically set.
6876 C<first> supplies the expression selecting between the two branches,
6877 and C<trueop> and C<falseop> supply the branches; they are consumed by
6878 this function and become part of the constructed op tree.
6879
6880 =cut
6881 */
6882
6883 OP *
6884 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
6885 {
6886     dVAR;
6887     LOGOP *logop;
6888     OP *start;
6889     OP *o;
6890     OP *cstop;
6891
6892     PERL_ARGS_ASSERT_NEWCONDOP;
6893
6894     if (!falseop)
6895         return newLOGOP(OP_AND, 0, first, trueop);
6896     if (!trueop)
6897         return newLOGOP(OP_OR, 0, first, falseop);
6898
6899     scalarboolean(first);
6900     if ((cstop = search_const(first))) {
6901         /* Left or right arm of the conditional?  */
6902         const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
6903         OP *live = left ? trueop : falseop;
6904         OP *const dead = left ? falseop : trueop;
6905         if (cstop->op_private & OPpCONST_BARE &&
6906             cstop->op_private & OPpCONST_STRICT) {
6907             no_bareword_allowed(cstop);
6908         }
6909         op_free(first);
6910         op_free(dead);
6911         if (live->op_type == OP_LEAVE)
6912             live = newUNOP(OP_NULL, OPf_SPECIAL, live);
6913         else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
6914               || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
6915             /* Mark the op as being unbindable with =~ */
6916             live->op_flags |= OPf_SPECIAL;
6917         live->op_folded = 1;
6918         return live;
6919     }
6920     logop = S_alloc_LOGOP(aTHX_ OP_COND_EXPR, first, LINKLIST(trueop));
6921     logop->op_flags |= (U8)flags;
6922     logop->op_private = (U8)(1 | (flags >> 8));
6923     logop->op_next = LINKLIST(falseop);
6924
6925     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
6926             logop);
6927
6928     /* establish postfix order */
6929     start = LINKLIST(first);
6930     first->op_next = (OP*)logop;
6931
6932     /* make first, trueop, falseop siblings */
6933     op_sibling_splice((OP*)logop, first,  0, trueop);
6934     op_sibling_splice((OP*)logop, trueop, 0, falseop);
6935
6936     o = newUNOP(OP_NULL, 0, (OP*)logop);
6937
6938     trueop->op_next = falseop->op_next = o;
6939
6940     o->op_next = start;
6941     return o;
6942 }
6943
6944 /*
6945 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
6946
6947 Constructs and returns a C<range> op, with subordinate C<flip> and
6948 C<flop> ops.  C<flags> gives the eight bits of C<op_flags> for the
6949 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
6950 for both the C<flip> and C<range> ops, except that the bit with value
6951 1 is automatically set.  C<left> and C<right> supply the expressions
6952 controlling the endpoints of the range; they are consumed by this function
6953 and become part of the constructed op tree.
6954
6955 =cut
6956 */
6957
6958 OP *
6959 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
6960 {
6961     LOGOP *range;
6962     OP *flip;
6963     OP *flop;
6964     OP *leftstart;
6965     OP *o;
6966
6967     PERL_ARGS_ASSERT_NEWRANGE;
6968
6969     range = S_alloc_LOGOP(aTHX_ OP_RANGE, left, LINKLIST(right));
6970     range->op_flags = OPf_KIDS;
6971     leftstart = LINKLIST(left);
6972     range->op_private = (U8)(1 | (flags >> 8));
6973
6974     /* make left and right siblings */
6975     op_sibling_splice((OP*)range, left, 0, right);
6976
6977     range->op_next = (OP*)range;
6978     flip = newUNOP(OP_FLIP, flags, (OP*)range);
6979     flop = newUNOP(OP_FLOP, 0, flip);
6980     o = newUNOP(OP_NULL, 0, flop);
6981     LINKLIST(flop);
6982     range->op_next = leftstart;
6983
6984     left->op_next = flip;
6985     right->op_next = flop;
6986
6987     range->op_targ =
6988         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
6989     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
6990     flip->op_targ =
6991         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
6992     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
6993     SvPADTMP_on(PAD_SV(flip->op_targ));
6994
6995     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6996     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6997
6998     /* check barewords before they might be optimized aways */
6999     if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
7000         no_bareword_allowed(left);
7001     if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
7002         no_bareword_allowed(right);
7003
7004     flip->op_next = o;
7005     if (!flip->op_private || !flop->op_private)
7006         LINKLIST(o);            /* blow off optimizer unless constant */
7007
7008     return o;
7009 }
7010
7011 /*
7012 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
7013
7014 Constructs, checks, and returns an op tree expressing a loop.  This is
7015 only a loop in the control flow through the op tree; it does not have
7016 the heavyweight loop structure that allows exiting the loop by C<last>
7017 and suchlike.  C<flags> gives the eight bits of C<op_flags> for the
7018 top-level op, except that some bits will be set automatically as required.
7019 C<expr> supplies the expression controlling loop iteration, and C<block>
7020 supplies the body of the loop; they are consumed by this function and
7021 become part of the constructed op tree.  C<debuggable> is currently
7022 unused and should always be 1.
7023
7024 =cut
7025 */
7026
7027 OP *
7028 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
7029 {
7030     OP* listop;
7031     OP* o;
7032     const bool once = block && block->op_flags & OPf_SPECIAL &&
7033                       block->op_type == OP_NULL;
7034
7035     PERL_UNUSED_ARG(debuggable);
7036
7037     if (expr) {
7038         if (once && (
7039               (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
7040            || (  expr->op_type == OP_NOT
7041               && cUNOPx(expr)->op_first->op_type == OP_CONST
7042               && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
7043               )
7044            ))
7045             /* Return the block now, so that S_new_logop does not try to
7046                fold it away. */
7047             return block;       /* do {} while 0 does once */
7048         if (expr->op_type == OP_READLINE
7049             || expr->op_type == OP_READDIR
7050             || expr->op_type == OP_GLOB
7051             || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
7052             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
7053             expr = newUNOP(OP_DEFINED, 0,
7054                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
7055         } else if (expr->op_flags & OPf_KIDS) {
7056             const OP * const k1 = ((UNOP*)expr)->op_first;
7057             const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
7058             switch (expr->op_type) {
7059               case OP_NULL:
7060                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
7061                       && (k2->op_flags & OPf_STACKED)
7062                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7063                     expr = newUNOP(OP_DEFINED, 0, expr);
7064                 break;
7065
7066               case OP_SASSIGN:
7067                 if (k1 && (k1->op_type == OP_READDIR
7068                       || k1->op_type == OP_GLOB
7069                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7070                      || k1->op_type == OP_EACH
7071                      || k1->op_type == OP_AEACH))
7072                     expr = newUNOP(OP_DEFINED, 0, expr);
7073                 break;
7074             }
7075         }
7076     }
7077
7078     /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
7079      * op, in listop. This is wrong. [perl #27024] */
7080     if (!block)
7081         block = newOP(OP_NULL, 0);
7082     listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
7083     o = new_logop(OP_AND, 0, &expr, &listop);
7084
7085     if (once) {
7086         ASSUME(listop);
7087     }
7088
7089     if (listop)
7090         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
7091
7092     if (once && o != listop)
7093     {
7094         assert(cUNOPo->op_first->op_type == OP_AND
7095             || cUNOPo->op_first->op_type == OP_OR);
7096         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
7097     }
7098
7099     if (o == listop)
7100         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
7101
7102     o->op_flags |= flags;
7103     o = op_scope(o);
7104     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
7105     return o;
7106 }
7107
7108 /*
7109 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
7110
7111 Constructs, checks, and returns an op tree expressing a C<while> loop.
7112 This is a heavyweight loop, with structure that allows exiting the loop
7113 by C<last> and suchlike.
7114
7115 C<loop> is an optional preconstructed C<enterloop> op to use in the
7116 loop; if it is null then a suitable op will be constructed automatically.
7117 C<expr> supplies the loop's controlling expression.  C<block> supplies the
7118 main body of the loop, and C<cont> optionally supplies a C<continue> block
7119 that operates as a second half of the body.  All of these optree inputs
7120 are consumed by this function and become part of the constructed op tree.
7121
7122 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7123 op and, shifted up eight bits, the eight bits of C<op_private> for
7124 the C<leaveloop> op, except that (in both cases) some bits will be set
7125 automatically.  C<debuggable> is currently unused and should always be 1.
7126 C<has_my> can be supplied as true to force the
7127 loop body to be enclosed in its own scope.
7128
7129 =cut
7130 */
7131
7132 OP *
7133 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
7134         OP *expr, OP *block, OP *cont, I32 has_my)
7135 {
7136     dVAR;
7137     OP *redo;
7138     OP *next = NULL;
7139     OP *listop;
7140     OP *o;
7141     U8 loopflags = 0;
7142
7143     PERL_UNUSED_ARG(debuggable);
7144
7145     if (expr) {
7146         if (expr->op_type == OP_READLINE
7147          || expr->op_type == OP_READDIR
7148          || expr->op_type == OP_GLOB
7149          || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
7150                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
7151             expr = newUNOP(OP_DEFINED, 0,
7152                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
7153         } else if (expr->op_flags & OPf_KIDS) {
7154             const OP * const k1 = ((UNOP*)expr)->op_first;
7155             const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
7156             switch (expr->op_type) {
7157               case OP_NULL:
7158                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
7159                       && (k2->op_flags & OPf_STACKED)
7160                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7161                     expr = newUNOP(OP_DEFINED, 0, expr);
7162                 break;
7163
7164               case OP_SASSIGN:
7165                 if (k1 && (k1->op_type == OP_READDIR
7166                       || k1->op_type == OP_GLOB
7167                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7168                      || k1->op_type == OP_EACH
7169                      || k1->op_type == OP_AEACH))
7170                     expr = newUNOP(OP_DEFINED, 0, expr);
7171                 break;
7172             }
7173         }
7174     }
7175
7176     if (!block)
7177         block = newOP(OP_NULL, 0);
7178     else if (cont || has_my) {
7179         block = op_scope(block);
7180     }
7181
7182     if (cont) {
7183         next = LINKLIST(cont);
7184     }
7185     if (expr) {
7186         OP * const unstack = newOP(OP_UNSTACK, 0);
7187         if (!next)
7188             next = unstack;
7189         cont = op_append_elem(OP_LINESEQ, cont, unstack);
7190     }
7191
7192     assert(block);
7193     listop = op_append_list(OP_LINESEQ, block, cont);
7194     assert(listop);
7195     redo = LINKLIST(listop);
7196
7197     if (expr) {
7198         scalar(listop);
7199         o = new_logop(OP_AND, 0, &expr, &listop);
7200         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
7201             op_free((OP*)loop);
7202             return expr;                /* listop already freed by new_logop */
7203         }
7204         if (listop)
7205             ((LISTOP*)listop)->op_last->op_next =
7206                 (o == listop ? redo : LINKLIST(o));
7207     }
7208     else
7209         o = listop;
7210
7211     if (!loop) {
7212         NewOp(1101,loop,1,LOOP);
7213         OpTYPE_set(loop, OP_ENTERLOOP);
7214         loop->op_private = 0;
7215         loop->op_next = (OP*)loop;
7216     }
7217
7218     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
7219
7220     loop->op_redoop = redo;
7221     loop->op_lastop = o;
7222     o->op_private |= loopflags;
7223
7224     if (next)
7225         loop->op_nextop = next;
7226     else
7227         loop->op_nextop = o;
7228
7229     o->op_flags |= flags;
7230     o->op_private |= (flags >> 8);
7231     return o;
7232 }
7233
7234 /*
7235 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
7236
7237 Constructs, checks, and returns an op tree expressing a C<foreach>
7238 loop (iteration through a list of values).  This is a heavyweight loop,
7239 with structure that allows exiting the loop by C<last> and suchlike.
7240
7241 C<sv> optionally supplies the variable that will be aliased to each
7242 item in turn; if null, it defaults to C<$_>.
7243 C<expr> supplies the list of values to iterate over.  C<block> supplies
7244 the main body of the loop, and C<cont> optionally supplies a C<continue>
7245 block that operates as a second half of the body.  All of these optree
7246 inputs are consumed by this function and become part of the constructed
7247 op tree.
7248
7249 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7250 op and, shifted up eight bits, the eight bits of C<op_private> for
7251 the C<leaveloop> op, except that (in both cases) some bits will be set
7252 automatically.
7253
7254 =cut
7255 */
7256
7257 OP *
7258 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
7259 {
7260     dVAR;
7261     LOOP *loop;
7262     OP *wop;
7263     PADOFFSET padoff = 0;
7264     I32 iterflags = 0;
7265     I32 iterpflags = 0;
7266
7267     PERL_ARGS_ASSERT_NEWFOROP;
7268
7269     if (sv) {
7270         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
7271             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
7272             OpTYPE_set(sv, OP_RV2GV);
7273
7274             /* The op_type check is needed to prevent a possible segfault
7275              * if the loop variable is undeclared and 'strict vars' is in
7276              * effect. This is illegal but is nonetheless parsed, so we
7277              * may reach this point with an OP_CONST where we're expecting
7278              * an OP_GV.
7279              */
7280             if (cUNOPx(sv)->op_first->op_type == OP_GV
7281              && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
7282                 iterpflags |= OPpITER_DEF;
7283         }
7284         else if (sv->op_type == OP_PADSV) { /* private variable */
7285             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
7286             padoff = sv->op_targ;
7287             sv->op_targ = 0;
7288             op_free(sv);
7289             sv = NULL;
7290             PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
7291         }
7292         else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
7293             NOOP;
7294         else
7295             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
7296         if (padoff) {
7297             PADNAME * const pn = PAD_COMPNAME(padoff);
7298             const char * const name = PadnamePV(pn);
7299
7300             if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
7301                 iterpflags |= OPpITER_DEF;
7302         }
7303     }
7304     else {
7305         sv = newGVOP(OP_GV, 0, PL_defgv);
7306         iterpflags |= OPpITER_DEF;
7307     }
7308
7309     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
7310         expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
7311         iterflags |= OPf_STACKED;
7312     }
7313     else if (expr->op_type == OP_NULL &&
7314              (expr->op_flags & OPf_KIDS) &&
7315              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
7316     {
7317         /* Basically turn for($x..$y) into the same as for($x,$y), but we
7318          * set the STACKED flag to indicate that these values are to be
7319          * treated as min/max values by 'pp_enteriter'.
7320          */
7321         const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
7322         LOGOP* const range = (LOGOP*) flip->op_first;
7323         OP* const left  = range->op_first;
7324         OP* const right = OpSIBLING(left);
7325         LISTOP* listop;
7326
7327         range->op_flags &= ~OPf_KIDS;
7328         /* detach range's children */
7329         op_sibling_splice((OP*)range, NULL, -1, NULL);
7330
7331         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
7332         listop->op_first->op_next = range->op_next;
7333         left->op_next = range->op_other;
7334         right->op_next = (OP*)listop;
7335         listop->op_next = listop->op_first;
7336
7337         op_free(expr);
7338         expr = (OP*)(listop);
7339         op_null(expr);
7340         iterflags |= OPf_STACKED;
7341     }
7342     else {
7343         expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
7344     }
7345
7346     loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
7347                                   op_append_elem(OP_LIST, list(expr),
7348                                                  scalar(sv)));
7349     assert(!loop->op_next);
7350     /* for my  $x () sets OPpLVAL_INTRO;
7351      * for our $x () sets OPpOUR_INTRO */
7352     loop->op_private = (U8)iterpflags;
7353     if (loop->op_slabbed
7354      && DIFF(loop, OpSLOT(loop)->opslot_next)
7355          < SIZE_TO_PSIZE(sizeof(LOOP)))
7356     {
7357         LOOP *tmp;
7358         NewOp(1234,tmp,1,LOOP);
7359         Copy(loop,tmp,1,LISTOP);
7360 #ifdef PERL_OP_PARENT
7361         assert(loop->op_last->op_sibparent == (OP*)loop);
7362         OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
7363 #endif
7364         S_op_destroy(aTHX_ (OP*)loop);
7365         loop = tmp;
7366     }
7367     else if (!loop->op_slabbed)
7368     {
7369         loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
7370 #ifdef PERL_OP_PARENT
7371         OpLASTSIB_set(loop->op_last, (OP*)loop);
7372 #endif
7373     }
7374     loop->op_targ = padoff;
7375     wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
7376     return wop;
7377 }
7378
7379 /*
7380 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
7381
7382 Constructs, checks, and returns a loop-exiting op (such as C<goto>
7383 or C<last>).  C<type> is the opcode.  C<label> supplies the parameter
7384 determining the target of the op; it is consumed by this function and
7385 becomes part of the constructed op tree.
7386
7387 =cut
7388 */
7389
7390 OP*
7391 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
7392 {
7393     OP *o = NULL;
7394
7395     PERL_ARGS_ASSERT_NEWLOOPEX;
7396
7397     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
7398         || type == OP_CUSTOM);
7399
7400     if (type != OP_GOTO) {
7401         /* "last()" means "last" */
7402         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
7403             o = newOP(type, OPf_SPECIAL);
7404         }
7405     }
7406     else {
7407         /* Check whether it's going to be a goto &function */
7408         if (label->op_type == OP_ENTERSUB
7409                 && !(label->op_flags & OPf_STACKED))
7410             label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
7411     }
7412
7413     /* Check for a constant argument */
7414     if (label->op_type == OP_CONST) {
7415             SV * const sv = ((SVOP *)label)->op_sv;
7416             STRLEN l;
7417             const char *s = SvPV_const(sv,l);
7418             if (l == strlen(s)) {
7419                 o = newPVOP(type,
7420                             SvUTF8(((SVOP*)label)->op_sv),
7421                             savesharedpv(
7422                                 SvPV_nolen_const(((SVOP*)label)->op_sv)));
7423             }
7424     }
7425
7426     /* If we have already created an op, we do not need the label. */
7427     if (o)
7428                 op_free(label);
7429     else o = newUNOP(type, OPf_STACKED, label);
7430
7431     PL_hints |= HINT_BLOCK_SCOPE;
7432     return o;
7433 }
7434
7435 /* if the condition is a literal array or hash
7436    (or @{ ... } etc), make a reference to it.
7437  */
7438 STATIC OP *
7439 S_ref_array_or_hash(pTHX_ OP *cond)
7440 {
7441     if (cond
7442     && (cond->op_type == OP_RV2AV
7443     ||  cond->op_type == OP_PADAV
7444     ||  cond->op_type == OP_RV2HV
7445     ||  cond->op_type == OP_PADHV))
7446
7447         return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
7448
7449     else if(cond
7450     && (cond->op_type == OP_ASLICE
7451     ||  cond->op_type == OP_KVASLICE
7452     ||  cond->op_type == OP_HSLICE
7453     ||  cond->op_type == OP_KVHSLICE)) {
7454
7455         /* anonlist now needs a list from this op, was previously used in
7456          * scalar context */
7457         cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
7458         cond->op_flags |= OPf_WANT_LIST;
7459
7460         return newANONLIST(op_lvalue(cond, OP_ANONLIST));
7461     }
7462
7463     else
7464         return cond;
7465 }
7466
7467 /* These construct the optree fragments representing given()
7468    and when() blocks.
7469
7470    entergiven and enterwhen are LOGOPs; the op_other pointer
7471    points up to the associated leave op. We need this so we
7472    can put it in the context and make break/continue work.
7473    (Also, of course, pp_enterwhen will jump straight to
7474    op_other if the match fails.)
7475  */
7476
7477 STATIC OP *
7478 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
7479                    I32 enter_opcode, I32 leave_opcode,
7480                    PADOFFSET entertarg)
7481 {
7482     dVAR;
7483     LOGOP *enterop;
7484     OP *o;
7485
7486     PERL_ARGS_ASSERT_NEWGIVWHENOP;
7487     PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
7488
7489     enterop = S_alloc_LOGOP(aTHX_ enter_opcode, block, NULL);
7490     enterop->op_targ = 0;
7491     enterop->op_private = 0;
7492
7493     o = newUNOP(leave_opcode, 0, (OP *) enterop);
7494
7495     if (cond) {
7496         /* prepend cond if we have one */
7497         op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
7498
7499         o->op_next = LINKLIST(cond);
7500         cond->op_next = (OP *) enterop;
7501     }
7502     else {
7503         /* This is a default {} block */
7504         enterop->op_flags |= OPf_SPECIAL;
7505         o      ->op_flags |= OPf_SPECIAL;
7506
7507         o->op_next = (OP *) enterop;
7508     }
7509
7510     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
7511                                        entergiven and enterwhen both
7512                                        use ck_null() */
7513
7514     enterop->op_next = LINKLIST(block);
7515     block->op_next = enterop->op_other = o;
7516
7517     return o;
7518 }
7519
7520 /* Does this look like a boolean operation? For these purposes
7521    a boolean operation is:
7522      - a subroutine call [*]
7523      - a logical connective
7524      - a comparison operator
7525      - a filetest operator, with the exception of -s -M -A -C
7526      - defined(), exists() or eof()
7527      - /$re/ or $foo =~ /$re/
7528
7529    [*] possibly surprising
7530  */
7531 STATIC bool
7532 S_looks_like_bool(pTHX_ const OP *o)
7533 {
7534     PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
7535
7536     switch(o->op_type) {
7537         case OP_OR:
7538         case OP_DOR:
7539             return looks_like_bool(cLOGOPo->op_first);
7540
7541         case OP_AND:
7542         {
7543             OP* sibl = OpSIBLING(cLOGOPo->op_first);
7544             ASSUME(sibl);
7545             return (
7546                 looks_like_bool(cLOGOPo->op_first)
7547              && looks_like_bool(sibl));
7548         }
7549
7550         case OP_NULL:
7551         case OP_SCALAR:
7552             return (
7553                 o->op_flags & OPf_KIDS
7554             && looks_like_bool(cUNOPo->op_first));
7555
7556         case OP_ENTERSUB:
7557
7558         case OP_NOT:    case OP_XOR:
7559
7560         case OP_EQ:     case OP_NE:     case OP_LT:
7561         case OP_GT:     case OP_LE:     case OP_GE:
7562
7563         case OP_I_EQ:   case OP_I_NE:   case OP_I_LT:
7564         case OP_I_GT:   case OP_I_LE:   case OP_I_GE:
7565
7566         case OP_SEQ:    case OP_SNE:    case OP_SLT:
7567         case OP_SGT:    case OP_SLE:    case OP_SGE:
7568
7569         case OP_SMARTMATCH:
7570
7571         case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
7572         case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
7573         case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
7574         case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
7575         case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
7576         case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
7577         case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
7578         case OP_FTTEXT:   case OP_FTBINARY:
7579
7580         case OP_DEFINED: case OP_EXISTS:
7581         case OP_MATCH:   case OP_EOF:
7582
7583         case OP_FLOP:
7584
7585             return TRUE;
7586
7587         case OP_CONST:
7588             /* Detect comparisons that have been optimized away */
7589             if (cSVOPo->op_sv == &PL_sv_yes
7590             ||  cSVOPo->op_sv == &PL_sv_no)
7591
7592                 return TRUE;
7593             else
7594                 return FALSE;
7595
7596         /* FALLTHROUGH */
7597         default:
7598             return FALSE;
7599     }
7600 }
7601
7602 /*
7603 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
7604
7605 Constructs, checks, and returns an op tree expressing a C<given> block.
7606 C<cond> supplies the expression that will be locally assigned to a lexical
7607 variable, and C<block> supplies the body of the C<given> construct; they
7608 are consumed by this function and become part of the constructed op tree.
7609 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
7610
7611 =cut
7612 */
7613
7614 OP *
7615 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
7616 {
7617     PERL_ARGS_ASSERT_NEWGIVENOP;
7618     PERL_UNUSED_ARG(defsv_off);
7619
7620     assert(!defsv_off);
7621     return newGIVWHENOP(
7622         ref_array_or_hash(cond),
7623         block,
7624         OP_ENTERGIVEN, OP_LEAVEGIVEN,
7625         0);
7626 }
7627
7628 /*
7629 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
7630
7631 Constructs, checks, and returns an op tree expressing a C<when> block.
7632 C<cond> supplies the test expression, and C<block> supplies the block
7633 that will be executed if the test evaluates to true; they are consumed
7634 by this function and become part of the constructed op tree.  C<cond>
7635 will be interpreted DWIMically, often as a comparison against C<$_>,
7636 and may be null to generate a C<default> block.
7637
7638 =cut
7639 */
7640
7641 OP *
7642 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
7643 {
7644     const bool cond_llb = (!cond || looks_like_bool(cond));
7645     OP *cond_op;
7646
7647     PERL_ARGS_ASSERT_NEWWHENOP;
7648
7649     if (cond_llb)
7650         cond_op = cond;
7651     else {
7652         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
7653                 newDEFSVOP(),
7654                 scalar(ref_array_or_hash(cond)));
7655     }
7656
7657     return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
7658 }
7659
7660 /* must not conflict with SVf_UTF8 */
7661 #define CV_CKPROTO_CURSTASH     0x1
7662
7663 void
7664 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
7665                     const STRLEN len, const U32 flags)
7666 {
7667     SV *name = NULL, *msg;
7668     const char * cvp = SvROK(cv)
7669                         ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
7670                            ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
7671                            : ""
7672                         : CvPROTO(cv);
7673     STRLEN clen = CvPROTOLEN(cv), plen = len;
7674
7675     PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
7676
7677     if (p == NULL && cvp == NULL)
7678         return;
7679
7680     if (!ckWARN_d(WARN_PROTOTYPE))
7681         return;
7682
7683     if (p && cvp) {
7684         p = S_strip_spaces(aTHX_ p, &plen);
7685         cvp = S_strip_spaces(aTHX_ cvp, &clen);
7686         if ((flags & SVf_UTF8) == SvUTF8(cv)) {
7687             if (plen == clen && memEQ(cvp, p, plen))
7688                 return;
7689         } else {
7690             if (flags & SVf_UTF8) {
7691                 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
7692                     return;
7693             }
7694             else {
7695                 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
7696                     return;
7697             }
7698         }
7699     }
7700
7701     msg = sv_newmortal();
7702
7703     if (gv)
7704     {
7705         if (isGV(gv))
7706             gv_efullname3(name = sv_newmortal(), gv, NULL);
7707         else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
7708             name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
7709         else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
7710             name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
7711             sv_catpvs(name, "::");
7712             if (SvROK(gv)) {
7713                 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
7714                 assert (CvNAMED(SvRV_const(gv)));
7715                 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
7716             }
7717             else sv_catsv(name, (SV *)gv);
7718         }
7719         else name = (SV *)gv;
7720     }
7721     sv_setpvs(msg, "Prototype mismatch:");
7722     if (name)
7723         Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
7724     if (cvp)
7725         Perl_sv_catpvf(aTHX_ msg, " (%"UTF8f")",
7726             UTF8fARG(SvUTF8(cv),clen,cvp)
7727         );
7728     else
7729         sv_catpvs(msg, ": none");
7730     sv_catpvs(msg, " vs ");
7731     if (p)
7732         Perl_sv_catpvf(aTHX_ msg, "(%"UTF8f")", UTF8fARG(flags & SVf_UTF8,len,p));
7733     else
7734         sv_catpvs(msg, "none");
7735     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
7736 }
7737
7738 static void const_sv_xsub(pTHX_ CV* cv);
7739 static void const_av_xsub(pTHX_ CV* cv);
7740
7741 /*
7742
7743 =head1 Optree Manipulation Functions
7744
7745 =for apidoc cv_const_sv
7746
7747 If C<cv> is a constant sub eligible for inlining, returns the constant
7748 value returned by the sub.  Otherwise, returns C<NULL>.
7749
7750 Constant subs can be created with C<newCONSTSUB> or as described in
7751 L<perlsub/"Constant Functions">.
7752
7753 =cut
7754 */
7755 SV *
7756 Perl_cv_const_sv(const CV *const cv)
7757 {
7758     SV *sv;
7759     if (!cv)
7760         return NULL;
7761     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
7762         return NULL;
7763     sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7764     if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
7765     return sv;
7766 }
7767
7768 SV *
7769 Perl_cv_const_sv_or_av(const CV * const cv)
7770 {
7771     if (!cv)
7772         return NULL;
7773     if (SvROK(cv)) return SvRV((SV *)cv);
7774     assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
7775     return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7776 }
7777
7778 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
7779  * Can be called in 2 ways:
7780  *
7781  * !allow_lex
7782  *      look for a single OP_CONST with attached value: return the value
7783  *
7784  * allow_lex && !CvCONST(cv);
7785  *
7786  *      examine the clone prototype, and if contains only a single
7787  *      OP_CONST, return the value; or if it contains a single PADSV ref-
7788  *      erencing an outer lexical, turn on CvCONST to indicate the CV is
7789  *      a candidate for "constizing" at clone time, and return NULL.
7790  */
7791
7792 static SV *
7793 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
7794 {
7795     SV *sv = NULL;
7796     bool padsv = FALSE;
7797
7798     assert(o);
7799     assert(cv);
7800
7801     for (; o; o = o->op_next) {
7802         const OPCODE type = o->op_type;
7803
7804         if (type == OP_NEXTSTATE || type == OP_LINESEQ
7805              || type == OP_NULL
7806              || type == OP_PUSHMARK)
7807                 continue;
7808         if (type == OP_DBSTATE)
7809                 continue;
7810         if (type == OP_LEAVESUB)
7811             break;
7812         if (sv)
7813             return NULL;
7814         if (type == OP_CONST && cSVOPo->op_sv)
7815             sv = cSVOPo->op_sv;
7816         else if (type == OP_UNDEF && !o->op_private) {
7817             sv = newSV(0);
7818             SAVEFREESV(sv);
7819         }
7820         else if (allow_lex && type == OP_PADSV) {
7821                 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
7822                 {
7823                     sv = &PL_sv_undef; /* an arbitrary non-null value */
7824                     padsv = TRUE;
7825                 }
7826                 else
7827                     return NULL;
7828         }
7829         else {
7830             return NULL;
7831         }
7832     }
7833     if (padsv) {
7834         CvCONST_on(cv);
7835         return NULL;
7836     }
7837     return sv;
7838 }
7839
7840 static bool
7841 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
7842                         PADNAME * const name, SV ** const const_svp)
7843 {
7844     assert (cv);
7845     assert (o || name);
7846     assert (const_svp);
7847     if ((!block
7848          )) {
7849         if (CvFLAGS(PL_compcv)) {
7850             /* might have had built-in attrs applied */
7851             const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
7852             if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
7853              && ckWARN(WARN_MISC))
7854             {
7855                 /* protect against fatal warnings leaking compcv */
7856                 SAVEFREESV(PL_compcv);
7857                 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
7858                 SvREFCNT_inc_simple_void_NN(PL_compcv);
7859             }
7860             CvFLAGS(cv) |=
7861                 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
7862                   & ~(CVf_LVALUE * pureperl));
7863         }
7864         return FALSE;
7865     }
7866
7867     /* redundant check for speed: */
7868     if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
7869         const line_t oldline = CopLINE(PL_curcop);
7870         SV *namesv = o
7871             ? cSVOPo->op_sv
7872             : sv_2mortal(newSVpvn_utf8(
7873                 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
7874               ));
7875         if (PL_parser && PL_parser->copline != NOLINE)
7876             /* This ensures that warnings are reported at the first
7877                line of a redefinition, not the last.  */
7878             CopLINE_set(PL_curcop, PL_parser->copline);
7879         /* protect against fatal warnings leaking compcv */
7880         SAVEFREESV(PL_compcv);
7881         report_redefined_cv(namesv, cv, const_svp);
7882         SvREFCNT_inc_simple_void_NN(PL_compcv);
7883         CopLINE_set(PL_curcop, oldline);
7884     }
7885     SAVEFREESV(cv);
7886     return TRUE;
7887 }
7888
7889 CV *
7890 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
7891 {
7892     CV **spot;
7893     SV **svspot;
7894     const char *ps;
7895     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
7896     U32 ps_utf8 = 0;
7897     CV *cv = NULL;
7898     CV *compcv = PL_compcv;
7899     SV *const_sv;
7900     PADNAME *name;
7901     PADOFFSET pax = o->op_targ;
7902     CV *outcv = CvOUTSIDE(PL_compcv);
7903     CV *clonee = NULL;
7904     HEK *hek = NULL;
7905     bool reusable = FALSE;
7906     OP *start = NULL;
7907 #ifdef PERL_DEBUG_READONLY_OPS
7908     OPSLAB *slab = NULL;
7909 #endif
7910
7911     PERL_ARGS_ASSERT_NEWMYSUB;
7912
7913     /* Find the pad slot for storing the new sub.
7914        We cannot use PL_comppad, as it is the pad owned by the new sub.  We
7915        need to look in CvOUTSIDE and find the pad belonging to the enclos-
7916        ing sub.  And then we need to dig deeper if this is a lexical from
7917        outside, as in:
7918            my sub foo; sub { sub foo { } }
7919      */
7920    redo:
7921     name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
7922     if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
7923         pax = PARENT_PAD_INDEX(name);
7924         outcv = CvOUTSIDE(outcv);
7925         assert(outcv);
7926         goto redo;
7927     }
7928     svspot =
7929         &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
7930                         [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
7931     spot = (CV **)svspot;
7932
7933     if (!(PL_parser && PL_parser->error_count))
7934         move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name));
7935
7936     if (proto) {
7937         assert(proto->op_type == OP_CONST);
7938         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
7939         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
7940     }
7941     else
7942         ps = NULL;
7943
7944     if (proto)
7945         SAVEFREEOP(proto);
7946     if (attrs)
7947         SAVEFREEOP(attrs);
7948
7949     if (PL_parser && PL_parser->error_count) {
7950         op_free(block);
7951         SvREFCNT_dec(PL_compcv);
7952         PL_compcv = 0;
7953         goto done;
7954     }
7955
7956     if (CvDEPTH(outcv) && CvCLONE(compcv)) {
7957         cv = *spot;
7958         svspot = (SV **)(spot = &clonee);
7959     }
7960     else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
7961         cv = *spot;
7962     else {
7963         assert (SvTYPE(*spot) == SVt_PVCV);
7964         if (CvNAMED(*spot))
7965             hek = CvNAME_HEK(*spot);
7966         else {
7967             dVAR;
7968             U32 hash;
7969             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
7970             CvNAME_HEK_set(*spot, hek =
7971                 share_hek(
7972                     PadnamePV(name)+1,
7973                     (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
7974                     hash
7975                 )
7976             );
7977             CvLEXICAL_on(*spot);
7978         }
7979         cv = PadnamePROTOCV(name);
7980         svspot = (SV **)(spot = &PadnamePROTOCV(name));
7981     }
7982
7983     if (block) {
7984         /* This makes sub {}; work as expected.  */
7985         if (block->op_type == OP_STUB) {
7986             const line_t l = PL_parser->copline;
7987             op_free(block);
7988             block = newSTATEOP(0, NULL, 0);
7989             PL_parser->copline = l;
7990         }
7991         block = CvLVALUE(compcv)
7992              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
7993                    ? newUNOP(OP_LEAVESUBLV, 0,
7994                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
7995                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
7996         start = LINKLIST(block);
7997         block->op_next = 0;
7998         if (ps && !*ps && !attrs && !CvLVALUE(compcv))
7999             const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
8000         else
8001             const_sv = NULL;
8002     }
8003     else
8004         const_sv = NULL;
8005
8006     if (cv) {
8007         const bool exists = CvROOT(cv) || CvXSUB(cv);
8008
8009         /* if the subroutine doesn't exist and wasn't pre-declared
8010          * with a prototype, assume it will be AUTOLOADed,
8011          * skipping the prototype check
8012          */
8013         if (exists || SvPOK(cv))
8014             cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
8015                                  ps_utf8);
8016         /* already defined? */
8017         if (exists) {
8018             if (S_already_defined(aTHX_ cv,block,NULL,name,&const_sv))
8019                 cv = NULL;
8020             else {
8021                 if (attrs) goto attrs;
8022                 /* just a "sub foo;" when &foo is already defined */
8023                 SAVEFREESV(compcv);
8024                 goto done;
8025             }
8026         }
8027         else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
8028             cv = NULL;
8029             reusable = TRUE;
8030         }
8031     }
8032     if (const_sv) {
8033         SvREFCNT_inc_simple_void_NN(const_sv);
8034         SvFLAGS(const_sv) |= SVs_PADTMP;
8035         if (cv) {
8036             assert(!CvROOT(cv) && !CvCONST(cv));
8037             cv_forget_slab(cv);
8038         }
8039         else {
8040             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8041             CvFILE_set_from_cop(cv, PL_curcop);
8042             CvSTASH_set(cv, PL_curstash);
8043             *spot = cv;
8044         }
8045         sv_setpvs(MUTABLE_SV(cv), "");  /* prototype is "" */
8046         CvXSUBANY(cv).any_ptr = const_sv;
8047         CvXSUB(cv) = const_sv_xsub;
8048         CvCONST_on(cv);
8049         CvISXSUB_on(cv);
8050         PoisonPADLIST(cv);
8051         CvFLAGS(cv) |= CvMETHOD(compcv);
8052         op_free(block);
8053         SvREFCNT_dec(compcv);
8054         PL_compcv = NULL;
8055         goto setname;
8056     }
8057     /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
8058        determine whether this sub definition is in the same scope as its
8059        declaration.  If this sub definition is inside an inner named pack-
8060        age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
8061        the package sub.  So check PadnameOUTER(name) too.
8062      */
8063     if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
8064         assert(!CvWEAKOUTSIDE(compcv));
8065         SvREFCNT_dec(CvOUTSIDE(compcv));
8066         CvWEAKOUTSIDE_on(compcv);
8067     }
8068     /* XXX else do we have a circular reference? */
8069     if (cv) {   /* must reuse cv in case stub is referenced elsewhere */
8070         /* transfer PL_compcv to cv */
8071         if (block
8072         ) {
8073             cv_flags_t preserved_flags =
8074                 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
8075             PADLIST *const temp_padl = CvPADLIST(cv);
8076             CV *const temp_cv = CvOUTSIDE(cv);
8077             const cv_flags_t other_flags =
8078                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8079             OP * const cvstart = CvSTART(cv);
8080
8081             SvPOK_off(cv);
8082             CvFLAGS(cv) =
8083                 CvFLAGS(compcv) | preserved_flags;
8084             CvOUTSIDE(cv) = CvOUTSIDE(compcv);
8085             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
8086             CvPADLIST_set(cv, CvPADLIST(compcv));
8087             CvOUTSIDE(compcv) = temp_cv;
8088             CvPADLIST_set(compcv, temp_padl);
8089             CvSTART(cv) = CvSTART(compcv);
8090             CvSTART(compcv) = cvstart;
8091             CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8092             CvFLAGS(compcv) |= other_flags;
8093
8094             if (CvFILE(cv) && CvDYNFILE(cv)) {
8095                 Safefree(CvFILE(cv));
8096             }
8097
8098             /* inner references to compcv must be fixed up ... */
8099             pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
8100             if (PERLDB_INTER)/* Advice debugger on the new sub. */
8101               ++PL_sub_generation;
8102         }
8103         else {
8104             /* Might have had built-in attributes applied -- propagate them. */
8105             CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
8106         }
8107         /* ... before we throw it away */
8108         SvREFCNT_dec(compcv);
8109         PL_compcv = compcv = cv;
8110     }
8111     else {
8112         cv = compcv;
8113         *spot = cv;
8114     }
8115    setname:
8116     CvLEXICAL_on(cv);
8117     if (!CvNAME_HEK(cv)) {
8118         if (hek) (void)share_hek_hek(hek);
8119         else {
8120             dVAR;
8121             U32 hash;
8122             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
8123             hek = share_hek(PadnamePV(name)+1,
8124                       (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
8125                       hash);
8126         }
8127         CvNAME_HEK_set(cv, hek);
8128     }
8129     if (const_sv) goto clone;
8130
8131     CvFILE_set_from_cop(cv, PL_curcop);
8132     CvSTASH_set(cv, PL_curstash);
8133
8134     if (ps) {
8135         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8136         if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
8137     }
8138
8139     if (!block)
8140         goto attrs;
8141
8142     /* If we assign an optree to a PVCV, then we've defined a subroutine that
8143        the debugger could be able to set a breakpoint in, so signal to
8144        pp_entereval that it should not throw away any saved lines at scope
8145        exit.  */
8146
8147     PL_breakable_sub_gen++;
8148     CvROOT(cv) = block;
8149     CvROOT(cv)->op_private |= OPpREFCOUNTED;
8150     OpREFCNT_set(CvROOT(cv), 1);
8151     /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8152        itself has a refcount. */
8153     CvSLABBED_off(cv);
8154     OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8155 #ifdef PERL_DEBUG_READONLY_OPS
8156     slab = (OPSLAB *)CvSTART(cv);
8157 #endif
8158     CvSTART(cv) = start;
8159     CALL_PEEP(start);
8160     finalize_optree(CvROOT(cv));
8161     S_prune_chain_head(&CvSTART(cv));
8162
8163     /* now that optimizer has done its work, adjust pad values */
8164
8165     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8166
8167   attrs:
8168     if (attrs) {
8169         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8170         apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
8171     }
8172
8173     if (block) {
8174         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8175             SV * const tmpstr = sv_newmortal();
8176             GV * const db_postponed = gv_fetchpvs("DB::postponed",
8177                                                   GV_ADDMULTI, SVt_PVHV);
8178             HV *hv;
8179             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8180                                           CopFILE(PL_curcop),
8181                                           (long)PL_subline,
8182                                           (long)CopLINE(PL_curcop));
8183             if (HvNAME_HEK(PL_curstash)) {
8184                 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
8185                 sv_catpvs(tmpstr, "::");
8186             }
8187             else sv_setpvs(tmpstr, "__ANON__::");
8188             sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
8189                             PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
8190             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8191                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8192             hv = GvHVn(db_postponed);
8193             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8194                 CV * const pcv = GvCV(db_postponed);
8195                 if (pcv) {
8196                     dSP;
8197                     PUSHMARK(SP);
8198                     XPUSHs(tmpstr);
8199                     PUTBACK;
8200                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
8201                 }
8202             }
8203         }
8204     }
8205
8206   clone:
8207     if (clonee) {
8208         assert(CvDEPTH(outcv));
8209         spot = (CV **)
8210             &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
8211         if (reusable) cv_clone_into(clonee, *spot);
8212         else *spot = cv_clone(clonee);
8213         SvREFCNT_dec_NN(clonee);
8214         cv = *spot;
8215     }
8216     if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
8217         PADOFFSET depth = CvDEPTH(outcv);
8218         while (--depth) {
8219             SV *oldcv;
8220             svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
8221             oldcv = *svspot;
8222             *svspot = SvREFCNT_inc_simple_NN(cv);
8223             SvREFCNT_dec(oldcv);
8224         }
8225     }
8226
8227   done:
8228     if (PL_parser)
8229         PL_parser->copline = NOLINE;
8230     LEAVE_SCOPE(floor);
8231 #ifdef PERL_DEBUG_READONLY_OPS
8232     if (slab)
8233         Slab_to_ro(slab);
8234 #endif
8235     op_free(o);
8236     return cv;
8237 }
8238
8239 /* _x = extended */
8240 CV *
8241 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
8242                             OP *block, bool o_is_gv)
8243 {
8244     GV *gv;
8245     const char *ps;
8246     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
8247     U32 ps_utf8 = 0;
8248     CV *cv = NULL;
8249     SV *const_sv;
8250     const bool ec = PL_parser && PL_parser->error_count;
8251     /* If the subroutine has no body, no attributes, and no builtin attributes
8252        then it's just a sub declaration, and we may be able to get away with
8253        storing with a placeholder scalar in the symbol table, rather than a
8254        full CV.  If anything is present then it will take a full CV to
8255        store it.  */
8256     const I32 gv_fetch_flags
8257         = ec ? GV_NOADD_NOINIT :
8258         (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
8259         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
8260     STRLEN namlen = 0;
8261     const char * const name =
8262          o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
8263     bool has_name;
8264     bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
8265     bool evanescent = FALSE;
8266     OP *start = NULL;
8267 #ifdef PERL_DEBUG_READONLY_OPS
8268     OPSLAB *slab = NULL;
8269 #endif
8270
8271     if (o_is_gv) {
8272         gv = (GV*)o;
8273         o = NULL;
8274         has_name = TRUE;
8275     } else if (name) {
8276         /* Try to optimise and avoid creating a GV.  Instead, the CV’s name
8277            hek and CvSTASH pointer together can imply the GV.  If the name
8278            contains a package name, then GvSTASH(CvGV(cv)) may differ from
8279            CvSTASH, so forego the optimisation if we find any.
8280            Also, we may be called from load_module at run time, so
8281            PL_curstash (which sets CvSTASH) may not point to the stash the
8282            sub is stored in.  */
8283         const I32 flags =
8284            ec ? GV_NOADD_NOINIT
8285               :   PL_curstash != CopSTASH(PL_curcop)
8286                || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
8287                     ? gv_fetch_flags
8288                     : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
8289         gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
8290         has_name = TRUE;
8291     } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
8292         SV * const sv = sv_newmortal();
8293         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
8294                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
8295                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
8296         gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
8297         has_name = TRUE;
8298     } else if (PL_curstash) {
8299         gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
8300         has_name = FALSE;
8301     } else {
8302         gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
8303         has_name = FALSE;
8304     }
8305     if (!ec) {
8306         if (isGV(gv)) {
8307             move_proto_attr(&proto, &attrs, gv);
8308         } else {
8309             assert(cSVOPo);
8310             move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv);
8311         }
8312     }
8313
8314     if (proto) {
8315         assert(proto->op_type == OP_CONST);
8316         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
8317         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
8318     }
8319     else
8320         ps = NULL;
8321
8322     if (o)
8323         SAVEFREEOP(o);
8324     if (proto)
8325         SAVEFREEOP(proto);
8326     if (attrs)
8327         SAVEFREEOP(attrs);
8328
8329     if (ec) {
8330         op_free(block);
8331         if (name) SvREFCNT_dec(PL_compcv);
8332         else cv = PL_compcv;
8333         PL_compcv = 0;
8334         if (name && block) {
8335             const char *s = strrchr(name, ':');
8336             s = s ? s+1 : name;
8337             if (strEQ(s, "BEGIN")) {
8338                 if (PL_in_eval & EVAL_KEEPERR)
8339                     Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
8340                 else {
8341                     SV * const errsv = ERRSV;
8342                     /* force display of errors found but not reported */
8343                     sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
8344                     Perl_croak_nocontext("%"SVf, SVfARG(errsv));
8345                 }
8346             }
8347         }
8348         goto done;
8349     }
8350
8351     if (!block && SvTYPE(gv) != SVt_PVGV) {
8352       /* If we are not defining a new sub and the existing one is not a
8353          full GV + CV... */
8354       if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
8355         /* We are applying attributes to an existing sub, so we need it
8356            upgraded if it is a constant.  */
8357         if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
8358             gv_init_pvn(gv, PL_curstash, name, namlen,
8359                         SVf_UTF8 * name_is_utf8);
8360       }
8361       else {                    /* Maybe prototype now, and had at maximum
8362                                    a prototype or const/sub ref before.  */
8363         if (SvTYPE(gv) > SVt_NULL) {
8364             cv_ckproto_len_flags((const CV *)gv,
8365                                  o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8366                                  ps_len, ps_utf8);
8367         }
8368         if (!SvROK(gv)) {
8369           if (ps) {
8370             sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
8371             if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
8372           }
8373           else
8374             sv_setiv(MUTABLE_SV(gv), -1);
8375         }
8376
8377         SvREFCNT_dec(PL_compcv);
8378         cv = PL_compcv = NULL;
8379         goto done;
8380       }
8381     }
8382
8383     cv = (!name || (isGV(gv) && GvCVGEN(gv)))
8384         ? NULL
8385         : isGV(gv)
8386             ? GvCV(gv)
8387             : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
8388                 ? (CV *)SvRV(gv)
8389                 : NULL;
8390
8391     if (block) {
8392         /* This makes sub {}; work as expected.  */
8393         if (block->op_type == OP_STUB) {
8394             const line_t l = PL_parser->copline;
8395             op_free(block);
8396             block = newSTATEOP(0, NULL, 0);
8397             PL_parser->copline = l;
8398         }
8399         block = CvLVALUE(PL_compcv)
8400              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
8401                     && (!isGV(gv) || !GvASSUMECV(gv)))
8402                    ? newUNOP(OP_LEAVESUBLV, 0,
8403                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
8404                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
8405         start = LINKLIST(block);
8406         block->op_next = 0;
8407         if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
8408             const_sv =
8409                 S_op_const_sv(aTHX_ start, PL_compcv,
8410                                         cBOOL(CvCLONE(PL_compcv)));
8411         else
8412             const_sv = NULL;
8413     }
8414     else
8415         const_sv = NULL;
8416
8417     if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
8418         cv_ckproto_len_flags((const CV *)gv,
8419                              o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8420                              ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
8421         if (SvROK(gv)) {
8422             /* All the other code for sub redefinition warnings expects the
8423                clobbered sub to be a CV.  Instead of making all those code
8424                paths more complex, just inline the RV version here.  */
8425             const line_t oldline = CopLINE(PL_curcop);
8426             assert(IN_PERL_COMPILETIME);
8427             if (PL_parser && PL_parser->copline != NOLINE)
8428                 /* This ensures that warnings are reported at the first
8429                    line of a redefinition, not the last.  */
8430                 CopLINE_set(PL_curcop, PL_parser->copline);
8431             /* protect against fatal warnings leaking compcv */
8432             SAVEFREESV(PL_compcv);
8433
8434             if (ckWARN(WARN_REDEFINE)
8435              || (  ckWARN_d(WARN_REDEFINE)
8436                 && (  !const_sv || SvRV(gv) == const_sv
8437                    || sv_cmp(SvRV(gv), const_sv)  )))
8438                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8439                           "Constant subroutine %"SVf" redefined",
8440                           SVfARG(cSVOPo->op_sv));
8441
8442             SvREFCNT_inc_simple_void_NN(PL_compcv);
8443             CopLINE_set(PL_curcop, oldline);
8444             SvREFCNT_dec(SvRV(gv));
8445         }
8446     }
8447
8448     if (cv) {
8449         const bool exists = CvROOT(cv) || CvXSUB(cv);
8450
8451         /* if the subroutine doesn't exist and wasn't pre-declared
8452          * with a prototype, assume it will be AUTOLOADed,
8453          * skipping the prototype check
8454          */
8455         if (exists || SvPOK(cv))
8456             cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
8457         /* already defined (or promised)? */
8458         if (exists || (isGV(gv) && GvASSUMECV(gv))) {
8459             if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv))
8460                 cv = NULL;
8461             else {
8462                 if (attrs) goto attrs;
8463                 /* just a "sub foo;" when &foo is already defined */
8464                 SAVEFREESV(PL_compcv);
8465                 goto done;
8466             }
8467         }
8468     }
8469     if (const_sv) {
8470         SvREFCNT_inc_simple_void_NN(const_sv);
8471         SvFLAGS(const_sv) |= SVs_PADTMP;
8472         if (cv) {
8473             assert(!CvROOT(cv) && !CvCONST(cv));
8474             cv_forget_slab(cv);
8475             sv_setpvs(MUTABLE_SV(cv), "");  /* prototype is "" */
8476             CvXSUBANY(cv).any_ptr = const_sv;
8477             CvXSUB(cv) = const_sv_xsub;
8478             CvCONST_on(cv);
8479             CvISXSUB_on(cv);
8480             PoisonPADLIST(cv);
8481             CvFLAGS(cv) |= CvMETHOD(PL_compcv);
8482         }
8483         else {
8484             if (isGV(gv) || CvMETHOD(PL_compcv)) {
8485                 if (name && isGV(gv))
8486                     GvCV_set(gv, NULL);
8487                 cv = newCONSTSUB_flags(
8488                     NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
8489                     const_sv
8490                 );
8491                 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
8492             }
8493             else {
8494                 if (!SvROK(gv)) {
8495                     SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8496                     prepare_SV_for_RV((SV *)gv);
8497                     SvOK_off((SV *)gv);
8498                     SvROK_on(gv);
8499                 }
8500                 SvRV_set(gv, const_sv);
8501             }
8502         }
8503         op_free(block);
8504         SvREFCNT_dec(PL_compcv);
8505         PL_compcv = NULL;
8506         goto done;
8507     }
8508     if (cv) {                           /* must reuse cv if autoloaded */
8509         /* transfer PL_compcv to cv */
8510         if (block
8511         ) {
8512             cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
8513             PADLIST *const temp_av = CvPADLIST(cv);
8514             CV *const temp_cv = CvOUTSIDE(cv);
8515             const cv_flags_t other_flags =
8516                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8517             OP * const cvstart = CvSTART(cv);
8518
8519             if (isGV(gv)) {
8520                 CvGV_set(cv,gv);
8521                 assert(!CvCVGV_RC(cv));
8522                 assert(CvGV(cv) == gv);
8523             }
8524             else {
8525                 dVAR;
8526                 U32 hash;
8527                 PERL_HASH(hash, name, namlen);
8528                 CvNAME_HEK_set(cv,
8529                                share_hek(name,
8530                                          name_is_utf8
8531                                             ? -(SSize_t)namlen
8532                                             :  (SSize_t)namlen,
8533                                          hash));
8534             }
8535
8536             SvPOK_off(cv);
8537             CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
8538                                              | CvNAMED(cv);
8539             CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
8540             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
8541             CvPADLIST_set(cv,CvPADLIST(PL_compcv));
8542             CvOUTSIDE(PL_compcv) = temp_cv;
8543             CvPADLIST_set(PL_compcv, temp_av);
8544             CvSTART(cv) = CvSTART(PL_compcv);
8545             CvSTART(PL_compcv) = cvstart;
8546             CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8547             CvFLAGS(PL_compcv) |= other_flags;
8548
8549             if (CvFILE(cv) && CvDYNFILE(cv)) {
8550                 Safefree(CvFILE(cv));
8551     }
8552             CvFILE_set_from_cop(cv, PL_curcop);
8553             CvSTASH_set(cv, PL_curstash);
8554
8555             /* inner references to PL_compcv must be fixed up ... */
8556             pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
8557             if (PERLDB_INTER)/* Advice debugger on the new sub. */
8558               ++PL_sub_generation;
8559         }
8560         else {
8561             /* Might have had built-in attributes applied -- propagate them. */
8562             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
8563         }
8564         /* ... before we throw it away */
8565         SvREFCNT_dec(PL_compcv);
8566         PL_compcv = cv;
8567     }
8568     else {
8569         cv = PL_compcv;
8570         if (name && isGV(gv)) {
8571             GvCV_set(gv, cv);
8572             GvCVGEN(gv) = 0;
8573             if (HvENAME_HEK(GvSTASH(gv)))
8574                 /* sub Foo::bar { (shift)+1 } */
8575                 gv_method_changed(gv);
8576         }
8577         else if (name) {
8578             if (!SvROK(gv)) {
8579                 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8580                 prepare_SV_for_RV((SV *)gv);
8581                 SvOK_off((SV *)gv);
8582                 SvROK_on(gv);
8583             }
8584             SvRV_set(gv, (SV *)cv);
8585         }
8586     }
8587     if (!CvHASGV(cv)) {
8588         if (isGV(gv)) CvGV_set(cv, gv);
8589         else {
8590             dVAR;
8591             U32 hash;
8592             PERL_HASH(hash, name, namlen);
8593             CvNAME_HEK_set(cv, share_hek(name,
8594                                          name_is_utf8
8595                                             ? -(SSize_t)namlen
8596                                             :  (SSize_t)namlen,
8597                                          hash));
8598         }
8599         CvFILE_set_from_cop(cv, PL_curcop);
8600         CvSTASH_set(cv, PL_curstash);
8601     }
8602
8603     if (ps) {
8604         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8605         if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
8606     }
8607
8608     if (!block)
8609         goto attrs;
8610
8611     /* If we assign an optree to a PVCV, then we've defined a subroutine that
8612        the debugger could be able to set a breakpoint in, so signal to
8613        pp_entereval that it should not throw away any saved lines at scope
8614        exit.  */
8615
8616     PL_breakable_sub_gen++;
8617     CvROOT(cv) = block;
8618     CvROOT(cv)->op_private |= OPpREFCOUNTED;
8619     OpREFCNT_set(CvROOT(cv), 1);
8620     /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8621        itself has a refcount. */
8622     CvSLABBED_off(cv);
8623     OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8624 #ifdef PERL_DEBUG_READONLY_OPS
8625     slab = (OPSLAB *)CvSTART(cv);
8626 #endif
8627     CvSTART(cv) = start;
8628     CALL_PEEP(start);
8629     finalize_optree(CvROOT(cv));
8630     S_prune_chain_head(&CvSTART(cv));
8631
8632     /* now that optimizer has done its work, adjust pad values */
8633
8634     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8635
8636   attrs:
8637     if (attrs) {
8638         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8639         HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
8640                         ? GvSTASH(CvGV(cv))
8641                         : PL_curstash;
8642         if (!name) SAVEFREESV(cv);
8643         apply_attrs(stash, MUTABLE_SV(cv), attrs);
8644         if (!name) SvREFCNT_inc_simple_void_NN(cv);
8645     }
8646
8647     if (block && has_name) {
8648         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8649             SV * const tmpstr = cv_name(cv,NULL,0);
8650             GV * const db_postponed = gv_fetchpvs("DB::postponed",
8651                                                   GV_ADDMULTI, SVt_PVHV);
8652             HV *hv;
8653             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8654                                           CopFILE(PL_curcop),
8655                                           (long)PL_subline,
8656                                           (long)CopLINE(PL_curcop));
8657             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8658                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8659             hv = GvHVn(db_postponed);
8660             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8661                 CV * const pcv = GvCV(db_postponed);
8662                 if (pcv) {
8663                     dSP;
8664                     PUSHMARK(SP);
8665                     XPUSHs(tmpstr);
8666                     PUTBACK;
8667                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
8668                 }
8669             }
8670         }
8671
8672         if (name) {
8673             if (PL_parser && PL_parser->error_count)
8674                 clear_special_blocks(name, gv, cv);
8675             else
8676                 evanescent =
8677                     process_special_blocks(floor, name, gv, cv);
8678         }
8679     }
8680
8681   done:
8682     if (PL_parser)
8683         PL_parser->copline = NOLINE;
8684     LEAVE_SCOPE(floor);
8685     if (!evanescent) {
8686 #ifdef PERL_DEBUG_READONLY_OPS
8687       if (slab)
8688         Slab_to_ro(slab);
8689 #endif
8690       if (cv && name && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
8691         pad_add_weakref(cv);
8692     }
8693     return cv;
8694 }
8695
8696 STATIC void
8697 S_clear_special_blocks(pTHX_ const char *const fullname,
8698                        GV *const gv, CV *const cv) {
8699     const char *colon;
8700     const char *name;
8701
8702     PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
8703
8704     colon = strrchr(fullname,':');
8705     name = colon ? colon + 1 : fullname;
8706
8707     if ((*name == 'B' && strEQ(name, "BEGIN"))
8708         || (*name == 'E' && strEQ(name, "END"))
8709         || (*name == 'U' && strEQ(name, "UNITCHECK"))
8710         || (*name == 'C' && strEQ(name, "CHECK"))
8711         || (*name == 'I' && strEQ(name, "INIT"))) {
8712         if (!isGV(gv)) {
8713             (void)CvGV(cv);
8714             assert(isGV(gv));
8715         }
8716         GvCV_set(gv, NULL);
8717         SvREFCNT_dec_NN(MUTABLE_SV(cv));
8718     }
8719 }
8720
8721 /* Returns true if the sub has been freed.  */
8722 STATIC bool
8723 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
8724                          GV *const gv,
8725                          CV *const cv)
8726 {
8727     const char *const colon = strrchr(fullname,':');
8728     const char *const name = colon ? colon + 1 : fullname;
8729
8730     PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
8731
8732     if (*name == 'B') {
8733         if (strEQ(name, "BEGIN")) {
8734             const I32 oldscope = PL_scopestack_ix;
8735             dSP;
8736             (void)CvGV(cv);
8737             if (floor) LEAVE_SCOPE(floor);
8738             ENTER;
8739             PUSHSTACKi(PERLSI_REQUIRE);
8740             SAVECOPFILE(&PL_compiling);
8741             SAVECOPLINE(&PL_compiling);
8742             SAVEVPTR(PL_curcop);
8743
8744             DEBUG_x( dump_sub(gv) );
8745             Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
8746             GvCV_set(gv,0);             /* cv has been hijacked */
8747             call_list(oldscope, PL_beginav);
8748
8749             POPSTACK;
8750             LEAVE;
8751             return !PL_savebegin;
8752         }
8753         else
8754             return FALSE;
8755     } else {
8756         if (*name == 'E') {
8757             if strEQ(name, "END") {
8758                 DEBUG_x( dump_sub(gv) );
8759                 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
8760             } else
8761                 return FALSE;
8762         } else if (*name == 'U') {
8763             if (strEQ(name, "UNITCHECK")) {
8764                 /* It's never too late to run a unitcheck block */
8765                 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
8766             }
8767             else
8768                 return FALSE;
8769         } else if (*name == 'C') {
8770             if (strEQ(name, "CHECK")) {
8771                 if (PL_main_start)
8772                     /* diag_listed_as: Too late to run %s block */
8773                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8774                                    "Too late to run CHECK block");
8775                 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
8776             }
8777             else
8778                 return FALSE;
8779         } else if (*name == 'I') {
8780             if (strEQ(name, "INIT")) {
8781                 if (PL_main_start)
8782                     /* diag_listed_as: Too late to run %s block */
8783                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8784                                    "Too late to run INIT block");
8785                 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
8786             }
8787             else
8788                 return FALSE;
8789         } else
8790             return FALSE;
8791         DEBUG_x( dump_sub(gv) );
8792         (void)CvGV(cv);
8793         GvCV_set(gv,0);         /* cv has been hijacked */
8794         return FALSE;
8795     }
8796 }
8797
8798 /*
8799 =for apidoc newCONSTSUB
8800
8801 See L</newCONSTSUB_flags>.
8802
8803 =cut
8804 */
8805
8806 CV *
8807 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
8808 {
8809     return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
8810 }
8811
8812 /*
8813 =for apidoc newCONSTSUB_flags
8814
8815 Creates a constant sub equivalent to Perl S<C<sub FOO () { 123 }>> which is
8816 eligible for inlining at compile-time.
8817
8818 Currently, the only useful value for C<flags> is C<SVf_UTF8>.
8819
8820 The newly created subroutine takes ownership of a reference to the passed in
8821 SV.
8822
8823 Passing C<NULL> for SV creates a constant sub equivalent to S<C<sub BAR () {}>>,
8824 which won't be called if used as a destructor, but will suppress the overhead
8825 of a call to C<AUTOLOAD>.  (This form, however, isn't eligible for inlining at
8826 compile time.)
8827
8828 =cut
8829 */
8830
8831 CV *
8832 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
8833                              U32 flags, SV *sv)
8834 {
8835     CV* cv;
8836     const char *const file = CopFILE(PL_curcop);
8837
8838     ENTER;
8839
8840     if (IN_PERL_RUNTIME) {
8841         /* at runtime, it's not safe to manipulate PL_curcop: it may be
8842          * an op shared between threads. Use a non-shared COP for our
8843          * dirty work */
8844          SAVEVPTR(PL_curcop);
8845          SAVECOMPILEWARNINGS();
8846          PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
8847          PL_curcop = &PL_compiling;
8848     }
8849     SAVECOPLINE(PL_curcop);
8850     CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
8851
8852     SAVEHINTS();
8853     PL_hints &= ~HINT_BLOCK_SCOPE;
8854
8855     if (stash) {
8856         SAVEGENERICSV(PL_curstash);
8857         PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
8858     }
8859
8860     /* Protect sv against leakage caused by fatal warnings. */
8861     if (sv) SAVEFREESV(sv);
8862
8863     /* file becomes the CvFILE. For an XS, it's usually static storage,
8864        and so doesn't get free()d.  (It's expected to be from the C pre-
8865        processor __FILE__ directive). But we need a dynamically allocated one,
8866        and we need it to get freed.  */
8867     cv = newXS_len_flags(name, len,
8868                          sv && SvTYPE(sv) == SVt_PVAV
8869                              ? const_av_xsub
8870                              : const_sv_xsub,
8871                          file ? file : "", "",
8872                          &sv, XS_DYNAMIC_FILENAME | flags);
8873     CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
8874     CvCONST_on(cv);
8875
8876     LEAVE;
8877
8878     return cv;
8879 }
8880
8881 /*
8882 =for apidoc U||newXS
8883
8884 Used by C<xsubpp> to hook up XSUBs as Perl subs.  C<filename> needs to be
8885 static storage, as it is used directly as CvFILE(), without a copy being made.
8886
8887 =cut
8888 */
8889
8890 CV *
8891 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
8892 {
8893     PERL_ARGS_ASSERT_NEWXS;
8894     return newXS_len_flags(
8895         name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
8896     );
8897 }
8898
8899 CV *
8900 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
8901                  const char *const filename, const char *const proto,
8902                  U32 flags)
8903 {
8904     PERL_ARGS_ASSERT_NEWXS_FLAGS;
8905     return newXS_len_flags(
8906        name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
8907     );
8908 }
8909
8910 CV *
8911 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
8912 {
8913     PERL_ARGS_ASSERT_NEWXS_DEFFILE;
8914     return newXS_len_flags(
8915         name, strlen(name), subaddr, NULL, NULL, NULL, 0
8916     );
8917 }
8918
8919 CV *
8920 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
8921                            XSUBADDR_t subaddr, const char *const filename,
8922                            const char *const proto, SV **const_svp,
8923                            U32 flags)
8924 {
8925     CV *cv;
8926     bool interleave = FALSE;
8927
8928     PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
8929
8930     {
8931         GV * const gv = gv_fetchpvn(
8932                             name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
8933                             name ? len : PL_curstash ? sizeof("__ANON__") - 1:
8934                                 sizeof("__ANON__::__ANON__") - 1,
8935                             GV_ADDMULTI | flags, SVt_PVCV);
8936
8937         if ((cv = (name ? GvCV(gv) : NULL))) {
8938             if (GvCVGEN(gv)) {
8939                 /* just a cached method */
8940                 SvREFCNT_dec(cv);
8941                 cv = NULL;
8942             }
8943             else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
8944                 /* already defined (or promised) */
8945                 /* Redundant check that allows us to avoid creating an SV
8946                    most of the time: */
8947                 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
8948                     report_redefined_cv(newSVpvn_flags(
8949                                          name,len,(flags&SVf_UTF8)|SVs_TEMP
8950                                         ),
8951                                         cv, const_svp);
8952                 }
8953                 interleave = TRUE;
8954                 ENTER;
8955                 SAVEFREESV(cv);
8956                 cv = NULL;
8957             }
8958         }
8959
8960         if (cv)                         /* must reuse cv if autoloaded */
8961             cv_undef(cv);
8962         else {
8963             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8964             if (name) {
8965                 GvCV_set(gv,cv);
8966                 GvCVGEN(gv) = 0;
8967                 if (HvENAME_HEK(GvSTASH(gv)))
8968                     gv_method_changed(gv); /* newXS */
8969             }
8970         }
8971
8972         CvGV_set(cv, gv);
8973         if(filename) {
8974             /* XSUBs can't be perl lang/perl5db.pl debugged
8975             if (PERLDB_LINE_OR_SAVESRC)
8976                 (void)gv_fetchfile(filename); */
8977             assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
8978             if (flags & XS_DYNAMIC_FILENAME) {
8979                 CvDYNFILE_on(cv);
8980                 CvFILE(cv) = savepv(filename);
8981             } else {
8982             /* NOTE: not copied, as it is expected to be an external constant string */
8983                 CvFILE(cv) = (char *)filename;
8984             }
8985         } else {
8986             assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
8987             CvFILE(cv) = (char*)PL_xsubfilename;
8988         }
8989         CvISXSUB_on(cv);
8990         CvXSUB(cv) = subaddr;
8991 #ifndef PERL_IMPLICIT_CONTEXT
8992         CvHSCXT(cv) = &PL_stack_sp;
8993 #else
8994         PoisonPADLIST(cv);
8995 #endif
8996
8997         if (name)
8998             process_special_blocks(0, name, gv, cv);
8999         else
9000             CvANON_on(cv);
9001     } /* <- not a conditional branch */
9002
9003
9004     sv_setpv(MUTABLE_SV(cv), proto);
9005     if (interleave) LEAVE;
9006     return cv;
9007 }
9008
9009 CV *
9010 Perl_newSTUB(pTHX_ GV *gv, bool fake)
9011 {
9012     CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9013     GV *cvgv;
9014     PERL_ARGS_ASSERT_NEWSTUB;
9015     assert(!GvCVu(gv));
9016     GvCV_set(gv, cv);
9017     GvCVGEN(gv) = 0;
9018     if (!fake && HvENAME_HEK(GvSTASH(gv)))
9019         gv_method_changed(gv);
9020     if (SvFAKE(gv)) {
9021         cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
9022         SvFAKE_off(cvgv);
9023     }
9024     else cvgv = gv;
9025     CvGV_set(cv, cvgv);
9026     CvFILE_set_from_cop(cv, PL_curcop);
9027     CvSTASH_set(cv, PL_curstash);
9028     GvMULTI_on(gv);
9029     return cv;
9030 }
9031
9032 void
9033 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
9034 {
9035     CV *cv;
9036
9037     GV *gv;
9038
9039     if (PL_parser && PL_parser->error_count) {
9040         op_free(block);
9041         goto finish;
9042     }
9043
9044     gv = o
9045         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
9046         : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
9047
9048     GvMULTI_on(gv);
9049     if ((cv = GvFORM(gv))) {
9050         if (ckWARN(WARN_REDEFINE)) {
9051             const line_t oldline = CopLINE(PL_curcop);
9052             if (PL_parser && PL_parser->copline != NOLINE)
9053                 CopLINE_set(PL_curcop, PL_parser->copline);
9054             if (o) {
9055                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9056                             "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
9057             } else {
9058                 /* diag_listed_as: Format %s redefined */
9059                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9060                             "Format STDOUT redefined");
9061             }
9062             CopLINE_set(PL_curcop, oldline);
9063         }
9064         SvREFCNT_dec(cv);
9065     }
9066     cv = PL_compcv;
9067     GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
9068     CvGV_set(cv, gv);
9069     CvFILE_set_from_cop(cv, PL_curcop);
9070
9071
9072     pad_tidy(padtidy_FORMAT);
9073     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
9074     CvROOT(cv)->op_private |= OPpREFCOUNTED;
9075     OpREFCNT_set(CvROOT(cv), 1);
9076     CvSTART(cv) = LINKLIST(CvROOT(cv));
9077     CvROOT(cv)->op_next = 0;
9078     CALL_PEEP(CvSTART(cv));
9079     finalize_optree(CvROOT(cv));
9080     S_prune_chain_head(&CvSTART(cv));
9081     cv_forget_slab(cv);
9082
9083   finish:
9084     op_free(o);
9085     if (PL_parser)
9086         PL_parser->copline = NOLINE;
9087     LEAVE_SCOPE(floor);
9088     PL_compiling.cop_seq = 0;
9089 }
9090
9091 OP *
9092 Perl_newANONLIST(pTHX_ OP *o)
9093 {
9094     return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
9095 }
9096
9097 OP *
9098 Perl_newANONHASH(pTHX_ OP *o)
9099 {
9100     return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
9101 }
9102
9103 OP *
9104 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
9105 {
9106     return newANONATTRSUB(floor, proto, NULL, block);
9107 }
9108
9109 OP *
9110 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
9111 {
9112     SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
9113     OP * anoncode =
9114         newSVOP(OP_ANONCODE, 0,
9115                 cv);
9116     if (CvANONCONST(cv))
9117         anoncode = newUNOP(OP_ANONCONST, 0,
9118                            op_convert_list(OP_ENTERSUB,
9119                                            OPf_STACKED|OPf_WANT_SCALAR,
9120                                            anoncode));
9121     return newUNOP(OP_REFGEN, 0, anoncode);
9122 }
9123
9124 OP *
9125 Perl_oopsAV(pTHX_ OP *o)
9126 {
9127     dVAR;
9128
9129     PERL_ARGS_ASSERT_OOPSAV;
9130
9131     switch (o->op_type) {
9132     case OP_PADSV:
9133     case OP_PADHV:
9134         OpTYPE_set(o, OP_PADAV);
9135         return ref(o, OP_RV2AV);
9136
9137     case OP_RV2SV:
9138     case OP_RV2HV:
9139         OpTYPE_set(o, OP_RV2AV);
9140         ref(o, OP_RV2AV);
9141         break;
9142
9143     default:
9144         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
9145         break;
9146     }
9147     return o;
9148 }
9149
9150 OP *
9151 Perl_oopsHV(pTHX_ OP *o)
9152 {
9153     dVAR;
9154
9155     PERL_ARGS_ASSERT_OOPSHV;
9156
9157     switch (o->op_type) {
9158     case OP_PADSV:
9159     case OP_PADAV:
9160         OpTYPE_set(o, OP_PADHV);
9161         return ref(o, OP_RV2HV);
9162
9163     case OP_RV2SV:
9164     case OP_RV2AV:
9165         OpTYPE_set(o, OP_RV2HV);
9166         ref(o, OP_RV2HV);
9167         break;
9168
9169     default:
9170         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
9171         break;
9172     }
9173     return o;
9174 }
9175
9176 OP *
9177 Perl_newAVREF(pTHX_ OP *o)
9178 {
9179     dVAR;
9180
9181     PERL_ARGS_ASSERT_NEWAVREF;
9182
9183     if (o->op_type == OP_PADANY) {
9184         OpTYPE_set(o, OP_PADAV);
9185         return o;
9186     }
9187     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
9188         Perl_croak(aTHX_ "Can't use an array as a reference");
9189     }
9190     return newUNOP(OP_RV2AV, 0, scalar(o));
9191 }
9192
9193 OP *
9194 Perl_newGVREF(pTHX_ I32 type, OP *o)
9195 {
9196     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
9197         return newUNOP(OP_NULL, 0, o);
9198     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
9199 }
9200
9201 OP *
9202 Perl_newHVREF(pTHX_ OP *o)
9203 {
9204     dVAR;
9205
9206     PERL_ARGS_ASSERT_NEWHVREF;
9207
9208     if (o->op_type == OP_PADANY) {
9209         OpTYPE_set(o, OP_PADHV);
9210         return o;
9211     }
9212     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
9213         Perl_croak(aTHX_ "Can't use a hash as a reference");
9214     }
9215     return newUNOP(OP_RV2HV, 0, scalar(o));
9216 }
9217
9218 OP *
9219 Perl_newCVREF(pTHX_ I32 flags, OP *o)
9220 {
9221     if (o->op_type == OP_PADANY) {
9222         dVAR;
9223         OpTYPE_set(o, OP_PADCV);
9224     }
9225     return newUNOP(OP_RV2CV, flags, scalar(o));
9226 }
9227
9228 OP *
9229 Perl_newSVREF(pTHX_ OP *o)
9230 {
9231     dVAR;
9232
9233     PERL_ARGS_ASSERT_NEWSVREF;
9234
9235     if (o->op_type == OP_PADANY) {
9236         OpTYPE_set(o, OP_PADSV);
9237         scalar(o);
9238         return o;
9239     }
9240     return newUNOP(OP_RV2SV, 0, scalar(o));
9241 }
9242
9243 /* Check routines. See the comments at the top of this file for details
9244  * on when these are called */
9245
9246 OP *
9247 Perl_ck_anoncode(pTHX_ OP *o)
9248 {
9249     PERL_ARGS_ASSERT_CK_ANONCODE;
9250
9251     cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
9252     cSVOPo->op_sv = NULL;
9253     return o;
9254 }
9255
9256 static void
9257 S_io_hints(pTHX_ OP *o)
9258 {
9259 #if O_BINARY != 0 || O_TEXT != 0
9260     HV * const table =
9261         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
9262     if (table) {
9263         SV **svp = hv_fetchs(table, "open_IN", FALSE);
9264         if (svp && *svp) {
9265             STRLEN len = 0;
9266             const char *d = SvPV_const(*svp, len);
9267             const I32 mode = mode_from_discipline(d, len);
9268             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9269 #  if O_BINARY != 0
9270             if (mode & O_BINARY)
9271                 o->op_private |= OPpOPEN_IN_RAW;
9272 #  endif
9273 #  if O_TEXT != 0
9274             if (mode & O_TEXT)
9275                 o->op_private |= OPpOPEN_IN_CRLF;
9276 #  endif
9277         }
9278
9279         svp = hv_fetchs(table, "open_OUT", FALSE);
9280         if (svp && *svp) {
9281             STRLEN len = 0;
9282             const char *d = SvPV_const(*svp, len);
9283             const I32 mode = mode_from_discipline(d, len);
9284             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9285 #  if O_BINARY != 0
9286             if (mode & O_BINARY)
9287                 o->op_private |= OPpOPEN_OUT_RAW;
9288 #  endif
9289 #  if O_TEXT != 0
9290             if (mode & O_TEXT)
9291                 o->op_private |= OPpOPEN_OUT_CRLF;
9292 #  endif
9293         }
9294     }
9295 #else
9296     PERL_UNUSED_CONTEXT;
9297     PERL_UNUSED_ARG(o);
9298 #endif
9299 }
9300
9301 OP *
9302 Perl_ck_backtick(pTHX_ OP *o)
9303 {
9304     GV *gv;
9305     OP *newop = NULL;
9306     OP *sibl;
9307     PERL_ARGS_ASSERT_CK_BACKTICK;
9308     /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
9309     if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
9310      && (gv = gv_override("readpipe",8)))
9311     {
9312         /* detach rest of siblings from o and its first child */
9313         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
9314         newop = S_new_entersubop(aTHX_ gv, sibl);
9315     }
9316     else if (!(o->op_flags & OPf_KIDS))
9317         newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
9318     if (newop) {
9319         op_free(o);
9320         return newop;
9321     }
9322     S_io_hints(aTHX_ o);
9323     return o;
9324 }
9325
9326 OP *
9327 Perl_ck_bitop(pTHX_ OP *o)
9328 {
9329     PERL_ARGS_ASSERT_CK_BITOP;
9330
9331     o->op_private = (U8)(PL_hints & HINT_INTEGER);
9332
9333     if (o->op_type == OP_NBIT_OR     || o->op_type == OP_SBIT_OR
9334      || o->op_type == OP_NBIT_XOR    || o->op_type == OP_SBIT_XOR
9335      || o->op_type == OP_NBIT_AND    || o->op_type == OP_SBIT_AND
9336      || o->op_type == OP_NCOMPLEMENT || o->op_type == OP_SCOMPLEMENT)
9337         Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__BITWISE),
9338                               "The bitwise feature is experimental");
9339     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
9340             && OP_IS_INFIX_BIT(o->op_type))
9341     {
9342         const OP * const left = cBINOPo->op_first;
9343         const OP * const right = OpSIBLING(left);
9344         if ((OP_IS_NUMCOMPARE(left->op_type) &&
9345                 (left->op_flags & OPf_PARENS) == 0) ||
9346             (OP_IS_NUMCOMPARE(right->op_type) &&
9347                 (right->op_flags & OPf_PARENS) == 0))
9348             Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
9349                           "Possible precedence problem on bitwise %s operator",
9350                            o->op_type ==  OP_BIT_OR
9351                          ||o->op_type == OP_NBIT_OR  ? "|"
9352                         :  o->op_type ==  OP_BIT_AND
9353                          ||o->op_type == OP_NBIT_AND ? "&"
9354                         :  o->op_type ==  OP_BIT_XOR
9355                          ||o->op_type == OP_NBIT_XOR ? "^"
9356                         :  o->op_type == OP_SBIT_OR  ? "|."
9357                         :  o->op_type == OP_SBIT_AND ? "&." : "^."
9358                            );
9359     }
9360     return o;
9361 }
9362
9363 PERL_STATIC_INLINE bool
9364 is_dollar_bracket(pTHX_ const OP * const o)
9365 {
9366     const OP *kid;
9367     PERL_UNUSED_CONTEXT;
9368     return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
9369         && (kid = cUNOPx(o)->op_first)
9370         && kid->op_type == OP_GV
9371         && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
9372 }
9373
9374 OP *
9375 Perl_ck_cmp(pTHX_ OP *o)
9376 {
9377     PERL_ARGS_ASSERT_CK_CMP;
9378     if (ckWARN(WARN_SYNTAX)) {
9379         const OP *kid = cUNOPo->op_first;
9380         if (kid &&
9381             (
9382                 (   is_dollar_bracket(aTHX_ kid)
9383                  && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
9384                 )
9385              || (   kid->op_type == OP_CONST
9386                  && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
9387                 )
9388            )
9389         )
9390             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9391                         "$[ used in %s (did you mean $] ?)", OP_DESC(o));
9392     }
9393     return o;
9394 }
9395
9396 OP *
9397 Perl_ck_concat(pTHX_ OP *o)
9398 {
9399     const OP * const kid = cUNOPo->op_first;
9400
9401     PERL_ARGS_ASSERT_CK_CONCAT;
9402     PERL_UNUSED_CONTEXT;
9403
9404     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
9405             !(kUNOP->op_first->op_flags & OPf_MOD))
9406         o->op_flags |= OPf_STACKED;
9407     return o;
9408 }
9409
9410 OP *
9411 Perl_ck_spair(pTHX_ OP *o)
9412 {
9413     dVAR;
9414
9415     PERL_ARGS_ASSERT_CK_SPAIR;
9416
9417     if (o->op_flags & OPf_KIDS) {
9418         OP* newop;
9419         OP* kid;
9420         OP* kidkid;
9421         const OPCODE type = o->op_type;
9422         o = modkids(ck_fun(o), type);
9423         kid    = cUNOPo->op_first;
9424         kidkid = kUNOP->op_first;
9425         newop = OpSIBLING(kidkid);
9426         if (newop) {
9427             const OPCODE type = newop->op_type;
9428             if (OpHAS_SIBLING(newop))
9429                 return o;
9430             if (o->op_type == OP_REFGEN
9431              && (  type == OP_RV2CV
9432                 || (  !(newop->op_flags & OPf_PARENS)
9433                    && (  type == OP_RV2AV || type == OP_PADAV
9434                       || type == OP_RV2HV || type == OP_PADHV))))
9435                 NOOP; /* OK (allow srefgen for \@a and \%h) */
9436             else if (OP_GIMME(newop,0) != G_SCALAR)
9437                 return o;
9438         }
9439         /* excise first sibling */
9440         op_sibling_splice(kid, NULL, 1, NULL);
9441         op_free(kidkid);
9442     }
9443     /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
9444      * and OP_CHOMP into OP_SCHOMP */
9445     o->op_ppaddr = PL_ppaddr[++o->op_type];
9446     return ck_fun(o);
9447 }
9448
9449 OP *
9450 Perl_ck_delete(pTHX_ OP *o)
9451 {
9452     PERL_ARGS_ASSERT_CK_DELETE;
9453
9454     o = ck_fun(o);
9455     o->op_private = 0;
9456     if (o->op_flags & OPf_KIDS) {
9457         OP * const kid = cUNOPo->op_first;
9458         switch (kid->op_type) {
9459         case OP_ASLICE:
9460             o->op_flags |= OPf_SPECIAL;
9461             /* FALLTHROUGH */
9462         case OP_HSLICE:
9463             o->op_private |= OPpSLICE;
9464             break;
9465         case OP_AELEM:
9466             o->op_flags |= OPf_SPECIAL;
9467             /* FALLTHROUGH */
9468         case OP_HELEM:
9469             break;
9470         case OP_KVASLICE:
9471             Perl_croak(aTHX_ "delete argument is index/value array slice,"
9472                              " use array slice");
9473         case OP_KVHSLICE:
9474             Perl_croak(aTHX_ "delete argument is key/value hash slice, use"
9475                              " hash slice");
9476         default:
9477             Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
9478                              "element or slice");
9479         }
9480         if (kid->op_private & OPpLVAL_INTRO)
9481             o->op_private |= OPpLVAL_INTRO;
9482         op_null(kid);
9483     }
9484     return o;
9485 }
9486
9487 OP *
9488 Perl_ck_eof(pTHX_ OP *o)
9489 {
9490     PERL_ARGS_ASSERT_CK_EOF;
9491
9492     if (o->op_flags & OPf_KIDS) {
9493         OP *kid;
9494         if (cLISTOPo->op_first->op_type == OP_STUB) {
9495             OP * const newop
9496                 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
9497             op_free(o);
9498             o = newop;
9499         }
9500         o = ck_fun(o);
9501         kid = cLISTOPo->op_first;
9502         if (kid->op_type == OP_RV2GV)
9503             kid->op_private |= OPpALLOW_FAKE;
9504     }
9505     return o;
9506 }
9507
9508 OP *
9509 Perl_ck_eval(pTHX_ OP *o)
9510 {
9511     dVAR;
9512
9513     PERL_ARGS_ASSERT_CK_EVAL;
9514
9515     PL_hints |= HINT_BLOCK_SCOPE;
9516     if (o->op_flags & OPf_KIDS) {
9517         SVOP * const kid = (SVOP*)cUNOPo->op_first;
9518         assert(kid);
9519
9520         if (o->op_type == OP_ENTERTRY) {
9521             LOGOP *enter;
9522
9523             /* cut whole sibling chain free from o */
9524             op_sibling_splice(o, NULL, -1, NULL);
9525             op_free(o);
9526
9527             enter = S_alloc_LOGOP(aTHX_ OP_ENTERTRY, NULL, NULL);
9528
9529             /* establish postfix order */
9530             enter->op_next = (OP*)enter;
9531
9532             o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
9533             OpTYPE_set(o, OP_LEAVETRY);
9534             enter->op_other = o;
9535             return o;
9536         }
9537         else {
9538             scalar((OP*)kid);
9539             S_set_haseval(aTHX);
9540         }
9541     }
9542     else {
9543         const U8 priv = o->op_private;
9544         op_free(o);
9545         /* the newUNOP will recursively call ck_eval(), which will handle
9546          * all the stuff at the end of this function, like adding
9547          * OP_HINTSEVAL
9548          */
9549         return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
9550     }
9551     o->op_targ = (PADOFFSET)PL_hints;
9552     if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
9553     if ((PL_hints & HINT_LOCALIZE_HH) != 0
9554      && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
9555         /* Store a copy of %^H that pp_entereval can pick up. */
9556         OP *hhop = newSVOP(OP_HINTSEVAL, 0,
9557                            MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
9558         /* append hhop to only child  */
9559         op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
9560
9561         o->op_private |= OPpEVAL_HAS_HH;
9562     }
9563     if (!(o->op_private & OPpEVAL_BYTES)
9564          && FEATURE_UNIEVAL_IS_ENABLED)
9565             o->op_private |= OPpEVAL_UNICODE;
9566     return o;
9567 }
9568
9569 OP *
9570 Perl_ck_exec(pTHX_ OP *o)
9571 {
9572     PERL_ARGS_ASSERT_CK_EXEC;
9573
9574     if (o->op_flags & OPf_STACKED) {
9575         OP *kid;
9576         o = ck_fun(o);
9577         kid = OpSIBLING(cUNOPo->op_first);
9578         if (kid->op_type == OP_RV2GV)
9579             op_null(kid);
9580     }
9581     else
9582         o = listkids(o);
9583     return o;
9584 }
9585
9586 OP *
9587 Perl_ck_exists(pTHX_ OP *o)
9588 {
9589     PERL_ARGS_ASSERT_CK_EXISTS;
9590
9591     o = ck_fun(o);
9592     if (o->op_flags & OPf_KIDS) {
9593         OP * const kid = cUNOPo->op_first;
9594         if (kid->op_type == OP_ENTERSUB) {
9595             (void) ref(kid, o->op_type);
9596             if (kid->op_type != OP_RV2CV
9597                         && !(PL_parser && PL_parser->error_count))
9598                 Perl_croak(aTHX_
9599                           "exists argument is not a subroutine name");
9600             o->op_private |= OPpEXISTS_SUB;
9601         }
9602         else if (kid->op_type == OP_AELEM)
9603             o->op_flags |= OPf_SPECIAL;
9604         else if (kid->op_type != OP_HELEM)
9605             Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
9606                              "element or a subroutine");
9607         op_null(kid);
9608     }
9609     return o;
9610 }
9611
9612 OP *
9613 Perl_ck_rvconst(pTHX_ OP *o)
9614 {
9615     dVAR;
9616     SVOP * const kid = (SVOP*)cUNOPo->op_first;
9617
9618     PERL_ARGS_ASSERT_CK_RVCONST;
9619
9620     o->op_private |= (PL_hints & HINT_STRICT_REFS);
9621
9622     if (kid->op_type == OP_CONST) {
9623         int iscv;
9624         GV *gv;
9625         SV * const kidsv = kid->op_sv;
9626
9627         /* Is it a constant from cv_const_sv()? */
9628         if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
9629             return o;
9630         }
9631         if (SvTYPE(kidsv) == SVt_PVAV) return o;
9632         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
9633             const char *badthing;
9634             switch (o->op_type) {
9635             case OP_RV2SV:
9636                 badthing = "a SCALAR";
9637                 break;
9638             case OP_RV2AV:
9639                 badthing = "an ARRAY";
9640                 break;
9641             case OP_RV2HV:
9642                 badthing = "a HASH";
9643                 break;
9644             default:
9645                 badthing = NULL;
9646                 break;
9647             }
9648             if (badthing)
9649                 Perl_croak(aTHX_
9650                            "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
9651                            SVfARG(kidsv), badthing);
9652         }
9653         /*
9654          * This is a little tricky.  We only want to add the symbol if we
9655          * didn't add it in the lexer.  Otherwise we get duplicate strict
9656          * warnings.  But if we didn't add it in the lexer, we must at
9657          * least pretend like we wanted to add it even if it existed before,
9658          * or we get possible typo warnings.  OPpCONST_ENTERED says
9659          * whether the lexer already added THIS instance of this symbol.
9660          */
9661         iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
9662         gv = gv_fetchsv(kidsv,
9663                 o->op_type == OP_RV2CV
9664                         && o->op_private & OPpMAY_RETURN_CONSTANT
9665                     ? GV_NOEXPAND
9666                     : iscv | !(kid->op_private & OPpCONST_ENTERED),
9667                 iscv
9668                     ? SVt_PVCV
9669                     : o->op_type == OP_RV2SV
9670                         ? SVt_PV
9671                         : o->op_type == OP_RV2AV
9672                             ? SVt_PVAV
9673                             : o->op_type == OP_RV2HV
9674                                 ? SVt_PVHV
9675                                 : SVt_PVGV);
9676         if (gv) {
9677             if (!isGV(gv)) {
9678                 assert(iscv);
9679                 assert(SvROK(gv));
9680                 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
9681                   && SvTYPE(SvRV(gv)) != SVt_PVCV)
9682                     gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
9683             }
9684             OpTYPE_set(kid, OP_GV);
9685             SvREFCNT_dec(kid->op_sv);
9686 #ifdef USE_ITHREADS
9687             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
9688             STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
9689             kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
9690             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
9691             PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
9692 #else
9693             kid->op_sv = SvREFCNT_inc_simple_NN(gv);
9694 #endif
9695             kid->op_private = 0;
9696             /* FAKE globs in the symbol table cause weird bugs (#77810) */
9697             SvFAKE_off(gv);
9698         }
9699     }
9700     return o;
9701 }
9702
9703 OP *
9704 Perl_ck_ftst(pTHX_ OP *o)
9705 {
9706     dVAR;
9707     const I32 type = o->op_type;
9708
9709     PERL_ARGS_ASSERT_CK_FTST;
9710
9711     if (o->op_flags & OPf_REF) {
9712         NOOP;
9713     }
9714     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
9715         SVOP * const kid = (SVOP*)cUNOPo->op_first;
9716         const OPCODE kidtype = kid->op_type;
9717
9718         if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
9719          && !kid->op_folded) {
9720             OP * const newop = newGVOP(type, OPf_REF,
9721                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
9722             op_free(o);
9723             return newop;
9724         }
9725         scalar((OP *) kid);
9726         if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
9727             o->op_private |= OPpFT_ACCESS;
9728         if (type != OP_STAT && type != OP_LSTAT
9729             && PL_check[kidtype] == Perl_ck_ftst
9730             && kidtype != OP_STAT && kidtype != OP_LSTAT
9731         ) {
9732             o->op_private |= OPpFT_STACKED;
9733             kid->op_private |= OPpFT_STACKING;
9734             if (kidtype == OP_FTTTY && (
9735                    !(kid->op_private & OPpFT_STACKED)
9736                 || kid->op_private & OPpFT_AFTER_t
9737                ))
9738                 o->op_private |= OPpFT_AFTER_t;
9739         }
9740     }
9741     else {
9742         op_free(o);
9743         if (type == OP_FTTTY)
9744             o = newGVOP(type, OPf_REF, PL_stdingv);
9745         else
9746             o = newUNOP(type, 0, newDEFSVOP());
9747     }
9748     return o;
9749 }
9750
9751 OP *
9752 Perl_ck_fun(pTHX_ OP *o)
9753 {
9754     const int type = o->op_type;
9755     I32 oa = PL_opargs[type] >> OASHIFT;
9756
9757     PERL_ARGS_ASSERT_CK_FUN;
9758
9759     if (o->op_flags & OPf_STACKED) {
9760         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
9761             oa &= ~OA_OPTIONAL;
9762         else
9763             return no_fh_allowed(o);
9764     }
9765
9766     if (o->op_flags & OPf_KIDS) {
9767         OP *prev_kid = NULL;
9768         OP *kid = cLISTOPo->op_first;
9769         I32 numargs = 0;
9770         bool seen_optional = FALSE;
9771
9772         if (kid->op_type == OP_PUSHMARK ||
9773             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
9774         {
9775             prev_kid = kid;
9776             kid = OpSIBLING(kid);
9777         }
9778         if (kid && kid->op_type == OP_COREARGS) {
9779             bool optional = FALSE;
9780             while (oa) {
9781                 numargs++;
9782                 if (oa & OA_OPTIONAL) optional = TRUE;
9783                 oa = oa >> 4;
9784             }
9785             if (optional) o->op_private |= numargs;
9786             return o;
9787         }
9788
9789         while (oa) {
9790             if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
9791                 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
9792                     kid = newDEFSVOP();
9793                     /* append kid to chain */
9794                     op_sibling_splice(o, prev_kid, 0, kid);
9795                 }
9796                 seen_optional = TRUE;
9797             }
9798             if (!kid) break;
9799
9800             numargs++;
9801             switch (oa & 7) {
9802             case OA_SCALAR:
9803                 /* list seen where single (scalar) arg expected? */
9804                 if (numargs == 1 && !(oa >> 4)
9805                     && kid->op_type == OP_LIST && type != OP_SCALAR)
9806                 {
9807                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
9808                 }
9809                 if (type != OP_DELETE) scalar(kid);
9810                 break;
9811             case OA_LIST:
9812                 if (oa < 16) {
9813                     kid = 0;
9814                     continue;
9815                 }
9816                 else
9817                     list(kid);
9818                 break;
9819             case OA_AVREF:
9820                 if ((type == OP_PUSH || type == OP_UNSHIFT)
9821                     && !OpHAS_SIBLING(kid))
9822                     Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
9823                                    "Useless use of %s with no values",
9824                                    PL_op_desc[type]);
9825
9826                 if (kid->op_type == OP_CONST
9827                       && (  !SvROK(cSVOPx_sv(kid))
9828                          || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV  )
9829                         )
9830                     bad_type_pv(numargs, "array", o, kid);
9831                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
9832                     yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
9833                                          PL_op_desc[type]), 0);
9834                 }
9835                 else {
9836                     op_lvalue(kid, type);
9837                 }
9838                 break;
9839             case OA_HVREF:
9840                 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
9841                     bad_type_pv(numargs, "hash", o, kid);
9842                 op_lvalue(kid, type);
9843                 break;
9844             case OA_CVREF:
9845                 {
9846                     /* replace kid with newop in chain */
9847                     OP * const newop =
9848                         S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
9849                     newop->op_next = newop;
9850                     kid = newop;
9851                 }
9852                 break;
9853             case OA_FILEREF:
9854                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
9855                     if (kid->op_type == OP_CONST &&
9856                         (kid->op_private & OPpCONST_BARE))
9857                     {
9858                         OP * const newop = newGVOP(OP_GV, 0,
9859                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
9860                         /* replace kid with newop in chain */
9861                         op_sibling_splice(o, prev_kid, 1, newop);
9862                         op_free(kid);
9863                         kid = newop;
9864                     }
9865                     else if (kid->op_type == OP_READLINE) {
9866                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
9867                         bad_type_pv(numargs, "HANDLE", o, kid);
9868                     }
9869                     else {
9870                         I32 flags = OPf_SPECIAL;
9871                         I32 priv = 0;
9872                         PADOFFSET targ = 0;
9873
9874                         /* is this op a FH constructor? */
9875                         if (is_handle_constructor(o,numargs)) {
9876                             const char *name = NULL;
9877                             STRLEN len = 0;
9878                             U32 name_utf8 = 0;
9879                             bool want_dollar = TRUE;
9880
9881                             flags = 0;
9882                             /* Set a flag to tell rv2gv to vivify
9883                              * need to "prove" flag does not mean something
9884                              * else already - NI-S 1999/05/07
9885                              */
9886                             priv = OPpDEREF;
9887                             if (kid->op_type == OP_PADSV) {
9888                                 PADNAME * const pn
9889                                     = PAD_COMPNAME_SV(kid->op_targ);
9890                                 name = PadnamePV (pn);
9891                                 len  = PadnameLEN(pn);
9892                                 name_utf8 = PadnameUTF8(pn);
9893                             }
9894                             else if (kid->op_type == OP_RV2SV
9895                                      && kUNOP->op_first->op_type == OP_GV)
9896                             {
9897                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
9898                                 name = GvNAME(gv);
9899                                 len = GvNAMELEN(gv);
9900                                 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
9901                             }
9902                             else if (kid->op_type == OP_AELEM
9903                                      || kid->op_type == OP_HELEM)
9904                             {
9905                                  OP *firstop;
9906                                  OP *op = ((BINOP*)kid)->op_first;
9907                                  name = NULL;
9908                                  if (op) {
9909                                       SV *tmpstr = NULL;
9910                                       const char * const a =
9911                                            kid->op_type == OP_AELEM ?
9912                                            "[]" : "{}";
9913                                       if (((op->op_type == OP_RV2AV) ||
9914                                            (op->op_type == OP_RV2HV)) &&
9915                                           (firstop = ((UNOP*)op)->op_first) &&
9916                                           (firstop->op_type == OP_GV)) {
9917                                            /* packagevar $a[] or $h{} */
9918                                            GV * const gv = cGVOPx_gv(firstop);
9919                                            if (gv)
9920                                                 tmpstr =
9921                                                      Perl_newSVpvf(aTHX_
9922                                                                    "%s%c...%c",
9923                                                                    GvNAME(gv),
9924                                                                    a[0], a[1]);
9925                                       }
9926                                       else if (op->op_type == OP_PADAV
9927                                                || op->op_type == OP_PADHV) {
9928                                            /* lexicalvar $a[] or $h{} */
9929                                            const char * const padname =
9930                                                 PAD_COMPNAME_PV(op->op_targ);
9931                                            if (padname)
9932                                                 tmpstr =
9933                                                      Perl_newSVpvf(aTHX_
9934                                                                    "%s%c...%c",
9935                                                                    padname + 1,
9936                                                                    a[0], a[1]);
9937                                       }
9938                                       if (tmpstr) {
9939                                            name = SvPV_const(tmpstr, len);
9940                                            name_utf8 = SvUTF8(tmpstr);
9941                                            sv_2mortal(tmpstr);
9942                                       }
9943                                  }
9944                                  if (!name) {
9945                                       name = "__ANONIO__";
9946                                       len = 10;
9947                                       want_dollar = FALSE;
9948                                  }
9949                                  op_lvalue(kid, type);
9950                             }
9951                             if (name) {
9952                                 SV *namesv;
9953                                 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
9954                                 namesv = PAD_SVl(targ);
9955                                 if (want_dollar && *name != '$')
9956                                     sv_setpvs(namesv, "$");
9957                                 else
9958                                     sv_setpvs(namesv, "");
9959                                 sv_catpvn(namesv, name, len);
9960                                 if ( name_utf8 ) SvUTF8_on(namesv);
9961                             }
9962                         }
9963                         scalar(kid);
9964                         kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
9965                                     OP_RV2GV, flags);
9966                         kid->op_targ = targ;
9967                         kid->op_private |= priv;
9968                     }
9969                 }
9970                 scalar(kid);
9971                 break;
9972             case OA_SCALARREF:
9973                 if ((type == OP_UNDEF || type == OP_POS)
9974                     && numargs == 1 && !(oa >> 4)
9975                     && kid->op_type == OP_LIST)
9976                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
9977                 op_lvalue(scalar(kid), type);
9978                 break;
9979             }
9980             oa >>= 4;
9981             prev_kid = kid;
9982             kid = OpSIBLING(kid);
9983         }
9984         /* FIXME - should the numargs or-ing move after the too many
9985          * arguments check? */
9986         o->op_private |= numargs;
9987         if (kid)
9988             return too_many_arguments_pv(o,OP_DESC(o), 0);
9989         listkids(o);
9990     }
9991     else if (PL_opargs[type] & OA_DEFGV) {
9992         /* Ordering of these two is important to keep f_map.t passing.  */
9993         op_free(o);
9994         return newUNOP(type, 0, newDEFSVOP());
9995     }
9996
9997     if (oa) {
9998         while (oa & OA_OPTIONAL)
9999             oa >>= 4;
10000         if (oa && oa != OA_LIST)
10001             return too_few_arguments_pv(o,OP_DESC(o), 0);
10002     }
10003     return o;
10004 }
10005
10006 OP *
10007 Perl_ck_glob(pTHX_ OP *o)
10008 {
10009     GV *gv;
10010
10011     PERL_ARGS_ASSERT_CK_GLOB;
10012
10013     o = ck_fun(o);
10014     if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
10015         op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
10016
10017     if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
10018     {
10019         /* convert
10020          *     glob
10021          *       \ null - const(wildcard)
10022          * into
10023          *     null
10024          *       \ enter
10025          *            \ list
10026          *                 \ mark - glob - rv2cv
10027          *                             |        \ gv(CORE::GLOBAL::glob)
10028          *                             |
10029          *                              \ null - const(wildcard)
10030          */
10031         o->op_flags |= OPf_SPECIAL;
10032         o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
10033         o = S_new_entersubop(aTHX_ gv, o);
10034         o = newUNOP(OP_NULL, 0, o);
10035         o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
10036         return o;
10037     }
10038     else o->op_flags &= ~OPf_SPECIAL;
10039 #if !defined(PERL_EXTERNAL_GLOB)
10040     if (!PL_globhook) {
10041         ENTER;
10042         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
10043                                newSVpvs("File::Glob"), NULL, NULL, NULL);
10044         LEAVE;
10045     }
10046 #endif /* !PERL_EXTERNAL_GLOB */
10047     gv = (GV *)newSV(0);
10048     gv_init(gv, 0, "", 0, 0);
10049     gv_IOadd(gv);
10050     op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
10051     SvREFCNT_dec_NN(gv); /* newGVOP increased it */
10052     scalarkids(o);
10053     return o;
10054 }
10055
10056 OP *
10057 Perl_ck_grep(pTHX_ OP *o)
10058 {
10059     LOGOP *gwop;
10060     OP *kid;
10061     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
10062
10063     PERL_ARGS_ASSERT_CK_GREP;
10064
10065     /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
10066
10067     if (o->op_flags & OPf_STACKED) {
10068         kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
10069         if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
10070             return no_fh_allowed(o);
10071         o->op_flags &= ~OPf_STACKED;
10072     }
10073     kid = OpSIBLING(cLISTOPo->op_first);
10074     if (type == OP_MAPWHILE)
10075         list(kid);
10076     else
10077         scalar(kid);
10078     o = ck_fun(o);
10079     if (PL_parser && PL_parser->error_count)
10080         return o;
10081     kid = OpSIBLING(cLISTOPo->op_first);
10082     if (kid->op_type != OP_NULL)
10083         Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
10084     kid = kUNOP->op_first;
10085
10086     gwop = S_alloc_LOGOP(aTHX_ type, o, LINKLIST(kid));
10087     kid->op_next = (OP*)gwop;
10088     o->op_private = gwop->op_private = 0;
10089     gwop->op_targ = pad_alloc(type, SVs_PADTMP);
10090
10091     kid = OpSIBLING(cLISTOPo->op_first);
10092     for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
10093         op_lvalue(kid, OP_GREPSTART);
10094
10095     return (OP*)gwop;
10096 }
10097
10098 OP *
10099 Perl_ck_index(pTHX_ OP *o)
10100 {
10101     PERL_ARGS_ASSERT_CK_INDEX;
10102
10103     if (o->op_flags & OPf_KIDS) {
10104         OP *kid = OpSIBLING(cLISTOPo->op_first);        /* get past pushmark */
10105         if (kid)
10106             kid = OpSIBLING(kid);                       /* get past "big" */
10107         if (kid && kid->op_type == OP_CONST) {
10108             const bool save_taint = TAINT_get;
10109             SV *sv = kSVOP->op_sv;
10110             if ((!SvPOK(sv) || SvNIOKp(sv)) && SvOK(sv) && !SvROK(sv)) {
10111                 sv = newSV(0);
10112                 sv_copypv(sv, kSVOP->op_sv);
10113                 SvREFCNT_dec_NN(kSVOP->op_sv);
10114                 kSVOP->op_sv = sv;
10115             }
10116             if (SvOK(sv)) fbm_compile(sv, 0);
10117             TAINT_set(save_taint);
10118 #ifdef NO_TAINT_SUPPORT
10119             PERL_UNUSED_VAR(save_taint);
10120 #endif
10121         }
10122     }
10123     return ck_fun(o);
10124 }
10125
10126 OP *
10127 Perl_ck_lfun(pTHX_ OP *o)
10128 {
10129     const OPCODE type = o->op_type;
10130
10131     PERL_ARGS_ASSERT_CK_LFUN;
10132
10133     return modkids(ck_fun(o), type);
10134 }
10135
10136 OP *
10137 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
10138 {
10139     PERL_ARGS_ASSERT_CK_DEFINED;
10140
10141     if ((o->op_flags & OPf_KIDS)) {
10142         switch (cUNOPo->op_first->op_type) {
10143         case OP_RV2AV:
10144         case OP_PADAV:
10145             Perl_croak(aTHX_ "Can't use 'defined(@array)'"
10146                              " (Maybe you should just omit the defined()?)");
10147         break;
10148         case OP_RV2HV:
10149         case OP_PADHV:
10150             Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
10151                              " (Maybe you should just omit the defined()?)");
10152             break;
10153         default:
10154             /* no warning */
10155             break;
10156         }
10157     }
10158     return ck_rfun(o);
10159 }
10160
10161 OP *
10162 Perl_ck_readline(pTHX_ OP *o)
10163 {
10164     PERL_ARGS_ASSERT_CK_READLINE;
10165
10166     if (o->op_flags & OPf_KIDS) {
10167          OP *kid = cLISTOPo->op_first;
10168          if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
10169     }
10170     else {
10171         OP * const newop
10172             = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
10173         op_free(o);
10174         return newop;
10175     }
10176     return o;
10177 }
10178
10179 OP *
10180 Perl_ck_rfun(pTHX_ OP *o)
10181 {
10182     const OPCODE type = o->op_type;
10183
10184     PERL_ARGS_ASSERT_CK_RFUN;
10185
10186     return refkids(ck_fun(o), type);
10187 }
10188
10189 OP *
10190 Perl_ck_listiob(pTHX_ OP *o)
10191 {
10192     OP *kid;
10193
10194     PERL_ARGS_ASSERT_CK_LISTIOB;
10195
10196     kid = cLISTOPo->op_first;
10197     if (!kid) {
10198         o = force_list(o, 1);
10199         kid = cLISTOPo->op_first;
10200     }
10201     if (kid->op_type == OP_PUSHMARK)
10202         kid = OpSIBLING(kid);
10203     if (kid && o->op_flags & OPf_STACKED)
10204         kid = OpSIBLING(kid);
10205     else if (kid && !OpHAS_SIBLING(kid)) {              /* print HANDLE; */
10206         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
10207          && !kid->op_folded) {
10208             o->op_flags |= OPf_STACKED; /* make it a filehandle */
10209             scalar(kid);
10210             /* replace old const op with new OP_RV2GV parent */
10211             kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
10212                                         OP_RV2GV, OPf_REF);
10213             kid = OpSIBLING(kid);
10214         }
10215     }
10216
10217     if (!kid)
10218         op_append_elem(o->op_type, o, newDEFSVOP());
10219
10220     if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
10221     return listkids(o);
10222 }
10223
10224 OP *
10225 Perl_ck_smartmatch(pTHX_ OP *o)
10226 {
10227     dVAR;
10228     PERL_ARGS_ASSERT_CK_SMARTMATCH;
10229     if (0 == (o->op_flags & OPf_SPECIAL)) {
10230         OP *first  = cBINOPo->op_first;
10231         OP *second = OpSIBLING(first);
10232
10233         /* Implicitly take a reference to an array or hash */
10234
10235         /* remove the original two siblings, then add back the
10236          * (possibly different) first and second sibs.
10237          */
10238         op_sibling_splice(o, NULL, 1, NULL);
10239         op_sibling_splice(o, NULL, 1, NULL);
10240         first  = ref_array_or_hash(first);
10241         second = ref_array_or_hash(second);
10242         op_sibling_splice(o, NULL, 0, second);
10243         op_sibling_splice(o, NULL, 0, first);
10244
10245         /* Implicitly take a reference to a regular expression */
10246         if (first->op_type == OP_MATCH) {
10247             OpTYPE_set(first, OP_QR);
10248         }
10249         if (second->op_type == OP_MATCH) {
10250             OpTYPE_set(second, OP_QR);
10251         }
10252     }
10253
10254     return o;
10255 }
10256
10257
10258 static OP *
10259 S_maybe_targlex(pTHX_ OP *o)
10260 {
10261     OP * const kid = cLISTOPo->op_first;
10262     /* has a disposable target? */
10263     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
10264         && !(kid->op_flags & OPf_STACKED)
10265         /* Cannot steal the second time! */
10266         && !(kid->op_private & OPpTARGET_MY)
10267         )
10268     {
10269         OP * const kkid = OpSIBLING(kid);
10270
10271         /* Can just relocate the target. */
10272         if (kkid && kkid->op_type == OP_PADSV
10273             && (!(kkid->op_private & OPpLVAL_INTRO)
10274                || kkid->op_private & OPpPAD_STATE))
10275         {
10276             kid->op_targ = kkid->op_targ;
10277             kkid->op_targ = 0;
10278             /* Now we do not need PADSV and SASSIGN.
10279              * Detach kid and free the rest. */
10280             op_sibling_splice(o, NULL, 1, NULL);
10281             op_free(o);
10282             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
10283             return kid;
10284         }
10285     }
10286     return o;
10287 }
10288
10289 OP *
10290 Perl_ck_sassign(pTHX_ OP *o)
10291 {
10292     dVAR;
10293     OP * const kid = cLISTOPo->op_first;
10294
10295     PERL_ARGS_ASSERT_CK_SASSIGN;
10296
10297     if (OpHAS_SIBLING(kid)) {
10298         OP *kkid = OpSIBLING(kid);
10299         /* For state variable assignment with attributes, kkid is a list op
10300            whose op_last is a padsv. */
10301         if ((kkid->op_type == OP_PADSV ||
10302              (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
10303               (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
10304              )
10305             )
10306                 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
10307                     == (OPpLVAL_INTRO|OPpPAD_STATE)) {
10308             const PADOFFSET target = kkid->op_targ;
10309             OP *const other = newOP(OP_PADSV,
10310                                     kkid->op_flags
10311                                     | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
10312             OP *const first = newOP(OP_NULL, 0);
10313             OP *const nullop =
10314                 newCONDOP(0, first, o, other);
10315             /* XXX targlex disabled for now; see ticket #124160
10316                 newCONDOP(0, first, S_maybe_targlex(aTHX_ o), other);
10317              */
10318             OP *const condop = first->op_next;
10319
10320             OpTYPE_set(condop, OP_ONCE);
10321             other->op_targ = target;
10322             nullop->op_flags |= OPf_WANT_SCALAR;
10323
10324             /* Store the initializedness of state vars in a separate
10325                pad entry.  */
10326             condop->op_targ =
10327               pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
10328             /* hijacking PADSTALE for uninitialized state variables */
10329             SvPADSTALE_on(PAD_SVl(condop->op_targ));
10330
10331             return nullop;
10332         }
10333     }
10334     return S_maybe_targlex(aTHX_ o);
10335 }
10336
10337 OP *
10338 Perl_ck_match(pTHX_ OP *o)
10339 {
10340     PERL_UNUSED_CONTEXT;
10341     PERL_ARGS_ASSERT_CK_MATCH;
10342
10343     if (o->op_type == OP_MATCH || o->op_type == OP_QR)
10344         o->op_private |= OPpRUNTIME;
10345     return o;
10346 }
10347
10348 OP *
10349 Perl_ck_method(pTHX_ OP *o)
10350 {
10351     SV *sv, *methsv, *rclass;
10352     const char* method;
10353     char* compatptr;
10354     int utf8;
10355     STRLEN len, nsplit = 0, i;
10356     OP* new_op;
10357     OP * const kid = cUNOPo->op_first;
10358
10359     PERL_ARGS_ASSERT_CK_METHOD;
10360     if (kid->op_type != OP_CONST) return o;
10361
10362     sv = kSVOP->op_sv;
10363
10364     /* replace ' with :: */
10365     while ((compatptr = strchr(SvPVX(sv), '\''))) {
10366         *compatptr = ':';
10367         sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
10368     }
10369
10370     method = SvPVX_const(sv);
10371     len = SvCUR(sv);
10372     utf8 = SvUTF8(sv) ? -1 : 1;
10373
10374     for (i = len - 1; i > 0; --i) if (method[i] == ':') {
10375         nsplit = i+1;
10376         break;
10377     }
10378
10379     methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
10380
10381     if (!nsplit) { /* $proto->method() */
10382         op_free(o);
10383         return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
10384     }
10385
10386     if (nsplit == 7 && memEQ(method, "SUPER::", nsplit)) { /* $proto->SUPER::method() */
10387         op_free(o);
10388         return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
10389     }
10390
10391     /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
10392     if (nsplit >= 9 && strnEQ(method+nsplit-9, "::SUPER::", 9)) {
10393         rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
10394         new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
10395     } else {
10396         rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
10397         new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
10398     }
10399 #ifdef USE_ITHREADS
10400     op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
10401 #else
10402     cMETHOPx(new_op)->op_rclass_sv = rclass;
10403 #endif
10404     op_free(o);
10405     return new_op;
10406 }
10407
10408 OP *
10409 Perl_ck_null(pTHX_ OP *o)
10410 {
10411     PERL_ARGS_ASSERT_CK_NULL;
10412     PERL_UNUSED_CONTEXT;
10413     return o;
10414 }
10415
10416 OP *
10417 Perl_ck_open(pTHX_ OP *o)
10418 {
10419     PERL_ARGS_ASSERT_CK_OPEN;
10420
10421     S_io_hints(aTHX_ o);
10422     {
10423          /* In case of three-arg dup open remove strictness
10424           * from the last arg if it is a bareword. */
10425          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
10426          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
10427          OP *oa;
10428          const char *mode;
10429
10430          if ((last->op_type == OP_CONST) &&             /* The bareword. */
10431              (last->op_private & OPpCONST_BARE) &&
10432              (last->op_private & OPpCONST_STRICT) &&
10433              (oa = OpSIBLING(first)) &&         /* The fh. */
10434              (oa = OpSIBLING(oa)) &&                    /* The mode. */
10435              (oa->op_type == OP_CONST) &&
10436              SvPOK(((SVOP*)oa)->op_sv) &&
10437              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
10438              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
10439              (last == OpSIBLING(oa)))                   /* The bareword. */
10440               last->op_private &= ~OPpCONST_STRICT;
10441     }
10442     return ck_fun(o);
10443 }
10444
10445 OP *
10446 Perl_ck_prototype(pTHX_ OP *o)
10447 {
10448     PERL_ARGS_ASSERT_CK_PROTOTYPE;
10449     if (!(o->op_flags & OPf_KIDS)) {
10450         op_free(o);
10451         return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
10452     }
10453     return o;
10454 }
10455
10456 OP *
10457 Perl_ck_refassign(pTHX_ OP *o)
10458 {
10459     OP * const right = cLISTOPo->op_first;
10460     OP * const left = OpSIBLING(right);
10461     OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
10462     bool stacked = 0;
10463
10464     PERL_ARGS_ASSERT_CK_REFASSIGN;
10465     assert (left);
10466     assert (left->op_type == OP_SREFGEN);
10467
10468     o->op_private = 0;
10469     /* we use OPpPAD_STATE in refassign to mean either of those things,
10470      * and the code assumes the two flags occupy the same bit position
10471      * in the various ops below */
10472     assert(OPpPAD_STATE == OPpOUR_INTRO);
10473
10474     switch (varop->op_type) {
10475     case OP_PADAV:
10476         o->op_private |= OPpLVREF_AV;
10477         goto settarg;
10478     case OP_PADHV:
10479         o->op_private |= OPpLVREF_HV;
10480         /* FALLTHROUGH */
10481     case OP_PADSV:
10482       settarg:
10483         o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
10484         o->op_targ = varop->op_targ;
10485         varop->op_targ = 0;
10486         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
10487         break;
10488
10489     case OP_RV2AV:
10490         o->op_private |= OPpLVREF_AV;
10491         goto checkgv;
10492         NOT_REACHED; /* NOTREACHED */
10493     case OP_RV2HV:
10494         o->op_private |= OPpLVREF_HV;
10495         /* FALLTHROUGH */
10496     case OP_RV2SV:
10497       checkgv:
10498         o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
10499         if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
10500       detach_and_stack:
10501         /* Point varop to its GV kid, detached.  */
10502         varop = op_sibling_splice(varop, NULL, -1, NULL);
10503         stacked = TRUE;
10504         break;
10505     case OP_RV2CV: {
10506         OP * const kidparent =
10507             OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
10508         OP * const kid = cUNOPx(kidparent)->op_first;
10509         o->op_private |= OPpLVREF_CV;
10510         if (kid->op_type == OP_GV) {
10511             varop = kidparent;
10512             goto detach_and_stack;
10513         }
10514         if (kid->op_type != OP_PADCV)   goto bad;
10515         o->op_targ = kid->op_targ;
10516         kid->op_targ = 0;
10517         break;
10518     }
10519     case OP_AELEM:
10520     case OP_HELEM:
10521         o->op_private |= (varop->op_private & OPpLVAL_INTRO);
10522         o->op_private |= OPpLVREF_ELEM;
10523         op_null(varop);
10524         stacked = TRUE;
10525         /* Detach varop.  */
10526         op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
10527         break;
10528     default:
10529       bad:
10530         /* diag_listed_as: Can't modify reference to %s in %s assignment */
10531         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
10532                                 "assignment",
10533                                  OP_DESC(varop)));
10534         return o;
10535     }
10536     if (!FEATURE_REFALIASING_IS_ENABLED)
10537         Perl_croak(aTHX_
10538                   "Experimental aliasing via reference not enabled");
10539     Perl_ck_warner_d(aTHX_
10540                      packWARN(WARN_EXPERIMENTAL__REFALIASING),
10541                     "Aliasing via reference is experimental");
10542     if (stacked) {
10543         o->op_flags |= OPf_STACKED;
10544         op_sibling_splice(o, right, 1, varop);
10545     }
10546     else {
10547         o->op_flags &=~ OPf_STACKED;
10548         op_sibling_splice(o, right, 1, NULL);
10549     }
10550     op_free(left);
10551     return o;
10552 }
10553
10554 OP *
10555 Perl_ck_repeat(pTHX_ OP *o)
10556 {
10557     PERL_ARGS_ASSERT_CK_REPEAT;
10558
10559     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
10560         OP* kids;
10561         o->op_private |= OPpREPEAT_DOLIST;
10562         kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
10563         kids = force_list(kids, 1); /* promote it to a list */
10564         op_sibling_splice(o, NULL, 0, kids); /* and add back */
10565     }
10566     else
10567         scalar(o);
10568     return o;
10569 }
10570
10571 OP *
10572 Perl_ck_require(pTHX_ OP *o)
10573 {
10574     GV* gv;
10575
10576     PERL_ARGS_ASSERT_CK_REQUIRE;
10577
10578     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
10579         SVOP * const kid = (SVOP*)cUNOPo->op_first;
10580         HEK *hek;
10581         U32 hash;
10582         char *s;
10583         STRLEN len;
10584         if (kid->op_type == OP_CONST) {
10585           SV * const sv = kid->op_sv;
10586           U32 const was_readonly = SvREADONLY(sv);
10587           if (kid->op_private & OPpCONST_BARE) {
10588             dVAR;
10589             const char *end;
10590
10591             if (was_readonly) {
10592                     SvREADONLY_off(sv);
10593             }
10594             if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
10595
10596             s = SvPVX(sv);
10597             len = SvCUR(sv);
10598             end = s + len;
10599             for (; s < end; s++) {
10600                 if (*s == ':' && s[1] == ':') {
10601                     *s = '/';
10602                     Move(s+2, s+1, end - s - 1, char);
10603                     --end;
10604                 }
10605             }
10606             SvEND_set(sv, end);
10607             sv_catpvs(sv, ".pm");
10608             PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
10609             hek = share_hek(SvPVX(sv),
10610                             (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
10611                             hash);
10612             sv_sethek(sv, hek);
10613             unshare_hek(hek);
10614             SvFLAGS(sv) |= was_readonly;
10615           }
10616           else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
10617                 && !SvVOK(sv)) {
10618             s = SvPV(sv, len);
10619             if (SvREFCNT(sv) > 1) {
10620                 kid->op_sv = newSVpvn_share(
10621                     s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
10622                 SvREFCNT_dec_NN(sv);
10623             }
10624             else {
10625                 dVAR;
10626                 if (was_readonly) SvREADONLY_off(sv);
10627                 PERL_HASH(hash, s, len);
10628                 hek = share_hek(s,
10629                                 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
10630                                 hash);
10631                 sv_sethek(sv, hek);
10632                 unshare_hek(hek);
10633                 SvFLAGS(sv) |= was_readonly;
10634             }
10635           }
10636         }
10637     }
10638
10639     if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
10640         /* handle override, if any */
10641      && (gv = gv_override("require", 7))) {
10642         OP *kid, *newop;
10643         if (o->op_flags & OPf_KIDS) {
10644             kid = cUNOPo->op_first;
10645             op_sibling_splice(o, NULL, -1, NULL);
10646         }
10647         else {
10648             kid = newDEFSVOP();
10649         }
10650         op_free(o);
10651         newop = S_new_entersubop(aTHX_ gv, kid);
10652         return newop;
10653     }
10654
10655     return ck_fun(o);
10656 }
10657
10658 OP *
10659 Perl_ck_return(pTHX_ OP *o)
10660 {
10661     OP *kid;
10662
10663     PERL_ARGS_ASSERT_CK_RETURN;
10664
10665     kid = OpSIBLING(cLISTOPo->op_first);
10666     if (CvLVALUE(PL_compcv)) {
10667         for (; kid; kid = OpSIBLING(kid))
10668             op_lvalue(kid, OP_LEAVESUBLV);
10669     }
10670
10671     return o;
10672 }
10673
10674 OP *
10675 Perl_ck_select(pTHX_ OP *o)
10676 {
10677     dVAR;
10678     OP* kid;
10679
10680     PERL_ARGS_ASSERT_CK_SELECT;
10681
10682     if (o->op_flags & OPf_KIDS) {
10683         kid = OpSIBLING(cLISTOPo->op_first);     /* get past pushmark */
10684         if (kid && OpHAS_SIBLING(kid)) {
10685             OpTYPE_set(o, OP_SSELECT);
10686             o = ck_fun(o);
10687             return fold_constants(op_integerize(op_std_init(o)));
10688         }
10689     }
10690     o = ck_fun(o);
10691     kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
10692     if (kid && kid->op_type == OP_RV2GV)
10693         kid->op_private &= ~HINT_STRICT_REFS;
10694     return o;
10695 }
10696
10697 OP *
10698 Perl_ck_shift(pTHX_ OP *o)
10699 {
10700     const I32 type = o->op_type;
10701
10702     PERL_ARGS_ASSERT_CK_SHIFT;
10703
10704     if (!(o->op_flags & OPf_KIDS)) {
10705         OP *argop;
10706
10707         if (!CvUNIQUE(PL_compcv)) {
10708             o->op_flags |= OPf_SPECIAL;
10709             return o;
10710         }
10711
10712         argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
10713         op_free(o);
10714         return newUNOP(type, 0, scalar(argop));
10715     }
10716     return scalar(ck_fun(o));
10717 }
10718
10719 OP *
10720 Perl_ck_sort(pTHX_ OP *o)
10721 {
10722     OP *firstkid;
10723     OP *kid;
10724     HV * const hinthv =
10725         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
10726     U8 stacked;
10727
10728     PERL_ARGS_ASSERT_CK_SORT;
10729
10730     if (hinthv) {
10731             SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
10732             if (svp) {
10733                 const I32 sorthints = (I32)SvIV(*svp);
10734                 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
10735                     o->op_private |= OPpSORT_QSORT;
10736                 if ((sorthints & HINT_SORT_STABLE) != 0)
10737                     o->op_private |= OPpSORT_STABLE;
10738             }
10739     }
10740
10741     if (o->op_flags & OPf_STACKED)
10742         simplify_sort(o);
10743     firstkid = OpSIBLING(cLISTOPo->op_first);           /* get past pushmark */
10744
10745     if ((stacked = o->op_flags & OPf_STACKED)) {        /* may have been cleared */
10746         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
10747
10748         /* if the first arg is a code block, process it and mark sort as
10749          * OPf_SPECIAL */
10750         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
10751             LINKLIST(kid);
10752             if (kid->op_type == OP_LEAVE)
10753                     op_null(kid);                       /* wipe out leave */
10754             /* Prevent execution from escaping out of the sort block. */
10755             kid->op_next = 0;
10756
10757             /* provide scalar context for comparison function/block */
10758             kid = scalar(firstkid);
10759             kid->op_next = kid;
10760             o->op_flags |= OPf_SPECIAL;
10761         }
10762         else if (kid->op_type == OP_CONST
10763               && kid->op_private & OPpCONST_BARE) {
10764             char tmpbuf[256];
10765             STRLEN len;
10766             PADOFFSET off;
10767             const char * const name = SvPV(kSVOP_sv, len);
10768             *tmpbuf = '&';
10769             assert (len < 256);
10770             Copy(name, tmpbuf+1, len, char);
10771             off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv));
10772             if (off != NOT_IN_PAD) {
10773                 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
10774                     SV * const fq =
10775                         newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
10776                     sv_catpvs(fq, "::");
10777                     sv_catsv(fq, kSVOP_sv);
10778                     SvREFCNT_dec_NN(kSVOP_sv);
10779                     kSVOP->op_sv = fq;
10780                 }
10781                 else {
10782                     OP * const padop = newOP(OP_PADCV, 0);
10783                     padop->op_targ = off;
10784                     /* replace the const op with the pad op */
10785                     op_sibling_splice(firstkid, NULL, 1, padop);
10786                     op_free(kid);
10787                 }
10788             }
10789         }
10790
10791         firstkid = OpSIBLING(firstkid);
10792     }
10793
10794     for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
10795         /* provide list context for arguments */
10796         list(kid);
10797         if (stacked)
10798             op_lvalue(kid, OP_GREPSTART);
10799     }
10800
10801     return o;
10802 }
10803
10804 /* for sort { X } ..., where X is one of
10805  *   $a <=> $b, $b <= $a, $a cmp $b, $b cmp $a
10806  * elide the second child of the sort (the one containing X),
10807  * and set these flags as appropriate
10808         OPpSORT_NUMERIC;
10809         OPpSORT_INTEGER;
10810         OPpSORT_DESCEND;
10811  * Also, check and warn on lexical $a, $b.
10812  */
10813
10814 STATIC void
10815 S_simplify_sort(pTHX_ OP *o)
10816 {
10817     OP *kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
10818     OP *k;
10819     int descending;
10820     GV *gv;
10821     const char *gvname;
10822     bool have_scopeop;
10823
10824     PERL_ARGS_ASSERT_SIMPLIFY_SORT;
10825
10826     kid = kUNOP->op_first;                              /* get past null */
10827     if (!(have_scopeop = kid->op_type == OP_SCOPE)
10828      && kid->op_type != OP_LEAVE)
10829         return;
10830     kid = kLISTOP->op_last;                             /* get past scope */
10831     switch(kid->op_type) {
10832         case OP_NCMP:
10833         case OP_I_NCMP:
10834         case OP_SCMP:
10835             if (!have_scopeop) goto padkids;
10836             break;
10837         default:
10838             return;
10839     }
10840     k = kid;                                            /* remember this node*/
10841     if (kBINOP->op_first->op_type != OP_RV2SV
10842      || kBINOP->op_last ->op_type != OP_RV2SV)
10843     {
10844         /*
10845            Warn about my($a) or my($b) in a sort block, *if* $a or $b is
10846            then used in a comparison.  This catches most, but not
10847            all cases.  For instance, it catches
10848                sort { my($a); $a <=> $b }
10849            but not
10850                sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
10851            (although why you'd do that is anyone's guess).
10852         */
10853
10854        padkids:
10855         if (!ckWARN(WARN_SYNTAX)) return;
10856         kid = kBINOP->op_first;
10857         do {
10858             if (kid->op_type == OP_PADSV) {
10859                 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
10860                 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
10861                  && (  PadnamePV(name)[1] == 'a'
10862                     || PadnamePV(name)[1] == 'b'  ))
10863                     /* diag_listed_as: "my %s" used in sort comparison */
10864                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10865                                      "\"%s %s\" used in sort comparison",
10866                                       PadnameIsSTATE(name)
10867                                         ? "state"
10868                                         : "my",
10869                                       PadnamePV(name));
10870             }
10871         } while ((kid = OpSIBLING(kid)));
10872         return;
10873     }
10874     kid = kBINOP->op_first;                             /* get past cmp */
10875     if (kUNOP->op_first->op_type != OP_GV)
10876         return;
10877     kid = kUNOP->op_first;                              /* get past rv2sv */
10878     gv = kGVOP_gv;
10879     if (GvSTASH(gv) != PL_curstash)
10880         return;
10881     gvname = GvNAME(gv);
10882     if (*gvname == 'a' && gvname[1] == '\0')
10883         descending = 0;
10884     else if (*gvname == 'b' && gvname[1] == '\0')
10885         descending = 1;
10886     else
10887         return;
10888
10889     kid = k;                                            /* back to cmp */
10890     /* already checked above that it is rv2sv */
10891     kid = kBINOP->op_last;                              /* down to 2nd arg */
10892     if (kUNOP->op_first->op_type != OP_GV)
10893         return;
10894     kid = kUNOP->op_first;                              /* get past rv2sv */
10895     gv = kGVOP_gv;
10896     if (GvSTASH(gv) != PL_curstash)
10897         return;
10898     gvname = GvNAME(gv);
10899     if ( descending
10900          ? !(*gvname == 'a' && gvname[1] == '\0')
10901          : !(*gvname == 'b' && gvname[1] == '\0'))
10902         return;
10903     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
10904     if (descending)
10905         o->op_private |= OPpSORT_DESCEND;
10906     if (k->op_type == OP_NCMP)
10907         o->op_private |= OPpSORT_NUMERIC;
10908     if (k->op_type == OP_I_NCMP)
10909         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
10910     kid = OpSIBLING(cLISTOPo->op_first);
10911     /* cut out and delete old block (second sibling) */
10912     op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
10913     op_free(kid);
10914 }
10915
10916 OP *
10917 Perl_ck_split(pTHX_ OP *o)
10918 {
10919     dVAR;
10920     OP *kid;
10921
10922     PERL_ARGS_ASSERT_CK_SPLIT;
10923
10924     if (o->op_flags & OPf_STACKED)
10925         return no_fh_allowed(o);
10926
10927     kid = cLISTOPo->op_first;
10928     if (kid->op_type != OP_NULL)
10929         Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
10930     /* delete leading NULL node, then add a CONST if no other nodes */
10931     op_sibling_splice(o, NULL, 1,
10932         OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
10933     op_free(kid);
10934     kid = cLISTOPo->op_first;
10935
10936     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
10937         /* remove kid, and replace with new optree */
10938         op_sibling_splice(o, NULL, 1, NULL);
10939         /* OPf_SPECIAL is used to trigger split " " behavior */
10940         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, NULL, 0, 0);
10941         op_sibling_splice(o, NULL, 0, kid);
10942     }
10943     OpTYPE_set(kid, OP_PUSHRE);
10944     /* target implies @ary=..., so wipe it */
10945     kid->op_targ = 0;
10946     scalar(kid);
10947     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
10948       Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
10949                      "Use of /g modifier is meaningless in split");
10950     }
10951
10952     if (!OpHAS_SIBLING(kid))
10953         op_append_elem(OP_SPLIT, o, newDEFSVOP());
10954
10955     kid = OpSIBLING(kid);
10956     assert(kid);
10957     scalar(kid);
10958
10959     if (!OpHAS_SIBLING(kid))
10960     {
10961         op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
10962         o->op_private |= OPpSPLIT_IMPLIM;
10963     }
10964     assert(OpHAS_SIBLING(kid));
10965
10966     kid = OpSIBLING(kid);
10967     scalar(kid);
10968
10969     if (OpHAS_SIBLING(kid))
10970         return too_many_arguments_pv(o,OP_DESC(o), 0);
10971
10972     return o;
10973 }
10974
10975 OP *
10976 Perl_ck_stringify(pTHX_ OP *o)
10977 {
10978     OP * const kid = OpSIBLING(cUNOPo->op_first);
10979     PERL_ARGS_ASSERT_CK_STRINGIFY;
10980     if ((   kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
10981          || kid->op_type == OP_LC   || kid->op_type == OP_LCFIRST
10982          || kid->op_type == OP_UC   || kid->op_type == OP_UCFIRST)
10983         && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
10984     {
10985         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
10986         op_free(o);
10987         return kid;
10988     }
10989     return ck_fun(o);
10990 }
10991
10992 OP *
10993 Perl_ck_join(pTHX_ OP *o)
10994 {
10995     OP * const kid = OpSIBLING(cLISTOPo->op_first);
10996
10997     PERL_ARGS_ASSERT_CK_JOIN;
10998
10999     if (kid && kid->op_type == OP_MATCH) {
11000         if (ckWARN(WARN_SYNTAX)) {
11001             const REGEXP *re = PM_GETRE(kPMOP);
11002             const SV *msg = re
11003                     ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
11004                                             SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
11005                     : newSVpvs_flags( "STRING", SVs_TEMP );
11006             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11007                         "/%"SVf"/ should probably be written as \"%"SVf"\"",
11008                         SVfARG(msg), SVfARG(msg));
11009         }
11010     }
11011     if (kid
11012      && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
11013         || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
11014         || (  kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
11015            && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
11016     {
11017         const OP * const bairn = OpSIBLING(kid); /* the list */
11018         if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
11019          && OP_GIMME(bairn,0) == G_SCALAR)
11020         {
11021             OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
11022                                      op_sibling_splice(o, kid, 1, NULL));
11023             op_free(o);
11024             return ret;
11025         }
11026     }
11027
11028     return ck_fun(o);
11029 }
11030
11031 /*
11032 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
11033
11034 Examines an op, which is expected to identify a subroutine at runtime,
11035 and attempts to determine at compile time which subroutine it identifies.
11036 This is normally used during Perl compilation to determine whether
11037 a prototype can be applied to a function call.  C<cvop> is the op
11038 being considered, normally an C<rv2cv> op.  A pointer to the identified
11039 subroutine is returned, if it could be determined statically, and a null
11040 pointer is returned if it was not possible to determine statically.
11041
11042 Currently, the subroutine can be identified statically if the RV that the
11043 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
11044 A C<gv> op is suitable if the GV's CV slot is populated.  A C<const> op is
11045 suitable if the constant value must be an RV pointing to a CV.  Details of
11046 this process may change in future versions of Perl.  If the C<rv2cv> op
11047 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
11048 the subroutine statically: this flag is used to suppress compile-time
11049 magic on a subroutine call, forcing it to use default runtime behaviour.
11050
11051 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
11052 of a GV reference is modified.  If a GV was examined and its CV slot was
11053 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
11054 If the op is not optimised away, and the CV slot is later populated with
11055 a subroutine having a prototype, that flag eventually triggers the warning
11056 "called too early to check prototype".
11057
11058 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
11059 of returning a pointer to the subroutine it returns a pointer to the
11060 GV giving the most appropriate name for the subroutine in this context.
11061 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
11062 (C<CvANON>) subroutine that is referenced through a GV it will be the
11063 referencing GV.  The resulting C<GV*> is cast to C<CV*> to be returned.
11064 A null pointer is returned as usual if there is no statically-determinable
11065 subroutine.
11066
11067 =cut
11068 */
11069
11070 /* shared by toke.c:yylex */
11071 CV *
11072 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
11073 {
11074     PADNAME *name = PAD_COMPNAME(off);
11075     CV *compcv = PL_compcv;
11076     while (PadnameOUTER(name)) {
11077         assert(PARENT_PAD_INDEX(name));
11078         compcv = CvOUTSIDE(compcv);
11079         name = PadlistNAMESARRAY(CvPADLIST(compcv))
11080                 [off = PARENT_PAD_INDEX(name)];
11081     }
11082     assert(!PadnameIsOUR(name));
11083     if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
11084         return PadnamePROTOCV(name);
11085     }
11086     return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
11087 }
11088
11089 CV *
11090 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
11091 {
11092     OP *rvop;
11093     CV *cv;
11094     GV *gv;
11095     PERL_ARGS_ASSERT_RV2CV_OP_CV;
11096     if (flags & ~RV2CVOPCV_FLAG_MASK)
11097         Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
11098     if (cvop->op_type != OP_RV2CV)
11099         return NULL;
11100     if (cvop->op_private & OPpENTERSUB_AMPER)
11101         return NULL;
11102     if (!(cvop->op_flags & OPf_KIDS))
11103         return NULL;
11104     rvop = cUNOPx(cvop)->op_first;
11105     switch (rvop->op_type) {
11106         case OP_GV: {
11107             gv = cGVOPx_gv(rvop);
11108             if (!isGV(gv)) {
11109                 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
11110                     cv = MUTABLE_CV(SvRV(gv));
11111                     gv = NULL;
11112                     break;
11113                 }
11114                 if (flags & RV2CVOPCV_RETURN_STUB)
11115                     return (CV *)gv;
11116                 else return NULL;
11117             }
11118             cv = GvCVu(gv);
11119             if (!cv) {
11120                 if (flags & RV2CVOPCV_MARK_EARLY)
11121                     rvop->op_private |= OPpEARLY_CV;
11122                 return NULL;
11123             }
11124         } break;
11125         case OP_CONST: {
11126             SV *rv = cSVOPx_sv(rvop);
11127             if (!SvROK(rv))
11128                 return NULL;
11129             cv = (CV*)SvRV(rv);
11130             gv = NULL;
11131         } break;
11132         case OP_PADCV: {
11133             cv = find_lexical_cv(rvop->op_targ);
11134             gv = NULL;
11135         } break;
11136         default: {
11137             return NULL;
11138         } NOT_REACHED; /* NOTREACHED */
11139     }
11140     if (SvTYPE((SV*)cv) != SVt_PVCV)
11141         return NULL;
11142     if (flags & (RV2CVOPCV_RETURN_NAME_GV|RV2CVOPCV_MAYBE_NAME_GV)) {
11143         if ((!CvANON(cv) || !gv) && !CvLEXICAL(cv)
11144          && ((flags & RV2CVOPCV_RETURN_NAME_GV) || !CvNAMED(cv)))
11145             gv = CvGV(cv);
11146         return (CV*)gv;
11147     } else {
11148         return cv;
11149     }
11150 }
11151
11152 /*
11153 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
11154
11155 Performs the default fixup of the arguments part of an C<entersub>
11156 op tree.  This consists of applying list context to each of the
11157 argument ops.  This is the standard treatment used on a call marked
11158 with C<&>, or a method call, or a call through a subroutine reference,
11159 or any other call where the callee can't be identified at compile time,
11160 or a call where the callee has no prototype.
11161
11162 =cut
11163 */
11164
11165 OP *
11166 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
11167 {
11168     OP *aop;
11169
11170     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
11171
11172     aop = cUNOPx(entersubop)->op_first;
11173     if (!OpHAS_SIBLING(aop))
11174         aop = cUNOPx(aop)->op_first;
11175     for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
11176         /* skip the extra attributes->import() call implicitly added in
11177          * something like foo(my $x : bar)
11178          */
11179         if (   aop->op_type == OP_ENTERSUB
11180             && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
11181         )
11182             continue;
11183         list(aop);
11184         op_lvalue(aop, OP_ENTERSUB);
11185     }
11186     return entersubop;
11187 }
11188
11189 /*
11190 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
11191
11192 Performs the fixup of the arguments part of an C<entersub> op tree
11193 based on a subroutine prototype.  This makes various modifications to
11194 the argument ops, from applying context up to inserting C<refgen> ops,
11195 and checking the number and syntactic types of arguments, as directed by
11196 the prototype.  This is the standard treatment used on a subroutine call,
11197 not marked with C<&>, where the callee can be identified at compile time
11198 and has a prototype.
11199
11200 C<protosv> supplies the subroutine prototype to be applied to the call.
11201 It may be a normal defined scalar, of which the string value will be used.
11202 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11203 that has been cast to C<SV*>) which has a prototype.  The prototype
11204 supplied, in whichever form, does not need to match the actual callee
11205 referenced by the op tree.
11206
11207 If the argument ops disagree with the prototype, for example by having
11208 an unacceptable number of arguments, a valid op tree is returned anyway.
11209 The error is reflected in the parser state, normally resulting in a single
11210 exception at the top level of parsing which covers all the compilation
11211 errors that occurred.  In the error message, the callee is referred to
11212 by the name defined by the C<namegv> parameter.
11213
11214 =cut
11215 */
11216
11217 OP *
11218 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11219 {
11220     STRLEN proto_len;
11221     const char *proto, *proto_end;
11222     OP *aop, *prev, *cvop, *parent;
11223     int optional = 0;
11224     I32 arg = 0;
11225     I32 contextclass = 0;
11226     const char *e = NULL;
11227     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
11228     if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
11229         Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
11230                    "flags=%lx", (unsigned long) SvFLAGS(protosv));
11231     if (SvTYPE(protosv) == SVt_PVCV)
11232          proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
11233     else proto = SvPV(protosv, proto_len);
11234     proto = S_strip_spaces(aTHX_ proto, &proto_len);
11235     proto_end = proto + proto_len;
11236     parent = entersubop;
11237     aop = cUNOPx(entersubop)->op_first;
11238     if (!OpHAS_SIBLING(aop)) {
11239         parent = aop;
11240         aop = cUNOPx(aop)->op_first;
11241     }
11242     prev = aop;
11243     aop = OpSIBLING(aop);
11244     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11245     while (aop != cvop) {
11246         OP* o3 = aop;
11247
11248         if (proto >= proto_end)
11249         {
11250             SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11251             yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf,
11252                                         SVfARG(namesv)), SvUTF8(namesv));
11253             return entersubop;
11254         }
11255
11256         switch (*proto) {
11257             case ';':
11258                 optional = 1;
11259                 proto++;
11260                 continue;
11261             case '_':
11262                 /* _ must be at the end */
11263                 if (proto[1] && !strchr(";@%", proto[1]))
11264                     goto oops;
11265                 /* FALLTHROUGH */
11266             case '$':
11267                 proto++;
11268                 arg++;
11269                 scalar(aop);
11270                 break;
11271             case '%':
11272             case '@':
11273                 list(aop);
11274                 arg++;
11275                 break;
11276             case '&':
11277                 proto++;
11278                 arg++;
11279                 if (    o3->op_type != OP_UNDEF
11280                     && (o3->op_type != OP_SREFGEN
11281                         || (  cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
11282                                 != OP_ANONCODE
11283                             && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
11284                                 != OP_RV2CV)))
11285                     bad_type_gv(arg, namegv, o3,
11286                             arg == 1 ? "block or sub {}" : "sub {}");
11287                 break;
11288             case '*':
11289                 /* '*' allows any scalar type, including bareword */
11290                 proto++;
11291                 arg++;
11292                 if (o3->op_type == OP_RV2GV)
11293                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
11294                 else if (o3->op_type == OP_CONST)
11295                     o3->op_private &= ~OPpCONST_STRICT;
11296                 scalar(aop);
11297                 break;
11298             case '+':
11299                 proto++;
11300                 arg++;
11301                 if (o3->op_type == OP_RV2AV ||
11302                     o3->op_type == OP_PADAV ||
11303                     o3->op_type == OP_RV2HV ||
11304                     o3->op_type == OP_PADHV
11305                 ) {
11306                     goto wrapref;
11307                 }
11308                 scalar(aop);
11309                 break;
11310             case '[': case ']':
11311                 goto oops;
11312
11313             case '\\':
11314                 proto++;
11315                 arg++;
11316             again:
11317                 switch (*proto++) {
11318                     case '[':
11319                         if (contextclass++ == 0) {
11320                             e = strchr(proto, ']');
11321                             if (!e || e == proto)
11322                                 goto oops;
11323                         }
11324                         else
11325                             goto oops;
11326                         goto again;
11327
11328                     case ']':
11329                         if (contextclass) {
11330                             const char *p = proto;
11331                             const char *const end = proto;
11332                             contextclass = 0;
11333                             while (*--p != '[')
11334                                 /* \[$] accepts any scalar lvalue */
11335                                 if (*p == '$'
11336                                  && Perl_op_lvalue_flags(aTHX_
11337                                      scalar(o3),
11338                                      OP_READ, /* not entersub */
11339                                      OP_LVALUE_NO_CROAK
11340                                     )) goto wrapref;
11341                             bad_type_gv(arg, namegv, o3,
11342                                     Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
11343                         } else
11344                             goto oops;
11345                         break;
11346                     case '*':
11347                         if (o3->op_type == OP_RV2GV)
11348                             goto wrapref;
11349                         if (!contextclass)
11350                             bad_type_gv(arg, namegv, o3, "symbol");
11351                         break;
11352                     case '&':
11353                         if (o3->op_type == OP_ENTERSUB
11354                          && !(o3->op_flags & OPf_STACKED))
11355                             goto wrapref;
11356                         if (!contextclass)
11357                             bad_type_gv(arg, namegv, o3, "subroutine");
11358                         break;
11359                     case '$':
11360                         if (o3->op_type == OP_RV2SV ||
11361                                 o3->op_type == OP_PADSV ||
11362                                 o3->op_type == OP_HELEM ||
11363                                 o3->op_type == OP_AELEM)
11364                             goto wrapref;
11365                         if (!contextclass) {
11366                             /* \$ accepts any scalar lvalue */
11367                             if (Perl_op_lvalue_flags(aTHX_
11368                                     scalar(o3),
11369                                     OP_READ,  /* not entersub */
11370                                     OP_LVALUE_NO_CROAK
11371                                )) goto wrapref;
11372                             bad_type_gv(arg, namegv, o3, "scalar");
11373                         }
11374                         break;
11375                     case '@':
11376                         if (o3->op_type == OP_RV2AV ||
11377                                 o3->op_type == OP_PADAV)
11378                         {
11379                             o3->op_flags &=~ OPf_PARENS;
11380                             goto wrapref;
11381                         }
11382                         if (!contextclass)
11383                             bad_type_gv(arg, namegv, o3, "array");
11384                         break;
11385                     case '%':
11386                         if (o3->op_type == OP_RV2HV ||
11387                                 o3->op_type == OP_PADHV)
11388                         {
11389                             o3->op_flags &=~ OPf_PARENS;
11390                             goto wrapref;
11391                         }
11392                         if (!contextclass)
11393                             bad_type_gv(arg, namegv, o3, "hash");
11394                         break;
11395                     wrapref:
11396                             aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
11397                                                 OP_REFGEN, 0);
11398                         if (contextclass && e) {
11399                             proto = e + 1;
11400                             contextclass = 0;
11401                         }
11402                         break;
11403                     default: goto oops;
11404                 }
11405                 if (contextclass)
11406                     goto again;
11407                 break;
11408             case ' ':
11409                 proto++;
11410                 continue;
11411             default:
11412             oops: {
11413                 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
11414                                   SVfARG(cv_name((CV *)namegv, NULL, 0)),
11415                                   SVfARG(protosv));
11416             }
11417         }
11418
11419         op_lvalue(aop, OP_ENTERSUB);
11420         prev = aop;
11421         aop = OpSIBLING(aop);
11422     }
11423     if (aop == cvop && *proto == '_') {
11424         /* generate an access to $_ */
11425         op_sibling_splice(parent, prev, 0, newDEFSVOP());
11426     }
11427     if (!optional && proto_end > proto &&
11428         (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
11429     {
11430         SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11431         yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf,
11432                                     SVfARG(namesv)), SvUTF8(namesv));
11433     }
11434     return entersubop;
11435 }
11436
11437 /*
11438 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
11439
11440 Performs the fixup of the arguments part of an C<entersub> op tree either
11441 based on a subroutine prototype or using default list-context processing.
11442 This is the standard treatment used on a subroutine call, not marked
11443 with C<&>, where the callee can be identified at compile time.
11444
11445 C<protosv> supplies the subroutine prototype to be applied to the call,
11446 or indicates that there is no prototype.  It may be a normal scalar,
11447 in which case if it is defined then the string value will be used
11448 as a prototype, and if it is undefined then there is no prototype.
11449 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11450 that has been cast to C<SV*>), of which the prototype will be used if it
11451 has one.  The prototype (or lack thereof) supplied, in whichever form,
11452 does not need to match the actual callee referenced by the op tree.
11453
11454 If the argument ops disagree with the prototype, for example by having
11455 an unacceptable number of arguments, a valid op tree is returned anyway.
11456 The error is reflected in the parser state, normally resulting in a single
11457 exception at the top level of parsing which covers all the compilation
11458 errors that occurred.  In the error message, the callee is referred to
11459 by the name defined by the C<namegv> parameter.
11460
11461 =cut
11462 */
11463
11464 OP *
11465 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
11466         GV *namegv, SV *protosv)
11467 {
11468     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
11469     if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
11470         return ck_entersub_args_proto(entersubop, namegv, protosv);
11471     else
11472         return ck_entersub_args_list(entersubop);
11473 }
11474
11475 OP *
11476 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11477 {
11478     int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
11479     OP *aop = cUNOPx(entersubop)->op_first;
11480
11481     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
11482
11483     if (!opnum) {
11484         OP *cvop;
11485         if (!OpHAS_SIBLING(aop))
11486             aop = cUNOPx(aop)->op_first;
11487         aop = OpSIBLING(aop);
11488         for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11489         if (aop != cvop)
11490             (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
11491
11492         op_free(entersubop);
11493         switch(GvNAME(namegv)[2]) {
11494         case 'F': return newSVOP(OP_CONST, 0,
11495                                         newSVpv(CopFILE(PL_curcop),0));
11496         case 'L': return newSVOP(
11497                            OP_CONST, 0,
11498                            Perl_newSVpvf(aTHX_
11499                              "%"IVdf, (IV)CopLINE(PL_curcop)
11500                            )
11501                          );
11502         case 'P': return newSVOP(OP_CONST, 0,
11503                                    (PL_curstash
11504                                      ? newSVhek(HvNAME_HEK(PL_curstash))
11505                                      : &PL_sv_undef
11506                                    )
11507                                 );
11508         }
11509         NOT_REACHED; /* NOTREACHED */
11510     }
11511     else {
11512         OP *prev, *cvop, *first, *parent;
11513         U32 flags = 0;
11514
11515         parent = entersubop;
11516         if (!OpHAS_SIBLING(aop)) {
11517             parent = aop;
11518             aop = cUNOPx(aop)->op_first;
11519         }
11520
11521         first = prev = aop;
11522         aop = OpSIBLING(aop);
11523         /* find last sibling */
11524         for (cvop = aop;
11525              OpHAS_SIBLING(cvop);
11526              prev = cvop, cvop = OpSIBLING(cvop))
11527             ;
11528         if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
11529             /* Usually, OPf_SPECIAL on an op with no args means that it had
11530              * parens, but these have their own meaning for that flag: */
11531             && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
11532             && opnum != OP_DELETE && opnum != OP_EXISTS)
11533                 flags |= OPf_SPECIAL;
11534         /* excise cvop from end of sibling chain */
11535         op_sibling_splice(parent, prev, 1, NULL);
11536         op_free(cvop);
11537         if (aop == cvop) aop = NULL;
11538
11539         /* detach remaining siblings from the first sibling, then
11540          * dispose of original optree */
11541
11542         if (aop)
11543             op_sibling_splice(parent, first, -1, NULL);
11544         op_free(entersubop);
11545
11546         if (opnum == OP_ENTEREVAL
11547          && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
11548             flags |= OPpEVAL_BYTES <<8;
11549
11550         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
11551         case OA_UNOP:
11552         case OA_BASEOP_OR_UNOP:
11553         case OA_FILESTATOP:
11554             return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
11555         case OA_BASEOP:
11556             if (aop) {
11557                     (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
11558                 op_free(aop);
11559             }
11560             return opnum == OP_RUNCV
11561                 ? newPVOP(OP_RUNCV,0,NULL)
11562                 : newOP(opnum,0);
11563         default:
11564             return op_convert_list(opnum,0,aop);
11565         }
11566     }
11567     NOT_REACHED; /* NOTREACHED */
11568     return entersubop;
11569 }
11570
11571 /*
11572 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
11573
11574 Retrieves the function that will be used to fix up a call to C<cv>.
11575 Specifically, the function is applied to an C<entersub> op tree for a
11576 subroutine call, not marked with C<&>, where the callee can be identified
11577 at compile time as C<cv>.
11578
11579 The C-level function pointer is returned in C<*ckfun_p>, and an SV
11580 argument for it is returned in C<*ckobj_p>.  The function is intended
11581 to be called in this manner:
11582
11583  entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
11584
11585 In this call, C<entersubop> is a pointer to the C<entersub> op,
11586 which may be replaced by the check function, and C<namegv> is a GV
11587 supplying the name that should be used by the check function to refer
11588 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11589 It is permitted to apply the check function in non-standard situations,
11590 such as to a call to a different subroutine or to a method call.
11591
11592 By default, the function is
11593 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
11594 and the SV parameter is C<cv> itself.  This implements standard
11595 prototype processing.  It can be changed, for a particular subroutine,
11596 by L</cv_set_call_checker>.
11597
11598 =cut
11599 */
11600
11601 static void
11602 S_cv_get_call_checker(CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p,
11603                       U8 *flagsp)
11604 {
11605     MAGIC *callmg;
11606     callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
11607     if (callmg) {
11608         *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
11609         *ckobj_p = callmg->mg_obj;
11610         if (flagsp) *flagsp = callmg->mg_flags;
11611     } else {
11612         *ckfun_p = Perl_ck_entersub_args_proto_or_list;
11613         *ckobj_p = (SV*)cv;
11614         if (flagsp) *flagsp = 0;
11615     }
11616 }
11617
11618 void
11619 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
11620 {
11621     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
11622     PERL_UNUSED_CONTEXT;
11623     S_cv_get_call_checker(cv, ckfun_p, ckobj_p, NULL);
11624 }
11625
11626 /*
11627 =for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 flags
11628
11629 Sets the function that will be used to fix up a call to C<cv>.
11630 Specifically, the function is applied to an C<entersub> op tree for a
11631 subroutine call, not marked with C<&>, where the callee can be identified
11632 at compile time as C<cv>.
11633
11634 The C-level function pointer is supplied in C<ckfun>, and an SV argument
11635 for it is supplied in C<ckobj>.  The function should be defined like this:
11636
11637     STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
11638
11639 It is intended to be called in this manner:
11640
11641     entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
11642
11643 In this call, C<entersubop> is a pointer to the C<entersub> op,
11644 which may be replaced by the check function, and C<namegv> supplies
11645 the name that should be used by the check function to refer
11646 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11647 It is permitted to apply the check function in non-standard situations,
11648 such as to a call to a different subroutine or to a method call.
11649
11650 C<namegv> may not actually be a GV.  For efficiency, perl may pass a
11651 CV or other SV instead.  Whatever is passed can be used as the first
11652 argument to L</cv_name>.  You can force perl to pass a GV by including
11653 C<CALL_CHECKER_REQUIRE_GV> in the C<flags>.
11654
11655 The current setting for a particular CV can be retrieved by
11656 L</cv_get_call_checker>.
11657
11658 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
11659
11660 The original form of L</cv_set_call_checker_flags>, which passes it the
11661 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.
11662
11663 =cut
11664 */
11665
11666 void
11667 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
11668 {
11669     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
11670     cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
11671 }
11672
11673 void
11674 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
11675                                      SV *ckobj, U32 flags)
11676 {
11677     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
11678     if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
11679         if (SvMAGICAL((SV*)cv))
11680             mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
11681     } else {
11682         MAGIC *callmg;
11683         sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
11684         callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
11685         assert(callmg);
11686         if (callmg->mg_flags & MGf_REFCOUNTED) {
11687             SvREFCNT_dec(callmg->mg_obj);
11688             callmg->mg_flags &= ~MGf_REFCOUNTED;
11689         }
11690         callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
11691         callmg->mg_obj = ckobj;
11692         if (ckobj != (SV*)cv) {
11693             SvREFCNT_inc_simple_void_NN(ckobj);
11694             callmg->mg_flags |= MGf_REFCOUNTED;
11695         }
11696         callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
11697                          | (U8)(flags & MGf_REQUIRE_GV) | MGf_COPY;
11698     }
11699 }
11700
11701 static void
11702 S_entersub_alloc_targ(pTHX_ OP * const o)
11703 {
11704     o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
11705     o->op_private |= OPpENTERSUB_HASTARG;
11706 }
11707
11708 OP *
11709 Perl_ck_subr(pTHX_ OP *o)
11710 {
11711     OP *aop, *cvop;
11712     CV *cv;
11713     GV *namegv;
11714     SV **const_class = NULL;
11715
11716     PERL_ARGS_ASSERT_CK_SUBR;
11717
11718     aop = cUNOPx(o)->op_first;
11719     if (!OpHAS_SIBLING(aop))
11720         aop = cUNOPx(aop)->op_first;
11721     aop = OpSIBLING(aop);
11722     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11723     cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
11724     namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
11725
11726     o->op_private &= ~1;
11727     o->op_private |= (PL_hints & HINT_STRICT_REFS);
11728     if (PERLDB_SUB && PL_curstash != PL_debstash)
11729         o->op_private |= OPpENTERSUB_DB;
11730     switch (cvop->op_type) {
11731         case OP_RV2CV:
11732             o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
11733             op_null(cvop);
11734             break;
11735         case OP_METHOD:
11736         case OP_METHOD_NAMED:
11737         case OP_METHOD_SUPER:
11738         case OP_METHOD_REDIR:
11739         case OP_METHOD_REDIR_SUPER:
11740             if (aop->op_type == OP_CONST) {
11741                 aop->op_private &= ~OPpCONST_STRICT;
11742                 const_class = &cSVOPx(aop)->op_sv;
11743             }
11744             else if (aop->op_type == OP_LIST) {
11745                 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
11746                 if (sib && sib->op_type == OP_CONST) {
11747                     sib->op_private &= ~OPpCONST_STRICT;
11748                     const_class = &cSVOPx(sib)->op_sv;
11749                 }
11750             }
11751             /* make class name a shared cow string to speedup method calls */
11752             /* constant string might be replaced with object, f.e. bigint */
11753             if (const_class && SvPOK(*const_class)) {
11754                 STRLEN len;
11755                 const char* str = SvPV(*const_class, len);
11756                 if (len) {
11757                     SV* const shared = newSVpvn_share(
11758                         str, SvUTF8(*const_class)
11759                                     ? -(SSize_t)len : (SSize_t)len,
11760                         0
11761                     );
11762                     if (SvREADONLY(*const_class))
11763                         SvREADONLY_on(shared);
11764                     SvREFCNT_dec(*const_class);
11765                     *const_class = shared;
11766                 }
11767             }
11768             break;
11769     }
11770
11771     if (!cv) {
11772         S_entersub_alloc_targ(aTHX_ o);
11773         return ck_entersub_args_list(o);
11774     } else {
11775         Perl_call_checker ckfun;
11776         SV *ckobj;
11777         U8 flags;
11778         S_cv_get_call_checker(cv, &ckfun, &ckobj, &flags);
11779         if (CvISXSUB(cv) || !CvROOT(cv))
11780             S_entersub_alloc_targ(aTHX_ o);
11781         if (!namegv) {
11782             /* The original call checker API guarantees that a GV will be
11783                be provided with the right name.  So, if the old API was
11784                used (or the REQUIRE_GV flag was passed), we have to reify
11785                the CV’s GV, unless this is an anonymous sub.  This is not
11786                ideal for lexical subs, as its stringification will include
11787                the package.  But it is the best we can do.  */
11788             if (flags & MGf_REQUIRE_GV) {
11789                 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
11790                     namegv = CvGV(cv);
11791             }
11792             else namegv = MUTABLE_GV(cv);
11793             /* After a syntax error in a lexical sub, the cv that
11794                rv2cv_op_cv returns may be a nameless stub. */
11795             if (!namegv) return ck_entersub_args_list(o);
11796
11797         }
11798         return ckfun(aTHX_ o, namegv, ckobj);
11799     }
11800 }
11801
11802 OP *
11803 Perl_ck_svconst(pTHX_ OP *o)
11804 {
11805     SV * const sv = cSVOPo->op_sv;
11806     PERL_ARGS_ASSERT_CK_SVCONST;
11807     PERL_UNUSED_CONTEXT;
11808 #ifdef PERL_COPY_ON_WRITE
11809     /* Since the read-only flag may be used to protect a string buffer, we
11810        cannot do copy-on-write with existing read-only scalars that are not
11811        already copy-on-write scalars.  To allow $_ = "hello" to do COW with
11812        that constant, mark the constant as COWable here, if it is not
11813        already read-only. */
11814     if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
11815         SvIsCOW_on(sv);
11816         CowREFCNT(sv) = 0;
11817 # ifdef PERL_DEBUG_READONLY_COW
11818         sv_buf_to_ro(sv);
11819 # endif
11820     }
11821 #endif
11822     SvREADONLY_on(sv);
11823     return o;
11824 }
11825
11826 OP *
11827 Perl_ck_trunc(pTHX_ OP *o)
11828 {
11829     PERL_ARGS_ASSERT_CK_TRUNC;
11830
11831     if (o->op_flags & OPf_KIDS) {
11832         SVOP *kid = (SVOP*)cUNOPo->op_first;
11833
11834         if (kid->op_type == OP_NULL)
11835             kid = (SVOP*)OpSIBLING(kid);
11836         if (kid && kid->op_type == OP_CONST &&
11837             (kid->op_private & OPpCONST_BARE) &&
11838             !kid->op_folded)
11839         {
11840             o->op_flags |= OPf_SPECIAL;
11841             kid->op_private &= ~OPpCONST_STRICT;
11842         }
11843     }
11844     return ck_fun(o);
11845 }
11846
11847 OP *
11848 Perl_ck_substr(pTHX_ OP *o)
11849 {
11850     PERL_ARGS_ASSERT_CK_SUBSTR;
11851
11852     o = ck_fun(o);
11853     if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
11854         OP *kid = cLISTOPo->op_first;
11855
11856         if (kid->op_type == OP_NULL)
11857             kid = OpSIBLING(kid);
11858         if (kid)
11859             kid->op_flags |= OPf_MOD;
11860
11861     }
11862     return o;
11863 }
11864
11865 OP *
11866 Perl_ck_tell(pTHX_ OP *o)
11867 {
11868     PERL_ARGS_ASSERT_CK_TELL;
11869     o = ck_fun(o);
11870     if (o->op_flags & OPf_KIDS) {
11871      OP *kid = cLISTOPo->op_first;
11872      if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
11873      if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
11874     }
11875     return o;
11876 }
11877
11878 OP *
11879 Perl_ck_each(pTHX_ OP *o)
11880 {
11881     dVAR;
11882     OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
11883     const unsigned orig_type  = o->op_type;
11884
11885     PERL_ARGS_ASSERT_CK_EACH;
11886
11887     if (kid) {
11888         switch (kid->op_type) {
11889             case OP_PADHV:
11890             case OP_RV2HV:
11891                 break;
11892             case OP_PADAV:
11893             case OP_RV2AV:
11894                 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
11895                             : orig_type == OP_KEYS ? OP_AKEYS
11896                             :                        OP_AVALUES);
11897                 break;
11898             case OP_CONST:
11899                 if (kid->op_private == OPpCONST_BARE
11900                  || !SvROK(cSVOPx_sv(kid))
11901                  || (  SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
11902                     && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV  )
11903                    )
11904                     /* we let ck_fun handle it */
11905                     break;
11906             default:
11907                 Perl_croak_nocontext(
11908                     "Experimental %s on scalar is now forbidden",
11909                     PL_op_desc[orig_type]);
11910                 break;
11911         }
11912     }
11913     return ck_fun(o);
11914 }
11915
11916 OP *
11917 Perl_ck_length(pTHX_ OP *o)
11918 {
11919     PERL_ARGS_ASSERT_CK_LENGTH;
11920
11921     o = ck_fun(o);
11922
11923     if (ckWARN(WARN_SYNTAX)) {
11924         const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
11925
11926         if (kid) {
11927             SV *name = NULL;
11928             const bool hash = kid->op_type == OP_PADHV
11929                            || kid->op_type == OP_RV2HV;
11930             switch (kid->op_type) {
11931                 case OP_PADHV:
11932                 case OP_PADAV:
11933                 case OP_RV2HV:
11934                 case OP_RV2AV:
11935                     name = S_op_varname(aTHX_ kid);
11936                     break;
11937                 default:
11938                     return o;
11939             }
11940             if (name)
11941                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11942                     "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
11943                     ")\"?)",
11944                     SVfARG(name), hash ? "keys " : "", SVfARG(name)
11945                 );
11946             else if (hash)
11947      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
11948                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11949                     "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
11950             else
11951      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
11952                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11953                     "length() used on @array (did you mean \"scalar(@array)\"?)");
11954         }
11955     }
11956
11957     return o;
11958 }
11959
11960
11961
11962 /*
11963    ---------------------------------------------------------
11964
11965    Common vars in list assignment
11966
11967    There now follows some enums and static functions for detecting
11968    common variables in list assignments. Here is a little essay I wrote
11969    for myself when trying to get my head around this. DAPM.
11970
11971    ----
11972
11973    First some random observations:
11974
11975    * If a lexical var is an alias of something else, e.g.
11976        for my $x ($lex, $pkg, $a[0]) {...}
11977      then the act of aliasing will increase the reference count of the SV
11978
11979    * If a package var is an alias of something else, it may still have a
11980      reference count of 1, depending on how the alias was created, e.g.
11981      in *a = *b, $a may have a refcount of 1 since the GP is shared
11982      with a single GvSV pointer to the SV. So If it's an alias of another
11983      package var, then RC may be 1; if it's an alias of another scalar, e.g.
11984      a lexical var or an array element, then it will have RC > 1.
11985
11986    * There are many ways to create a package alias; ultimately, XS code
11987      may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
11988      run-time tracing mechanisms are unlikely to be able to catch all cases.
11989
11990    * When the LHS is all my declarations, the same vars can't appear directly
11991      on the RHS, but they can indirectly via closures, aliasing and lvalue
11992      subs. But those techniques all involve an increase in the lexical
11993      scalar's ref count.
11994
11995    * When the LHS is all lexical vars (but not necessarily my declarations),
11996      it is possible for the same lexicals to appear directly on the RHS, and
11997      without an increased ref count, since the stack isn't refcounted.
11998      This case can be detected at compile time by scanning for common lex
11999      vars with PL_generation.
12000
12001    * lvalue subs defeat common var detection, but they do at least
12002      return vars with a temporary ref count increment. Also, you can't
12003      tell at compile time whether a sub call is lvalue.
12004
12005
12006    So...
12007
12008    A: There are a few circumstances where there definitely can't be any
12009      commonality:
12010
12011        LHS empty:  () = (...);
12012        RHS empty:  (....) = ();
12013        RHS contains only constants or other 'can't possibly be shared'
12014            elements (e.g. ops that return PADTMPs):  (...) = (1,2, length)
12015            i.e. they only contain ops not marked as dangerous, whose children
12016            are also not dangerous;
12017        LHS ditto;
12018        LHS contains a single scalar element: e.g. ($x) = (....); because
12019            after $x has been modified, it won't be used again on the RHS;
12020        RHS contains a single element with no aggregate on LHS: e.g.
12021            ($a,$b,$c)  = ($x); again, once $a has been modified, its value
12022            won't be used again.
12023
12024    B: If LHS are all 'my' lexical var declarations (or safe ops, which
12025      we can ignore):
12026
12027        my ($a, $b, @c) = ...;
12028
12029        Due to closure and goto tricks, these vars may already have content.
12030        For the same reason, an element on the RHS may be a lexical or package
12031        alias of one of the vars on the left, or share common elements, for
12032        example:
12033
12034            my ($x,$y) = f(); # $x and $y on both sides
12035            sub f : lvalue { ($x,$y) = (1,2); $y, $x }
12036
12037        and
12038
12039            my $ra = f();
12040            my @a = @$ra;  # elements of @a on both sides
12041            sub f { @a = 1..4; \@a }
12042
12043
12044        First, just consider scalar vars on LHS:
12045
12046            RHS is safe only if (A), or in addition,
12047                * contains only lexical *scalar* vars, where neither side's
12048                  lexicals have been flagged as aliases
12049
12050            If RHS is not safe, then it's always legal to check LHS vars for
12051            RC==1, since the only RHS aliases will always be associated
12052            with an RC bump.
12053
12054            Note that in particular, RHS is not safe if:
12055
12056                * it contains package scalar vars; e.g.:
12057
12058                    f();
12059                    my ($x, $y) = (2, $x_alias);
12060                    sub f { $x = 1; *x_alias = \$x; }
12061
12062                * It contains other general elements, such as flattened or
12063                * spliced or single array or hash elements, e.g.
12064
12065                    f();
12066                    my ($x,$y) = @a; # or $a[0] or @a{@b} etc
12067
12068                    sub f {
12069                        ($x, $y) = (1,2);
12070                        use feature 'refaliasing';
12071                        \($a[0], $a[1]) = \($y,$x);
12072                    }
12073
12074                  It doesn't matter if the array/hash is lexical or package.
12075
12076                * it contains a function call that happens to be an lvalue
12077                  sub which returns one or more of the above, e.g.
12078
12079                    f();
12080                    my ($x,$y) = f();
12081
12082                    sub f : lvalue {
12083                        ($x, $y) = (1,2);
12084                        *x1 = \$x;
12085                        $y, $x1;
12086                    }
12087
12088                    (so a sub call on the RHS should be treated the same
12089                    as having a package var on the RHS).
12090
12091                * any other "dangerous" thing, such an op or built-in that
12092                  returns one of the above, e.g. pp_preinc
12093
12094
12095            If RHS is not safe, what we can do however is at compile time flag
12096            that the LHS are all my declarations, and at run time check whether
12097            all the LHS have RC == 1, and if so skip the full scan.
12098
12099        Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
12100
12101            Here the issue is whether there can be elements of @a on the RHS
12102            which will get prematurely freed when @a is cleared prior to
12103            assignment. This is only a problem if the aliasing mechanism
12104            is one which doesn't increase the refcount - only if RC == 1
12105            will the RHS element be prematurely freed.
12106
12107            Because the array/hash is being INTROed, it or its elements
12108            can't directly appear on the RHS:
12109
12110                my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
12111
12112            but can indirectly, e.g.:
12113
12114                my $r = f();
12115                my (@a) = @$r;
12116                sub f { @a = 1..3; \@a }
12117
12118            So if the RHS isn't safe as defined by (A), we must always
12119            mortalise and bump the ref count of any remaining RHS elements
12120            when assigning to a non-empty LHS aggregate.
12121
12122            Lexical scalars on the RHS aren't safe if they've been involved in
12123            aliasing, e.g.
12124
12125                use feature 'refaliasing';
12126
12127                f();
12128                \(my $lex) = \$pkg;
12129                my @a = ($lex,3); # equivalent to ($a[0],3)
12130
12131                sub f {
12132                    @a = (1,2);
12133                    \$pkg = \$a[0];
12134                }
12135
12136            Similarly with lexical arrays and hashes on the RHS:
12137
12138                f();
12139                my @b;
12140                my @a = (@b);
12141
12142                sub f {
12143                    @a = (1,2);
12144                    \$b[0] = \$a[1];
12145                    \$b[1] = \$a[0];
12146                }
12147
12148
12149
12150    C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
12151        my $a; ($a, my $b) = (....);
12152
12153        The difference between (B) and (C) is that it is now physically
12154        possible for the LHS vars to appear on the RHS too, where they
12155        are not reference counted; but in this case, the compile-time
12156        PL_generation sweep will detect such common vars.
12157
12158        So the rules for (C) differ from (B) in that if common vars are
12159        detected, the runtime "test RC==1" optimisation can no longer be used,
12160        and a full mark and sweep is required
12161
12162    D: As (C), but in addition the LHS may contain package vars.
12163
12164        Since package vars can be aliased without a corresponding refcount
12165        increase, all bets are off. It's only safe if (A). E.g.
12166
12167            my ($x, $y) = (1,2);
12168
12169            for $x_alias ($x) {
12170                ($x_alias, $y) = (3, $x); # whoops
12171            }
12172
12173        Ditto for LHS aggregate package vars.
12174
12175    E: Any other dangerous ops on LHS, e.g.
12176            (f(), $a[0], @$r) = (...);
12177
12178        this is similar to (E) in that all bets are off. In addition, it's
12179        impossible to determine at compile time whether the LHS
12180        contains a scalar or an aggregate, e.g.
12181
12182            sub f : lvalue { @a }
12183            (f()) = 1..3;
12184
12185 * ---------------------------------------------------------
12186 */
12187
12188
12189 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates
12190  * that at least one of the things flagged was seen.
12191  */
12192
12193 enum {
12194     AAS_MY_SCALAR       = 0x001, /* my $scalar */
12195     AAS_MY_AGG          = 0x002, /* aggregate: my @array or my %hash */
12196     AAS_LEX_SCALAR      = 0x004, /* $lexical */
12197     AAS_LEX_AGG         = 0x008, /* @lexical or %lexical aggregate */
12198     AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
12199     AAS_PKG_SCALAR      = 0x020, /* $scalar (where $scalar is pkg var) */
12200     AAS_PKG_AGG         = 0x040, /* package @array or %hash aggregate */
12201     AAS_DANGEROUS       = 0x080, /* an op (other than the above)
12202                                          that's flagged OA_DANGEROUS */
12203     AAS_SAFE_SCALAR     = 0x100, /* produces at least one scalar SV that's
12204                                         not in any of the categories above */
12205     AAS_DEFAV           = 0x200  /* contains just a single '@_' on RHS */
12206 };
12207
12208
12209
12210 /* helper function for S_aassign_scan().
12211  * check a PAD-related op for commonality and/or set its generation number.
12212  * Returns a boolean indicating whether its shared */
12213
12214 static bool
12215 S_aassign_padcheck(pTHX_ OP* o, bool rhs)
12216 {
12217     if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
12218         /* lexical used in aliasing */
12219         return TRUE;
12220
12221     if (rhs)
12222         return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
12223     else
12224         PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
12225
12226     return FALSE;
12227 }
12228
12229
12230 /*
12231   Helper function for OPpASSIGN_COMMON* detection in rpeep().
12232   It scans the left or right hand subtree of the aassign op, and returns a
12233   set of flags indicating what sorts of things it found there.
12234   'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
12235   set PL_generation on lexical vars; if the latter, we see if
12236   PL_generation matches.
12237   'top' indicates whether we're recursing or at the top level.
12238   'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
12239   This fn will increment it by the number seen. It's not intended to
12240   be an accurate count (especially as many ops can push a variable
12241   number of SVs onto the stack); rather it's used as to test whether there
12242   can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
12243 */
12244
12245 static int
12246 S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *scalars_p)
12247 {
12248     int flags = 0;
12249     bool kid_top = FALSE;
12250
12251     /* first, look for a solitary @_ on the RHS */
12252     if (   rhs
12253         && top
12254         && (o->op_flags & OPf_KIDS)
12255         && OP_TYPE_IS_OR_WAS(o, OP_LIST)
12256     ) {
12257         OP *kid = cUNOPo->op_first;
12258         if (   (   kid->op_type == OP_PUSHMARK
12259                 || kid->op_type == OP_PADRANGE) /* ex-pushmark */
12260             && ((kid = OpSIBLING(kid)))
12261             && !OpHAS_SIBLING(kid)
12262             && kid->op_type == OP_RV2AV
12263             && !(kid->op_flags & OPf_REF)
12264             && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
12265             && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
12266             && ((kid = cUNOPx(kid)->op_first))
12267             && kid->op_type == OP_GV
12268             && cGVOPx_gv(kid) == PL_defgv
12269         )
12270             flags |= AAS_DEFAV;
12271     }
12272
12273     switch (o->op_type) {
12274     case OP_GVSV:
12275         (*scalars_p)++;
12276         return AAS_PKG_SCALAR;
12277
12278     case OP_PADAV:
12279     case OP_PADHV:
12280         (*scalars_p) += 2;
12281         if (top && (o->op_flags & OPf_REF))
12282             return (o->op_private & OPpLVAL_INTRO)
12283                 ? AAS_MY_AGG : AAS_LEX_AGG;
12284         return AAS_DANGEROUS;
12285
12286     case OP_PADSV:
12287         {
12288             int comm = S_aassign_padcheck(aTHX_ o, rhs)
12289                         ?  AAS_LEX_SCALAR_COMM : 0;
12290             (*scalars_p)++;
12291             return (o->op_private & OPpLVAL_INTRO)
12292                 ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
12293         }
12294
12295     case OP_RV2AV:
12296     case OP_RV2HV:
12297         (*scalars_p) += 2;
12298         if (cUNOPx(o)->op_first->op_type != OP_GV)
12299             return AAS_DANGEROUS; /* @{expr}, %{expr} */
12300         /* @pkg, %pkg */
12301         if (top && (o->op_flags & OPf_REF))
12302             return AAS_PKG_AGG;
12303         return AAS_DANGEROUS;
12304
12305     case OP_RV2SV:
12306         (*scalars_p)++;
12307         if (cUNOPx(o)->op_first->op_type != OP_GV) {
12308             (*scalars_p) += 2;
12309             return AAS_DANGEROUS; /* ${expr} */
12310         }
12311         return AAS_PKG_SCALAR; /* $pkg */
12312
12313     case OP_SPLIT:
12314         if (cLISTOPo->op_first->op_type == OP_PUSHRE) {
12315             /* "@foo = split... " optimises away the aassign and stores its
12316              * destination array in the OP_PUSHRE that precedes it.
12317              * A flattened array is always dangerous.
12318              */
12319             (*scalars_p) += 2;
12320             return AAS_DANGEROUS;
12321         }
12322         break;
12323
12324     case OP_UNDEF:
12325         /* undef counts as a scalar on the RHS:
12326          *   (undef, $x) = ...;         # only 1 scalar on LHS: always safe
12327          *   ($x, $y)    = (undef, $x); # 2 scalars on RHS: unsafe
12328          */
12329         if (rhs)
12330             (*scalars_p)++;
12331         flags = AAS_SAFE_SCALAR;
12332         break;
12333
12334     case OP_PUSHMARK:
12335     case OP_STUB:
12336         /* these are all no-ops; they don't push a potentially common SV
12337          * onto the stack, so they are neither AAS_DANGEROUS nor
12338          * AAS_SAFE_SCALAR */
12339         return 0;
12340
12341     case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
12342         break;
12343
12344     case OP_NULL:
12345     case OP_LIST:
12346         /* these do nothing but may have children; but their children
12347          * should also be treated as top-level */
12348         kid_top = top;
12349         break;
12350
12351     default:
12352         if (PL_opargs[o->op_type] & OA_DANGEROUS) {
12353             (*scalars_p) += 2;
12354             flags = AAS_DANGEROUS;
12355             break;
12356         }
12357
12358         if (   (PL_opargs[o->op_type] & OA_TARGLEX)
12359             && (o->op_private & OPpTARGET_MY))
12360         {
12361             (*scalars_p)++;
12362             return S_aassign_padcheck(aTHX_ o, rhs)
12363                 ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
12364         }
12365
12366         /* if its an unrecognised, non-dangerous op, assume that it
12367          * it the cause of at least one safe scalar */
12368         (*scalars_p)++;
12369         flags = AAS_SAFE_SCALAR;
12370         break;
12371     }
12372
12373     if (o->op_flags & OPf_KIDS) {
12374         OP *kid;
12375         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
12376             flags |= S_aassign_scan(aTHX_ kid, rhs, kid_top, scalars_p);
12377     }
12378     return flags;
12379 }
12380
12381
12382 /* Check for in place reverse and sort assignments like "@a = reverse @a"
12383    and modify the optree to make them work inplace */
12384
12385 STATIC void
12386 S_inplace_aassign(pTHX_ OP *o) {
12387
12388     OP *modop, *modop_pushmark;
12389     OP *oright;
12390     OP *oleft, *oleft_pushmark;
12391
12392     PERL_ARGS_ASSERT_INPLACE_AASSIGN;
12393
12394     assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
12395
12396     assert(cUNOPo->op_first->op_type == OP_NULL);
12397     modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
12398     assert(modop_pushmark->op_type == OP_PUSHMARK);
12399     modop = OpSIBLING(modop_pushmark);
12400
12401     if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
12402         return;
12403
12404     /* no other operation except sort/reverse */
12405     if (OpHAS_SIBLING(modop))
12406         return;
12407
12408     assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
12409     if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
12410
12411     if (modop->op_flags & OPf_STACKED) {
12412         /* skip sort subroutine/block */
12413         assert(oright->op_type == OP_NULL);
12414         oright = OpSIBLING(oright);
12415     }
12416
12417     assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
12418     oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
12419     assert(oleft_pushmark->op_type == OP_PUSHMARK);
12420     oleft = OpSIBLING(oleft_pushmark);
12421
12422     /* Check the lhs is an array */
12423     if (!oleft ||
12424         (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
12425         || OpHAS_SIBLING(oleft)
12426         || (oleft->op_private & OPpLVAL_INTRO)
12427     )
12428         return;
12429
12430     /* Only one thing on the rhs */
12431     if (OpHAS_SIBLING(oright))
12432         return;
12433
12434     /* check the array is the same on both sides */
12435     if (oleft->op_type == OP_RV2AV) {
12436         if (oright->op_type != OP_RV2AV
12437             || !cUNOPx(oright)->op_first
12438             || cUNOPx(oright)->op_first->op_type != OP_GV
12439             || cUNOPx(oleft )->op_first->op_type != OP_GV
12440             || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
12441                cGVOPx_gv(cUNOPx(oright)->op_first)
12442         )
12443             return;
12444     }
12445     else if (oright->op_type != OP_PADAV
12446         || oright->op_targ != oleft->op_targ
12447     )
12448         return;
12449
12450     /* This actually is an inplace assignment */
12451
12452     modop->op_private |= OPpSORT_INPLACE;
12453
12454     /* transfer MODishness etc from LHS arg to RHS arg */
12455     oright->op_flags = oleft->op_flags;
12456
12457     /* remove the aassign op and the lhs */
12458     op_null(o);
12459     op_null(oleft_pushmark);
12460     if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
12461         op_null(cUNOPx(oleft)->op_first);
12462     op_null(oleft);
12463 }
12464
12465
12466
12467 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
12468  * that potentially represent a series of one or more aggregate derefs
12469  * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
12470  * the whole chain to a single OP_MULTIDEREF op (maybe with a few
12471  * additional ops left in too).
12472  *
12473  * The caller will have already verified that the first few ops in the
12474  * chain following 'start' indicate a multideref candidate, and will have
12475  * set 'orig_o' to the point further on in the chain where the first index
12476  * expression (if any) begins.  'orig_action' specifies what type of
12477  * beginning has already been determined by the ops between start..orig_o
12478  * (e.g.  $lex_ary[], $pkg_ary->{}, expr->[], etc).
12479  *
12480  * 'hints' contains any hints flags that need adding (currently just
12481  * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
12482  */
12483
12484 STATIC void
12485 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
12486 {
12487     dVAR;
12488     int pass;
12489     UNOP_AUX_item *arg_buf = NULL;
12490     bool reset_start_targ  = FALSE; /* start->op_targ needs zeroing */
12491     int index_skip         = -1;    /* don't output index arg on this action */
12492
12493     /* similar to regex compiling, do two passes; the first pass
12494      * determines whether the op chain is convertible and calculates the
12495      * buffer size; the second pass populates the buffer and makes any
12496      * changes necessary to ops (such as moving consts to the pad on
12497      * threaded builds).
12498      *
12499      * NB: for things like Coverity, note that both passes take the same
12500      * path through the logic tree (except for 'if (pass)' bits), since
12501      * both passes are following the same op_next chain; and in
12502      * particular, if it would return early on the second pass, it would
12503      * already have returned early on the first pass.
12504      */
12505     for (pass = 0; pass < 2; pass++) {
12506         OP *o                = orig_o;
12507         UV action            = orig_action;
12508         OP *first_elem_op    = NULL;  /* first seen aelem/helem */
12509         OP *top_op           = NULL;  /* highest [ah]elem/exists/del/rv2[ah]v */
12510         int action_count     = 0;     /* number of actions seen so far */
12511         int action_ix        = 0;     /* action_count % (actions per IV) */
12512         bool next_is_hash    = FALSE; /* is the next lookup to be a hash? */
12513         bool is_last         = FALSE; /* no more derefs to follow */
12514         bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
12515         UNOP_AUX_item *arg     = arg_buf;
12516         UNOP_AUX_item *action_ptr = arg_buf;
12517
12518         if (pass)
12519             action_ptr->uv = 0;
12520         arg++;
12521
12522         switch (action) {
12523         case MDEREF_HV_gvsv_vivify_rv2hv_helem:
12524         case MDEREF_HV_gvhv_helem:
12525             next_is_hash = TRUE;
12526             /* FALLTHROUGH */
12527         case MDEREF_AV_gvsv_vivify_rv2av_aelem:
12528         case MDEREF_AV_gvav_aelem:
12529             if (pass) {
12530 #ifdef USE_ITHREADS
12531                 arg->pad_offset = cPADOPx(start)->op_padix;
12532                 /* stop it being swiped when nulled */
12533                 cPADOPx(start)->op_padix = 0;
12534 #else
12535                 arg->sv = cSVOPx(start)->op_sv;
12536                 cSVOPx(start)->op_sv = NULL;
12537 #endif
12538             }
12539             arg++;
12540             break;
12541
12542         case MDEREF_HV_padhv_helem:
12543         case MDEREF_HV_padsv_vivify_rv2hv_helem:
12544             next_is_hash = TRUE;
12545             /* FALLTHROUGH */
12546         case MDEREF_AV_padav_aelem:
12547         case MDEREF_AV_padsv_vivify_rv2av_aelem:
12548             if (pass) {
12549                 arg->pad_offset = start->op_targ;
12550                 /* we skip setting op_targ = 0 for now, since the intact
12551                  * OP_PADXV is needed by S_check_hash_fields_and_hekify */
12552                 reset_start_targ = TRUE;
12553             }
12554             arg++;
12555             break;
12556
12557         case MDEREF_HV_pop_rv2hv_helem:
12558             next_is_hash = TRUE;
12559             /* FALLTHROUGH */
12560         case MDEREF_AV_pop_rv2av_aelem:
12561             break;
12562
12563         default:
12564             NOT_REACHED; /* NOTREACHED */
12565             return;
12566         }
12567
12568         while (!is_last) {
12569             /* look for another (rv2av/hv; get index;
12570              * aelem/helem/exists/delele) sequence */
12571
12572             OP *kid;
12573             bool is_deref;
12574             bool ok;
12575             UV index_type = MDEREF_INDEX_none;
12576
12577             if (action_count) {
12578                 /* if this is not the first lookup, consume the rv2av/hv  */
12579
12580                 /* for N levels of aggregate lookup, we normally expect
12581                  * that the first N-1 [ah]elem ops will be flagged as
12582                  * /DEREF (so they autovivifiy if necessary), and the last
12583                  * lookup op not to be.
12584                  * For other things (like @{$h{k1}{k2}}) extra scope or
12585                  * leave ops can appear, so abandon the effort in that
12586                  * case */
12587                 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
12588                     return;
12589
12590                 /* rv2av or rv2hv sKR/1 */
12591
12592                 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12593                                             |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12594                 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
12595                     return;
12596
12597                 /* at this point, we wouldn't expect any of these
12598                  * possible private flags:
12599                  * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
12600                  * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
12601                  */
12602                 ASSUME(!(o->op_private &
12603                     ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
12604
12605                 hints = (o->op_private & OPpHINT_STRICT_REFS);
12606
12607                 /* make sure the type of the previous /DEREF matches the
12608                  * type of the next lookup */
12609                 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
12610                 top_op = o;
12611
12612                 action = next_is_hash
12613                             ? MDEREF_HV_vivify_rv2hv_helem
12614                             : MDEREF_AV_vivify_rv2av_aelem;
12615                 o = o->op_next;
12616             }
12617
12618             /* if this is the second pass, and we're at the depth where
12619              * previously we encountered a non-simple index expression,
12620              * stop processing the index at this point */
12621             if (action_count != index_skip) {
12622
12623                 /* look for one or more simple ops that return an array
12624                  * index or hash key */
12625
12626                 switch (o->op_type) {
12627                 case OP_PADSV:
12628                     /* it may be a lexical var index */
12629                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
12630                                             |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12631                     ASSUME(!(o->op_private &
12632                             ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
12633
12634                     if (   OP_GIMME(o,0) == G_SCALAR
12635                         && !(o->op_flags & (OPf_REF|OPf_MOD))
12636                         && o->op_private == 0)
12637                     {
12638                         if (pass)
12639                             arg->pad_offset = o->op_targ;
12640                         arg++;
12641                         index_type = MDEREF_INDEX_padsv;
12642                         o = o->op_next;
12643                     }
12644                     break;
12645
12646                 case OP_CONST:
12647                     if (next_is_hash) {
12648                         /* it's a constant hash index */
12649                         if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
12650                             /* "use constant foo => FOO; $h{+foo}" for
12651                              * some weird FOO, can leave you with constants
12652                              * that aren't simple strings. It's not worth
12653                              * the extra hassle for those edge cases */
12654                             break;
12655
12656                         if (pass) {
12657                             UNOP *rop = NULL;
12658                             OP * helem_op = o->op_next;
12659
12660                             ASSUME(   helem_op->op_type == OP_HELEM
12661                                    || helem_op->op_type == OP_NULL);
12662                             if (helem_op->op_type == OP_HELEM) {
12663                                 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
12664                                 if (   helem_op->op_private & OPpLVAL_INTRO
12665                                     || rop->op_type != OP_RV2HV
12666                                 )
12667                                     rop = NULL;
12668                             }
12669                             S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo);
12670
12671 #ifdef USE_ITHREADS
12672                             /* Relocate sv to the pad for thread safety */
12673                             op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
12674                             arg->pad_offset = o->op_targ;
12675                             o->op_targ = 0;
12676 #else
12677                             arg->sv = cSVOPx_sv(o);
12678 #endif
12679                         }
12680                     }
12681                     else {
12682                         /* it's a constant array index */
12683                         IV iv;
12684                         SV *ix_sv = cSVOPo->op_sv;
12685                         if (!SvIOK(ix_sv))
12686                             break;
12687                         iv = SvIV(ix_sv);
12688
12689                         if (   action_count == 0
12690                             && iv >= -128
12691                             && iv <= 127
12692                             && (   action == MDEREF_AV_padav_aelem
12693                                 || action == MDEREF_AV_gvav_aelem)
12694                         )
12695                             maybe_aelemfast = TRUE;
12696
12697                         if (pass) {
12698                             arg->iv = iv;
12699                             SvREFCNT_dec_NN(cSVOPo->op_sv);
12700                         }
12701                     }
12702                     if (pass)
12703                         /* we've taken ownership of the SV */
12704                         cSVOPo->op_sv = NULL;
12705                     arg++;
12706                     index_type = MDEREF_INDEX_const;
12707                     o = o->op_next;
12708                     break;
12709
12710                 case OP_GV:
12711                     /* it may be a package var index */
12712
12713                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_SPECIAL)));
12714                     ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
12715                     if (  (o->op_flags &~ OPf_SPECIAL) != OPf_WANT_SCALAR
12716                         || o->op_private != 0
12717                     )
12718                         break;
12719
12720                     kid = o->op_next;
12721                     if (kid->op_type != OP_RV2SV)
12722                         break;
12723
12724                     ASSUME(!(kid->op_flags &
12725                             ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
12726                              |OPf_SPECIAL|OPf_PARENS)));
12727                     ASSUME(!(kid->op_private &
12728                                     ~(OPpARG1_MASK
12729                                      |OPpHINT_STRICT_REFS|OPpOUR_INTRO
12730                                      |OPpDEREF|OPpLVAL_INTRO)));
12731                     if(   (kid->op_flags &~ OPf_PARENS)
12732                             != (OPf_WANT_SCALAR|OPf_KIDS)
12733                        || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
12734                     )
12735                         break;
12736
12737                     if (pass) {
12738 #ifdef USE_ITHREADS
12739                         arg->pad_offset = cPADOPx(o)->op_padix;
12740                         /* stop it being swiped when nulled */
12741                         cPADOPx(o)->op_padix = 0;
12742 #else
12743                         arg->sv = cSVOPx(o)->op_sv;
12744                         cSVOPo->op_sv = NULL;
12745 #endif
12746                     }
12747                     arg++;
12748                     index_type = MDEREF_INDEX_gvsv;
12749                     o = kid->op_next;
12750                     break;
12751
12752                 } /* switch */
12753             } /* action_count != index_skip */
12754
12755             action |= index_type;
12756
12757
12758             /* at this point we have either:
12759              *   * detected what looks like a simple index expression,
12760              *     and expect the next op to be an [ah]elem, or
12761              *     an nulled  [ah]elem followed by a delete or exists;
12762              *  * found a more complex expression, so something other
12763              *    than the above follows.
12764              */
12765
12766             /* possibly an optimised away [ah]elem (where op_next is
12767              * exists or delete) */
12768             if (o->op_type == OP_NULL)
12769                 o = o->op_next;
12770
12771             /* at this point we're looking for an OP_AELEM, OP_HELEM,
12772              * OP_EXISTS or OP_DELETE */
12773
12774             /* if something like arybase (a.k.a $[ ) is in scope,
12775              * abandon optimisation attempt */
12776             if (  (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
12777                && PL_check[o->op_type] != Perl_ck_null)
12778                 return;
12779
12780             if (   o->op_type != OP_AELEM
12781                 || (o->op_private &
12782                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
12783                 )
12784                 maybe_aelemfast = FALSE;
12785
12786             /* look for aelem/helem/exists/delete. If it's not the last elem
12787              * lookup, it *must* have OPpDEREF_AV/HV, but not many other
12788              * flags; if it's the last, then it mustn't have
12789              * OPpDEREF_AV/HV, but may have lots of other flags, like
12790              * OPpLVAL_INTRO etc
12791              */
12792
12793             if (   index_type == MDEREF_INDEX_none
12794                 || (   o->op_type != OP_AELEM  && o->op_type != OP_HELEM
12795                     && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
12796             )
12797                 ok = FALSE;
12798             else {
12799                 /* we have aelem/helem/exists/delete with valid simple index */
12800
12801                 is_deref =    (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
12802                            && (   (o->op_private & OPpDEREF) == OPpDEREF_AV
12803                                || (o->op_private & OPpDEREF) == OPpDEREF_HV);
12804
12805                 if (is_deref) {
12806                     ASSUME(!(o->op_flags &
12807                                  ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
12808                     ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
12809
12810                     ok =    (o->op_flags &~ OPf_PARENS)
12811                                == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
12812                          && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
12813                 }
12814                 else if (o->op_type == OP_EXISTS) {
12815                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12816                                 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12817                     ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
12818                     ok =  !(o->op_private & ~OPpARG1_MASK);
12819                 }
12820                 else if (o->op_type == OP_DELETE) {
12821                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12822                                 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12823                     ASSUME(!(o->op_private &
12824                                     ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
12825                     /* don't handle slices or 'local delete'; the latter
12826                      * is fairly rare, and has a complex runtime */
12827                     ok =  !(o->op_private & ~OPpARG1_MASK);
12828                     if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
12829                         /* skip handling run-tome error */
12830                         ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
12831                 }
12832                 else {
12833                     ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
12834                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
12835                                             |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
12836                     ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
12837                                     |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
12838                     ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
12839                 }
12840             }
12841
12842             if (ok) {
12843                 if (!first_elem_op)
12844                     first_elem_op = o;
12845                 top_op = o;
12846                 if (is_deref) {
12847                     next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
12848                     o = o->op_next;
12849                 }
12850                 else {
12851                     is_last = TRUE;
12852                     action |= MDEREF_FLAG_last;
12853                 }
12854             }
12855             else {
12856                 /* at this point we have something that started
12857                  * promisingly enough (with rv2av or whatever), but failed
12858                  * to find a simple index followed by an
12859                  * aelem/helem/exists/delete. If this is the first action,
12860                  * give up; but if we've already seen at least one
12861                  * aelem/helem, then keep them and add a new action with
12862                  * MDEREF_INDEX_none, which causes it to do the vivify
12863                  * from the end of the previous lookup, and do the deref,
12864                  * but stop at that point. So $a[0][expr] will do one
12865                  * av_fetch, vivify and deref, then continue executing at
12866                  * expr */
12867                 if (!action_count)
12868                     return;
12869                 is_last = TRUE;
12870                 index_skip = action_count;
12871                 action |= MDEREF_FLAG_last;
12872             }
12873
12874             if (pass)
12875                 action_ptr->uv |= (action << (action_ix * MDEREF_SHIFT));
12876             action_ix++;
12877             action_count++;
12878             /* if there's no space for the next action, create a new slot
12879              * for it *before* we start adding args for that action */
12880             if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
12881                 action_ptr = arg;
12882                 if (pass)
12883                     arg->uv = 0;
12884                 arg++;
12885                 action_ix = 0;
12886             }
12887         } /* while !is_last */
12888
12889         /* success! */
12890
12891         if (pass) {
12892             OP *mderef;
12893             OP *p, *q;
12894
12895             mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
12896             if (index_skip == -1) {
12897                 mderef->op_flags = o->op_flags
12898                         & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
12899                 if (o->op_type == OP_EXISTS)
12900                     mderef->op_private = OPpMULTIDEREF_EXISTS;
12901                 else if (o->op_type == OP_DELETE)
12902                     mderef->op_private = OPpMULTIDEREF_DELETE;
12903                 else
12904                     mderef->op_private = o->op_private
12905                         & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
12906             }
12907             /* accumulate strictness from every level (although I don't think
12908              * they can actually vary) */
12909             mderef->op_private |= hints;
12910
12911             /* integrate the new multideref op into the optree and the
12912              * op_next chain.
12913              *
12914              * In general an op like aelem or helem has two child
12915              * sub-trees: the aggregate expression (a_expr) and the
12916              * index expression (i_expr):
12917              *
12918              *     aelem
12919              *       |
12920              *     a_expr - i_expr
12921              *
12922              * The a_expr returns an AV or HV, while the i-expr returns an
12923              * index. In general a multideref replaces most or all of a
12924              * multi-level tree, e.g.
12925              *
12926              *     exists
12927              *       |
12928              *     ex-aelem
12929              *       |
12930              *     rv2av  - i_expr1
12931              *       |
12932              *     helem
12933              *       |
12934              *     rv2hv  - i_expr2
12935              *       |
12936              *     aelem
12937              *       |
12938              *     a_expr - i_expr3
12939              *
12940              * With multideref, all the i_exprs will be simple vars or
12941              * constants, except that i_expr1 may be arbitrary in the case
12942              * of MDEREF_INDEX_none.
12943              *
12944              * The bottom-most a_expr will be either:
12945              *   1) a simple var (so padXv or gv+rv2Xv);
12946              *   2) a simple scalar var dereferenced (e.g. $r->[0]):
12947              *      so a simple var with an extra rv2Xv;
12948              *   3) or an arbitrary expression.
12949              *
12950              * 'start', the first op in the execution chain, will point to
12951              *   1),2): the padXv or gv op;
12952              *   3):    the rv2Xv which forms the last op in the a_expr
12953              *          execution chain, and the top-most op in the a_expr
12954              *          subtree.
12955              *
12956              * For all cases, the 'start' node is no longer required,
12957              * but we can't free it since one or more external nodes
12958              * may point to it. E.g. consider
12959              *     $h{foo} = $a ? $b : $c
12960              * Here, both the op_next and op_other branches of the
12961              * cond_expr point to the gv[*h] of the hash expression, so
12962              * we can't free the 'start' op.
12963              *
12964              * For expr->[...], we need to save the subtree containing the
12965              * expression; for the other cases, we just need to save the
12966              * start node.
12967              * So in all cases, we null the start op and keep it around by
12968              * making it the child of the multideref op; for the expr->
12969              * case, the expr will be a subtree of the start node.
12970              *
12971              * So in the simple 1,2 case the  optree above changes to
12972              *
12973              *     ex-exists
12974              *       |
12975              *     multideref
12976              *       |
12977              *     ex-gv (or ex-padxv)
12978              *
12979              *  with the op_next chain being
12980              *
12981              *  -> ex-gv -> multideref -> op-following-ex-exists ->
12982              *
12983              *  In the 3 case, we have
12984              *
12985              *     ex-exists
12986              *       |
12987              *     multideref
12988              *       |
12989              *     ex-rv2xv
12990              *       |
12991              *    rest-of-a_expr
12992              *      subtree
12993              *
12994              *  and
12995              *
12996              *  -> rest-of-a_expr subtree ->
12997              *    ex-rv2xv -> multideref -> op-following-ex-exists ->
12998              *
12999              *
13000              * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
13001              * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
13002              * multideref attached as the child, e.g.
13003              *
13004              *     exists
13005              *       |
13006              *     ex-aelem
13007              *       |
13008              *     ex-rv2av  - i_expr1
13009              *       |
13010              *     multideref
13011              *       |
13012              *     ex-whatever
13013              *
13014              */
13015
13016             /* if we free this op, don't free the pad entry */
13017             if (reset_start_targ)
13018                 start->op_targ = 0;
13019
13020
13021             /* Cut the bit we need to save out of the tree and attach to
13022              * the multideref op, then free the rest of the tree */
13023
13024             /* find parent of node to be detached (for use by splice) */
13025             p = first_elem_op;
13026             if (   orig_action == MDEREF_AV_pop_rv2av_aelem
13027                 || orig_action == MDEREF_HV_pop_rv2hv_helem)
13028             {
13029                 /* there is an arbitrary expression preceding us, e.g.
13030                  * expr->[..]? so we need to save the 'expr' subtree */
13031                 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
13032                     p = cUNOPx(p)->op_first;
13033                 ASSUME(   start->op_type == OP_RV2AV
13034                        || start->op_type == OP_RV2HV);
13035             }
13036             else {
13037                 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
13038                  * above for exists/delete. */
13039                 while (   (p->op_flags & OPf_KIDS)
13040                        && cUNOPx(p)->op_first != start
13041                 )
13042                     p = cUNOPx(p)->op_first;
13043             }
13044             ASSUME(cUNOPx(p)->op_first == start);
13045
13046             /* detach from main tree, and re-attach under the multideref */
13047             op_sibling_splice(mderef, NULL, 0,
13048                     op_sibling_splice(p, NULL, 1, NULL));
13049             op_null(start);
13050
13051             start->op_next = mderef;
13052
13053             mderef->op_next = index_skip == -1 ? o->op_next : o;
13054
13055             /* excise and free the original tree, and replace with
13056              * the multideref op */
13057             p = op_sibling_splice(top_op, NULL, -1, mderef);
13058             while (p) {
13059                 q = OpSIBLING(p);
13060                 op_free(p);
13061                 p = q;
13062             }
13063             op_null(top_op);
13064         }
13065         else {
13066             Size_t size = arg - arg_buf;
13067
13068             if (maybe_aelemfast && action_count == 1)
13069                 return;
13070
13071             arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
13072                                 sizeof(UNOP_AUX_item) * (size + 1));
13073             /* for dumping etc: store the length in a hidden first slot;
13074              * we set the op_aux pointer to the second slot */
13075             arg_buf->uv = size;
13076             arg_buf++;
13077         }
13078     } /* for (pass = ...) */
13079 }
13080
13081
13082
13083 /* mechanism for deferring recursion in rpeep() */
13084
13085 #define MAX_DEFERRED 4
13086
13087 #define DEFER(o) \
13088   STMT_START { \
13089     if (defer_ix == (MAX_DEFERRED-1)) { \
13090         OP **defer = defer_queue[defer_base]; \
13091         CALL_RPEEP(*defer); \
13092         S_prune_chain_head(defer); \
13093         defer_base = (defer_base + 1) % MAX_DEFERRED; \
13094         defer_ix--; \
13095     } \
13096     defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
13097   } STMT_END
13098
13099 #define IS_AND_OP(o)   (o->op_type == OP_AND)
13100 #define IS_OR_OP(o)    (o->op_type == OP_OR)
13101
13102
13103 /* A peephole optimizer.  We visit the ops in the order they're to execute.
13104  * See the comments at the top of this file for more details about when
13105  * peep() is called */
13106
13107 void
13108 Perl_rpeep(pTHX_ OP *o)
13109 {
13110     dVAR;
13111     OP* oldop = NULL;
13112     OP* oldoldop = NULL;
13113     OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
13114     int defer_base = 0;
13115     int defer_ix = -1;
13116     OP *fop;
13117     OP *sop;
13118
13119     if (!o || o->op_opt)
13120         return;
13121     ENTER;
13122     SAVEOP();
13123     SAVEVPTR(PL_curcop);
13124     for (;; o = o->op_next) {
13125         if (o && o->op_opt)
13126             o = NULL;
13127         if (!o) {
13128             while (defer_ix >= 0) {
13129                 OP **defer =
13130                         defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
13131                 CALL_RPEEP(*defer);
13132                 S_prune_chain_head(defer);
13133             }
13134             break;
13135         }
13136
13137       redo:
13138
13139         /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */
13140         assert(!oldoldop || oldoldop->op_next == oldop);
13141         assert(!oldop    || oldop->op_next    == o);
13142
13143         /* By default, this op has now been optimised. A couple of cases below
13144            clear this again.  */
13145         o->op_opt = 1;
13146         PL_op = o;
13147
13148         /* look for a series of 1 or more aggregate derefs, e.g.
13149          *   $a[1]{foo}[$i]{$k}
13150          * and replace with a single OP_MULTIDEREF op.
13151          * Each index must be either a const, or a simple variable,
13152          *
13153          * First, look for likely combinations of starting ops,
13154          * corresponding to (global and lexical variants of)
13155          *     $a[...]   $h{...}
13156          *     $r->[...] $r->{...}
13157          *     (preceding expression)->[...]
13158          *     (preceding expression)->{...}
13159          * and if so, call maybe_multideref() to do a full inspection
13160          * of the op chain and if appropriate, replace with an
13161          * OP_MULTIDEREF
13162          */
13163         {
13164             UV action;
13165             OP *o2 = o;
13166             U8 hints = 0;
13167
13168             switch (o2->op_type) {
13169             case OP_GV:
13170                 /* $pkg[..]   :   gv[*pkg]
13171                  * $pkg->[...]:   gv[*pkg]; rv2sv sKM/DREFAV */
13172
13173                 /* Fail if there are new op flag combinations that we're
13174                  * not aware of, rather than:
13175                  *  * silently failing to optimise, or
13176                  *  * silently optimising the flag away.
13177                  * If this ASSUME starts failing, examine what new flag
13178                  * has been added to the op, and decide whether the
13179                  * optimisation should still occur with that flag, then
13180                  * update the code accordingly. This applies to all the
13181                  * other ASSUMEs in the block of code too.
13182                  */
13183                 ASSUME(!(o2->op_flags &
13184                             ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
13185                 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
13186
13187                 o2 = o2->op_next;
13188
13189                 if (o2->op_type == OP_RV2AV) {
13190                     action = MDEREF_AV_gvav_aelem;
13191                     goto do_deref;
13192                 }
13193
13194                 if (o2->op_type == OP_RV2HV) {
13195                     action = MDEREF_HV_gvhv_helem;
13196                     goto do_deref;
13197                 }
13198
13199                 if (o2->op_type != OP_RV2SV)
13200                     break;
13201
13202                 /* at this point we've seen gv,rv2sv, so the only valid
13203                  * construct left is $pkg->[] or $pkg->{} */
13204
13205                 ASSUME(!(o2->op_flags & OPf_STACKED));
13206                 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13207                             != (OPf_WANT_SCALAR|OPf_MOD))
13208                     break;
13209
13210                 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
13211                                     |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
13212                 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
13213                     break;
13214                 if (   (o2->op_private & OPpDEREF) != OPpDEREF_AV
13215                     && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
13216                     break;
13217
13218                 o2 = o2->op_next;
13219                 if (o2->op_type == OP_RV2AV) {
13220                     action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
13221                     goto do_deref;
13222                 }
13223                 if (o2->op_type == OP_RV2HV) {
13224                     action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
13225                     goto do_deref;
13226                 }
13227                 break;
13228
13229             case OP_PADSV:
13230                 /* $lex->[...]: padsv[$lex] sM/DREFAV */
13231
13232                 ASSUME(!(o2->op_flags &
13233                     ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
13234                 if ((o2->op_flags &
13235                         (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13236                      != (OPf_WANT_SCALAR|OPf_MOD))
13237                     break;
13238
13239                 ASSUME(!(o2->op_private &
13240                                 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
13241                 /* skip if state or intro, or not a deref */
13242                 if (      o2->op_private != OPpDEREF_AV
13243                        && o2->op_private != OPpDEREF_HV)
13244                     break;
13245
13246                 o2 = o2->op_next;
13247                 if (o2->op_type == OP_RV2AV) {
13248                     action = MDEREF_AV_padsv_vivify_rv2av_aelem;
13249                     goto do_deref;
13250                 }
13251                 if (o2->op_type == OP_RV2HV) {
13252                     action = MDEREF_HV_padsv_vivify_rv2hv_helem;
13253                     goto do_deref;
13254                 }
13255                 break;
13256
13257             case OP_PADAV:
13258             case OP_PADHV:
13259                 /*    $lex[..]:  padav[@lex:1,2] sR *
13260                  * or $lex{..}:  padhv[%lex:1,2] sR */
13261                 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
13262                                             OPf_REF|OPf_SPECIAL)));
13263                 if ((o2->op_flags &
13264                         (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13265                      != (OPf_WANT_SCALAR|OPf_REF))
13266                     break;
13267                 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
13268                     break;
13269                 /* OPf_PARENS isn't currently used in this case;
13270                  * if that changes, let us know! */
13271                 ASSUME(!(o2->op_flags & OPf_PARENS));
13272
13273                 /* at this point, we wouldn't expect any of the remaining
13274                  * possible private flags:
13275                  * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
13276                  * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
13277                  *
13278                  * OPpSLICEWARNING shouldn't affect runtime
13279                  */
13280                 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
13281
13282                 action = o2->op_type == OP_PADAV
13283                             ? MDEREF_AV_padav_aelem
13284                             : MDEREF_HV_padhv_helem;
13285                 o2 = o2->op_next;
13286                 S_maybe_multideref(aTHX_ o, o2, action, 0);
13287                 break;
13288
13289
13290             case OP_RV2AV:
13291             case OP_RV2HV:
13292                 action = o2->op_type == OP_RV2AV
13293                             ? MDEREF_AV_pop_rv2av_aelem
13294                             : MDEREF_HV_pop_rv2hv_helem;
13295                 /* FALLTHROUGH */
13296             do_deref:
13297                 /* (expr)->[...]:  rv2av sKR/1;
13298                  * (expr)->{...}:  rv2hv sKR/1; */
13299
13300                 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
13301
13302                 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
13303                                 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
13304                 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
13305                     break;
13306
13307                 /* at this point, we wouldn't expect any of these
13308                  * possible private flags:
13309                  * OPpMAYBE_LVSUB, OPpLVAL_INTRO
13310                  * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
13311                  */
13312                 ASSUME(!(o2->op_private &
13313                     ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
13314                      |OPpOUR_INTRO)));
13315                 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
13316
13317                 o2 = o2->op_next;
13318
13319                 S_maybe_multideref(aTHX_ o, o2, action, hints);
13320                 break;
13321
13322             default:
13323                 break;
13324             }
13325         }
13326
13327
13328         switch (o->op_type) {
13329         case OP_DBSTATE:
13330             PL_curcop = ((COP*)o);              /* for warnings */
13331             break;
13332         case OP_NEXTSTATE:
13333             PL_curcop = ((COP*)o);              /* for warnings */
13334
13335             /* Optimise a "return ..." at the end of a sub to just be "...".
13336              * This saves 2 ops. Before:
13337              * 1  <;> nextstate(main 1 -e:1) v ->2
13338              * 4  <@> return K ->5
13339              * 2    <0> pushmark s ->3
13340              * -    <1> ex-rv2sv sK/1 ->4
13341              * 3      <#> gvsv[*cat] s ->4
13342              *
13343              * After:
13344              * -  <@> return K ->-
13345              * -    <0> pushmark s ->2
13346              * -    <1> ex-rv2sv sK/1 ->-
13347              * 2      <$> gvsv(*cat) s ->3
13348              */
13349             {
13350                 OP *next = o->op_next;
13351                 OP *sibling = OpSIBLING(o);
13352                 if (   OP_TYPE_IS(next, OP_PUSHMARK)
13353                     && OP_TYPE_IS(sibling, OP_RETURN)
13354                     && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
13355                     && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
13356                        ||OP_TYPE_IS(sibling->op_next->op_next,
13357                                     OP_LEAVESUBLV))
13358                     && cUNOPx(sibling)->op_first == next
13359                     && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
13360                     && next->op_next
13361                 ) {
13362                     /* Look through the PUSHMARK's siblings for one that
13363                      * points to the RETURN */
13364                     OP *top = OpSIBLING(next);
13365                     while (top && top->op_next) {
13366                         if (top->op_next == sibling) {
13367                             top->op_next = sibling->op_next;
13368                             o->op_next = next->op_next;
13369                             break;
13370                         }
13371                         top = OpSIBLING(top);
13372                     }
13373                 }
13374             }
13375
13376             /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
13377              *
13378              * This latter form is then suitable for conversion into padrange
13379              * later on. Convert:
13380              *
13381              *   nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
13382              *
13383              * into:
13384              *
13385              *   nextstate1 ->     listop     -> nextstate3
13386              *                 /            \
13387              *         pushmark -> padop1 -> padop2
13388              */
13389             if (o->op_next && (
13390                     o->op_next->op_type == OP_PADSV
13391                  || o->op_next->op_type == OP_PADAV
13392                  || o->op_next->op_type == OP_PADHV
13393                 )
13394                 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
13395                 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
13396                 && o->op_next->op_next->op_next && (
13397                     o->op_next->op_next->op_next->op_type == OP_PADSV
13398                  || o->op_next->op_next->op_next->op_type == OP_PADAV
13399                  || o->op_next->op_next->op_next->op_type == OP_PADHV
13400                 )
13401                 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
13402                 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
13403                 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
13404                 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
13405             ) {
13406                 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
13407
13408                 pad1 =    o->op_next;
13409                 ns2  = pad1->op_next;
13410                 pad2 =  ns2->op_next;
13411                 ns3  = pad2->op_next;
13412
13413                 /* we assume here that the op_next chain is the same as
13414                  * the op_sibling chain */
13415                 assert(OpSIBLING(o)    == pad1);
13416                 assert(OpSIBLING(pad1) == ns2);
13417                 assert(OpSIBLING(ns2)  == pad2);
13418                 assert(OpSIBLING(pad2) == ns3);
13419
13420                 /* excise and delete ns2 */
13421                 op_sibling_splice(NULL, pad1, 1, NULL);
13422                 op_free(ns2);
13423
13424                 /* excise pad1 and pad2 */
13425                 op_sibling_splice(NULL, o, 2, NULL);
13426
13427                 /* create new listop, with children consisting of:
13428                  * a new pushmark, pad1, pad2. */
13429                 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
13430                 newop->op_flags |= OPf_PARENS;
13431                 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
13432
13433                 /* insert newop between o and ns3 */
13434                 op_sibling_splice(NULL, o, 0, newop);
13435
13436                 /*fixup op_next chain */
13437                 newpm = cUNOPx(newop)->op_first; /* pushmark */
13438                 o    ->op_next = newpm;
13439                 newpm->op_next = pad1;
13440                 pad1 ->op_next = pad2;
13441                 pad2 ->op_next = newop; /* listop */
13442                 newop->op_next = ns3;
13443
13444                 /* Ensure pushmark has this flag if padops do */
13445                 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
13446                     newpm->op_flags |= OPf_MOD;
13447                 }
13448
13449                 break;
13450             }
13451
13452             /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
13453                to carry two labels. For now, take the easier option, and skip
13454                this optimisation if the first NEXTSTATE has a label.  */
13455             if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
13456                 OP *nextop = o->op_next;
13457                 while (nextop && nextop->op_type == OP_NULL)
13458                     nextop = nextop->op_next;
13459
13460                 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
13461                     op_null(o);
13462                     if (oldop)
13463                         oldop->op_next = nextop;
13464                     o = nextop;
13465                     /* Skip (old)oldop assignment since the current oldop's
13466                        op_next already points to the next op.  */
13467                     goto redo;
13468                 }
13469             }
13470             break;
13471
13472         case OP_CONCAT:
13473             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
13474                 if (o->op_next->op_private & OPpTARGET_MY) {
13475                     if (o->op_flags & OPf_STACKED) /* chained concats */
13476                         break; /* ignore_optimization */
13477                     else {
13478                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
13479                         o->op_targ = o->op_next->op_targ;
13480                         o->op_next->op_targ = 0;
13481                         o->op_private |= OPpTARGET_MY;
13482                     }
13483                 }
13484                 op_null(o->op_next);
13485             }
13486             break;
13487         case OP_STUB:
13488             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
13489                 break; /* Scalar stub must produce undef.  List stub is noop */
13490             }
13491             goto nothin;
13492         case OP_NULL:
13493             if (o->op_targ == OP_NEXTSTATE
13494                 || o->op_targ == OP_DBSTATE)
13495             {
13496                 PL_curcop = ((COP*)o);
13497             }
13498             /* XXX: We avoid setting op_seq here to prevent later calls
13499                to rpeep() from mistakenly concluding that optimisation
13500                has already occurred. This doesn't fix the real problem,
13501                though (See 20010220.007). AMS 20010719 */
13502             /* op_seq functionality is now replaced by op_opt */
13503             o->op_opt = 0;
13504             /* FALLTHROUGH */
13505         case OP_SCALAR:
13506         case OP_LINESEQ:
13507         case OP_SCOPE:
13508         nothin:
13509             if (oldop) {
13510                 oldop->op_next = o->op_next;
13511                 o->op_opt = 0;
13512                 continue;
13513             }
13514             break;
13515
13516         case OP_PUSHMARK:
13517
13518             /* Given
13519                  5 repeat/DOLIST
13520                  3   ex-list
13521                  1     pushmark
13522                  2     scalar or const
13523                  4   const[0]
13524                convert repeat into a stub with no kids.
13525              */
13526             if (o->op_next->op_type == OP_CONST
13527              || (  o->op_next->op_type == OP_PADSV
13528                 && !(o->op_next->op_private & OPpLVAL_INTRO))
13529              || (  o->op_next->op_type == OP_GV
13530                 && o->op_next->op_next->op_type == OP_RV2SV
13531                 && !(o->op_next->op_next->op_private
13532                         & (OPpLVAL_INTRO|OPpOUR_INTRO))))
13533             {
13534                 const OP *kid = o->op_next->op_next;
13535                 if (o->op_next->op_type == OP_GV)
13536                    kid = kid->op_next;
13537                 /* kid is now the ex-list.  */
13538                 if (kid->op_type == OP_NULL
13539                  && (kid = kid->op_next)->op_type == OP_CONST
13540                     /* kid is now the repeat count.  */
13541                  && kid->op_next->op_type == OP_REPEAT
13542                  && kid->op_next->op_private & OPpREPEAT_DOLIST
13543                  && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
13544                  && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0)
13545                 {
13546                     o = kid->op_next; /* repeat */
13547                     assert(oldop);
13548                     oldop->op_next = o;
13549                     op_free(cBINOPo->op_first);
13550                     op_free(cBINOPo->op_last );
13551                     o->op_flags &=~ OPf_KIDS;
13552                     /* stub is a baseop; repeat is a binop */
13553                     STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
13554                     OpTYPE_set(o, OP_STUB);
13555                     o->op_private = 0;
13556                     break;
13557                 }
13558             }
13559
13560             /* Convert a series of PAD ops for my vars plus support into a
13561              * single padrange op. Basically
13562              *
13563              *    pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
13564              *
13565              * becomes, depending on circumstances, one of
13566              *
13567              *    padrange  ----------------------------------> (list) -> rest
13568              *    padrange  --------------------------------------------> rest
13569              *
13570              * where all the pad indexes are sequential and of the same type
13571              * (INTRO or not).
13572              * We convert the pushmark into a padrange op, then skip
13573              * any other pad ops, and possibly some trailing ops.
13574              * Note that we don't null() the skipped ops, to make it
13575              * easier for Deparse to undo this optimisation (and none of
13576              * the skipped ops are holding any resourses). It also makes
13577              * it easier for find_uninit_var(), as it can just ignore
13578              * padrange, and examine the original pad ops.
13579              */
13580         {
13581             OP *p;
13582             OP *followop = NULL; /* the op that will follow the padrange op */
13583             U8 count = 0;
13584             U8 intro = 0;
13585             PADOFFSET base = 0; /* init only to stop compiler whining */
13586             bool gvoid = 0;     /* init only to stop compiler whining */
13587             bool defav = 0;  /* seen (...) = @_ */
13588             bool reuse = 0;  /* reuse an existing padrange op */
13589
13590             /* look for a pushmark -> gv[_] -> rv2av */
13591
13592             {
13593                 OP *rv2av, *q;
13594                 p = o->op_next;
13595                 if (   p->op_type == OP_GV
13596                     && cGVOPx_gv(p) == PL_defgv
13597                     && (rv2av = p->op_next)
13598                     && rv2av->op_type == OP_RV2AV
13599                     && !(rv2av->op_flags & OPf_REF)
13600                     && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
13601                     && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
13602                 ) {
13603                     q = rv2av->op_next;
13604                     if (q->op_type == OP_NULL)
13605                         q = q->op_next;
13606                     if (q->op_type == OP_PUSHMARK) {
13607                         defav = 1;
13608                         p = q;
13609                     }
13610                 }
13611             }
13612             if (!defav) {
13613                 p = o;
13614             }
13615
13616             /* scan for PAD ops */
13617
13618             for (p = p->op_next; p; p = p->op_next) {
13619                 if (p->op_type == OP_NULL)
13620                     continue;
13621
13622                 if ((     p->op_type != OP_PADSV
13623                        && p->op_type != OP_PADAV
13624                        && p->op_type != OP_PADHV
13625                     )
13626                       /* any private flag other than INTRO? e.g. STATE */
13627                    || (p->op_private & ~OPpLVAL_INTRO)
13628                 )
13629                     break;
13630
13631                 /* let $a[N] potentially be optimised into AELEMFAST_LEX
13632                  * instead */
13633                 if (   p->op_type == OP_PADAV
13634                     && p->op_next
13635                     && p->op_next->op_type == OP_CONST
13636                     && p->op_next->op_next
13637                     && p->op_next->op_next->op_type == OP_AELEM
13638                 )
13639                     break;
13640
13641                 /* for 1st padop, note what type it is and the range
13642                  * start; for the others, check that it's the same type
13643                  * and that the targs are contiguous */
13644                 if (count == 0) {
13645                     intro = (p->op_private & OPpLVAL_INTRO);
13646                     base = p->op_targ;
13647                     gvoid = OP_GIMME(p,0) == G_VOID;
13648                 }
13649                 else {
13650                     if ((p->op_private & OPpLVAL_INTRO) != intro)
13651                         break;
13652                     /* Note that you'd normally  expect targs to be
13653                      * contiguous in my($a,$b,$c), but that's not the case
13654                      * when external modules start doing things, e.g.
13655                      i* Function::Parameters */
13656                     if (p->op_targ != base + count)
13657                         break;
13658                     assert(p->op_targ == base + count);
13659                     /* Either all the padops or none of the padops should
13660                        be in void context.  Since we only do the optimisa-
13661                        tion for av/hv when the aggregate itself is pushed
13662                        on to the stack (one item), there is no need to dis-
13663                        tinguish list from scalar context.  */
13664                     if (gvoid != (OP_GIMME(p,0) == G_VOID))
13665                         break;
13666                 }
13667
13668                 /* for AV, HV, only when we're not flattening */
13669                 if (   p->op_type != OP_PADSV
13670                     && !gvoid
13671                     && !(p->op_flags & OPf_REF)
13672                 )
13673                     break;
13674
13675                 if (count >= OPpPADRANGE_COUNTMASK)
13676                     break;
13677
13678                 /* there's a biggest base we can fit into a
13679                  * SAVEt_CLEARPADRANGE in pp_padrange.
13680                  * (The sizeof() stuff will be constant-folded, and is
13681                  * intended to avoid getting "comparison is always false"
13682                  * compiler warnings)
13683                  */
13684                 if (   intro
13685                     && (8*sizeof(base) >
13686                         8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
13687                         ? base : 0) >
13688                         (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
13689                 )
13690                     break;
13691
13692                 /* Success! We've got another valid pad op to optimise away */
13693                 count++;
13694                 followop = p->op_next;
13695             }
13696
13697             if (count < 1 || (count == 1 && !defav))
13698                 break;
13699
13700             /* pp_padrange in specifically compile-time void context
13701              * skips pushing a mark and lexicals; in all other contexts
13702              * (including unknown till runtime) it pushes a mark and the
13703              * lexicals. We must be very careful then, that the ops we
13704              * optimise away would have exactly the same effect as the
13705              * padrange.
13706              * In particular in void context, we can only optimise to
13707              * a padrange if see see the complete sequence
13708              *     pushmark, pad*v, ...., list
13709              * which has the net effect of of leaving the markstack as it
13710              * was.  Not pushing on to the stack (whereas padsv does touch
13711              * the stack) makes no difference in void context.
13712              */
13713             assert(followop);
13714             if (gvoid) {
13715                 if (followop->op_type == OP_LIST
13716                         && OP_GIMME(followop,0) == G_VOID
13717                    )
13718                 {
13719                     followop = followop->op_next; /* skip OP_LIST */
13720
13721                     /* consolidate two successive my(...);'s */
13722
13723                     if (   oldoldop
13724                         && oldoldop->op_type == OP_PADRANGE
13725                         && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
13726                         && (oldoldop->op_private & OPpLVAL_INTRO) == intro
13727                         && !(oldoldop->op_flags & OPf_SPECIAL)
13728                     ) {
13729                         U8 old_count;
13730                         assert(oldoldop->op_next == oldop);
13731                         assert(   oldop->op_type == OP_NEXTSTATE
13732                                || oldop->op_type == OP_DBSTATE);
13733                         assert(oldop->op_next == o);
13734
13735                         old_count
13736                             = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
13737
13738                        /* Do not assume pad offsets for $c and $d are con-
13739                           tiguous in
13740                             my ($a,$b,$c);
13741                             my ($d,$e,$f);
13742                         */
13743                         if (  oldoldop->op_targ + old_count == base
13744                            && old_count < OPpPADRANGE_COUNTMASK - count) {
13745                             base = oldoldop->op_targ;
13746                             count += old_count;
13747                             reuse = 1;
13748                         }
13749                     }
13750
13751                     /* if there's any immediately following singleton
13752                      * my var's; then swallow them and the associated
13753                      * nextstates; i.e.
13754                      *    my ($a,$b); my $c; my $d;
13755                      * is treated as
13756                      *    my ($a,$b,$c,$d);
13757                      */
13758
13759                     while (    ((p = followop->op_next))
13760                             && (  p->op_type == OP_PADSV
13761                                || p->op_type == OP_PADAV
13762                                || p->op_type == OP_PADHV)
13763                             && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
13764                             && (p->op_private & OPpLVAL_INTRO) == intro
13765                             && !(p->op_private & ~OPpLVAL_INTRO)
13766                             && p->op_next
13767                             && (   p->op_next->op_type == OP_NEXTSTATE
13768                                 || p->op_next->op_type == OP_DBSTATE)
13769                             && count < OPpPADRANGE_COUNTMASK
13770                             && base + count == p->op_targ
13771                     ) {
13772                         count++;
13773                         followop = p->op_next;
13774                     }
13775                 }
13776                 else
13777                     break;
13778             }
13779
13780             if (reuse) {
13781                 assert(oldoldop->op_type == OP_PADRANGE);
13782                 oldoldop->op_next = followop;
13783                 oldoldop->op_private = (intro | count);
13784                 o = oldoldop;
13785                 oldop = NULL;
13786                 oldoldop = NULL;
13787             }
13788             else {
13789                 /* Convert the pushmark into a padrange.
13790                  * To make Deparse easier, we guarantee that a padrange was
13791                  * *always* formerly a pushmark */
13792                 assert(o->op_type == OP_PUSHMARK);
13793                 o->op_next = followop;
13794                 OpTYPE_set(o, OP_PADRANGE);
13795                 o->op_targ = base;
13796                 /* bit 7: INTRO; bit 6..0: count */
13797                 o->op_private = (intro | count);
13798                 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
13799                               | gvoid * OPf_WANT_VOID
13800                               | (defav ? OPf_SPECIAL : 0));
13801             }
13802             break;
13803         }
13804
13805         case OP_PADAV:
13806         case OP_PADSV:
13807         case OP_PADHV:
13808         /* Skip over state($x) in void context.  */
13809         if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
13810          && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
13811         {
13812             oldop->op_next = o->op_next;
13813             goto redo_nextstate;
13814         }
13815         if (o->op_type != OP_PADAV)
13816             break;
13817         /* FALLTHROUGH */
13818         case OP_GV:
13819             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
13820                 OP* const pop = (o->op_type == OP_PADAV) ?
13821                             o->op_next : o->op_next->op_next;
13822                 IV i;
13823                 if (pop && pop->op_type == OP_CONST &&
13824                     ((PL_op = pop->op_next)) &&
13825                     pop->op_next->op_type == OP_AELEM &&
13826                     !(pop->op_next->op_private &
13827                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
13828                     (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
13829                 {
13830                     GV *gv;
13831                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
13832                         no_bareword_allowed(pop);
13833                     if (o->op_type == OP_GV)
13834                         op_null(o->op_next);
13835                     op_null(pop->op_next);
13836                     op_null(pop);
13837                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
13838                     o->op_next = pop->op_next->op_next;
13839                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
13840                     o->op_private = (U8)i;
13841                     if (o->op_type == OP_GV) {
13842                         gv = cGVOPo_gv;
13843                         GvAVn(gv);
13844                         o->op_type = OP_AELEMFAST;
13845                     }
13846                     else
13847                         o->op_type = OP_AELEMFAST_LEX;
13848                 }
13849                 if (o->op_type != OP_GV)
13850                     break;
13851             }
13852
13853             /* Remove $foo from the op_next chain in void context.  */
13854             if (oldop
13855              && (  o->op_next->op_type == OP_RV2SV
13856                 || o->op_next->op_type == OP_RV2AV
13857                 || o->op_next->op_type == OP_RV2HV  )
13858              && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
13859              && !(o->op_next->op_private & OPpLVAL_INTRO))
13860             {
13861                 oldop->op_next = o->op_next->op_next;
13862                 /* Reprocess the previous op if it is a nextstate, to
13863                    allow double-nextstate optimisation.  */
13864               redo_nextstate:
13865                 if (oldop->op_type == OP_NEXTSTATE) {
13866                     oldop->op_opt = 0;
13867                     o = oldop;
13868                     oldop = oldoldop;
13869                     oldoldop = NULL;
13870                     goto redo;
13871                 }
13872                 o = oldop->op_next;
13873                 goto redo;
13874             }
13875             else if (o->op_next->op_type == OP_RV2SV) {
13876                 if (!(o->op_next->op_private & OPpDEREF)) {
13877                     op_null(o->op_next);
13878                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
13879                                                                | OPpOUR_INTRO);
13880                     o->op_next = o->op_next->op_next;
13881                     OpTYPE_set(o, OP_GVSV);
13882                 }
13883             }
13884             else if (o->op_next->op_type == OP_READLINE
13885                     && o->op_next->op_next->op_type == OP_CONCAT
13886                     && (o->op_next->op_next->op_flags & OPf_STACKED))
13887             {
13888                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
13889                 OpTYPE_set(o, OP_RCATLINE);
13890                 o->op_flags |= OPf_STACKED;
13891                 op_null(o->op_next->op_next);
13892                 op_null(o->op_next);
13893             }
13894
13895             break;
13896
13897 #define HV_OR_SCALARHV(op)                                   \
13898     (  (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \
13899        ? (op)                                                  \
13900        : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \
13901        && (  cUNOPx(op)->op_first->op_type == OP_PADHV          \
13902           || cUNOPx(op)->op_first->op_type == OP_RV2HV)          \
13903          ? cUNOPx(op)->op_first                                   \
13904          : NULL)
13905
13906         case OP_NOT:
13907             if ((fop = HV_OR_SCALARHV(cUNOP->op_first)))
13908                 fop->op_private |= OPpTRUEBOOL;
13909             break;
13910
13911         case OP_AND:
13912         case OP_OR:
13913         case OP_DOR:
13914             fop = cLOGOP->op_first;
13915             sop = OpSIBLING(fop);
13916             while (cLOGOP->op_other->op_type == OP_NULL)
13917                 cLOGOP->op_other = cLOGOP->op_other->op_next;
13918             while (o->op_next && (   o->op_type == o->op_next->op_type
13919                                   || o->op_next->op_type == OP_NULL))
13920                 o->op_next = o->op_next->op_next;
13921
13922             /* if we're an OR and our next is a AND in void context, we'll
13923                follow it's op_other on short circuit, same for reverse.
13924                We can't do this with OP_DOR since if it's true, its return
13925                value is the underlying value which must be evaluated
13926                by the next op */
13927             if (o->op_next &&
13928                 (
13929                     (IS_AND_OP(o) && IS_OR_OP(o->op_next))
13930                  || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
13931                 )
13932                 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
13933             ) {
13934                 o->op_next = ((LOGOP*)o->op_next)->op_other;
13935             }
13936             DEFER(cLOGOP->op_other);
13937
13938             o->op_opt = 1;
13939             fop = HV_OR_SCALARHV(fop);
13940             if (sop) sop = HV_OR_SCALARHV(sop);
13941             if (fop || sop
13942             ){
13943                 OP * nop = o;
13944                 OP * lop = o;
13945                 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
13946                     while (nop && nop->op_next) {
13947                         switch (nop->op_next->op_type) {
13948                             case OP_NOT:
13949                             case OP_AND:
13950                             case OP_OR:
13951                             case OP_DOR:
13952                                 lop = nop = nop->op_next;
13953                                 break;
13954                             case OP_NULL:
13955                                 nop = nop->op_next;
13956                                 break;
13957                             default:
13958                                 nop = NULL;
13959                                 break;
13960                         }
13961                     }
13962                 }
13963                 if (fop) {
13964                     if (  (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
13965                       || o->op_type == OP_AND  )
13966                         fop->op_private |= OPpTRUEBOOL;
13967                     else if (!(lop->op_flags & OPf_WANT))
13968                         fop->op_private |= OPpMAYBE_TRUEBOOL;
13969                 }
13970                 if (  (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
13971                    && sop)
13972                     sop->op_private |= OPpTRUEBOOL;
13973             }
13974
13975
13976             break;
13977
13978         case OP_COND_EXPR:
13979             if ((fop = HV_OR_SCALARHV(cLOGOP->op_first)))
13980                 fop->op_private |= OPpTRUEBOOL;
13981 #undef HV_OR_SCALARHV
13982             /* GERONIMO! */ /* FALLTHROUGH */
13983
13984         case OP_MAPWHILE:
13985         case OP_GREPWHILE:
13986         case OP_ANDASSIGN:
13987         case OP_ORASSIGN:
13988         case OP_DORASSIGN:
13989         case OP_RANGE:
13990         case OP_ONCE:
13991             while (cLOGOP->op_other->op_type == OP_NULL)
13992                 cLOGOP->op_other = cLOGOP->op_other->op_next;
13993             DEFER(cLOGOP->op_other);
13994             break;
13995
13996         case OP_ENTERLOOP:
13997         case OP_ENTERITER:
13998             while (cLOOP->op_redoop->op_type == OP_NULL)
13999                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
14000             while (cLOOP->op_nextop->op_type == OP_NULL)
14001                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
14002             while (cLOOP->op_lastop->op_type == OP_NULL)
14003                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
14004             /* a while(1) loop doesn't have an op_next that escapes the
14005              * loop, so we have to explicitly follow the op_lastop to
14006              * process the rest of the code */
14007             DEFER(cLOOP->op_lastop);
14008             break;
14009
14010         case OP_ENTERTRY:
14011             assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
14012             DEFER(cLOGOPo->op_other);
14013             break;
14014
14015         case OP_SUBST:
14016             assert(!(cPMOP->op_pmflags & PMf_ONCE));
14017             while (cPMOP->op_pmstashstartu.op_pmreplstart &&
14018                    cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
14019                 cPMOP->op_pmstashstartu.op_pmreplstart
14020                     = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
14021             DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
14022             break;
14023
14024         case OP_SORT: {
14025             OP *oright;
14026
14027             if (o->op_flags & OPf_SPECIAL) {
14028                 /* first arg is a code block */
14029                 OP * const nullop = OpSIBLING(cLISTOP->op_first);
14030                 OP * kid          = cUNOPx(nullop)->op_first;
14031
14032                 assert(nullop->op_type == OP_NULL);
14033                 assert(kid->op_type == OP_SCOPE
14034                  || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
14035                 /* since OP_SORT doesn't have a handy op_other-style
14036                  * field that can point directly to the start of the code
14037                  * block, store it in the otherwise-unused op_next field
14038                  * of the top-level OP_NULL. This will be quicker at
14039                  * run-time, and it will also allow us to remove leading
14040                  * OP_NULLs by just messing with op_nexts without
14041                  * altering the basic op_first/op_sibling layout. */
14042                 kid = kLISTOP->op_first;
14043                 assert(
14044                       (kid->op_type == OP_NULL
14045                       && (  kid->op_targ == OP_NEXTSTATE
14046                          || kid->op_targ == OP_DBSTATE  ))
14047                     || kid->op_type == OP_STUB
14048                     || kid->op_type == OP_ENTER);
14049                 nullop->op_next = kLISTOP->op_next;
14050                 DEFER(nullop->op_next);
14051             }
14052
14053             /* check that RHS of sort is a single plain array */
14054             oright = cUNOPo->op_first;
14055             if (!oright || oright->op_type != OP_PUSHMARK)
14056                 break;
14057
14058             if (o->op_private & OPpSORT_INPLACE)
14059                 break;
14060
14061             /* reverse sort ... can be optimised.  */
14062             if (!OpHAS_SIBLING(cUNOPo)) {
14063                 /* Nothing follows us on the list. */
14064                 OP * const reverse = o->op_next;
14065
14066                 if (reverse->op_type == OP_REVERSE &&
14067                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
14068                     OP * const pushmark = cUNOPx(reverse)->op_first;
14069                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
14070                         && (OpSIBLING(cUNOPx(pushmark)) == o)) {
14071                         /* reverse -> pushmark -> sort */
14072                         o->op_private |= OPpSORT_REVERSE;
14073                         op_null(reverse);
14074                         pushmark->op_next = oright->op_next;
14075                         op_null(oright);
14076                     }
14077                 }
14078             }
14079
14080             break;
14081         }
14082
14083         case OP_REVERSE: {
14084             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
14085             OP *gvop = NULL;
14086             LISTOP *enter, *exlist;
14087
14088             if (o->op_private & OPpSORT_INPLACE)
14089                 break;
14090
14091             enter = (LISTOP *) o->op_next;
14092             if (!enter)
14093                 break;
14094             if (enter->op_type == OP_NULL) {
14095                 enter = (LISTOP *) enter->op_next;
14096                 if (!enter)
14097                     break;
14098             }
14099             /* for $a (...) will have OP_GV then OP_RV2GV here.
14100                for (...) just has an OP_GV.  */
14101             if (enter->op_type == OP_GV) {
14102                 gvop = (OP *) enter;
14103                 enter = (LISTOP *) enter->op_next;
14104                 if (!enter)
14105                     break;
14106                 if (enter->op_type == OP_RV2GV) {
14107                   enter = (LISTOP *) enter->op_next;
14108                   if (!enter)
14109                     break;
14110                 }
14111             }
14112
14113             if (enter->op_type != OP_ENTERITER)
14114                 break;
14115
14116             iter = enter->op_next;
14117             if (!iter || iter->op_type != OP_ITER)
14118                 break;
14119
14120             expushmark = enter->op_first;
14121             if (!expushmark || expushmark->op_type != OP_NULL
14122                 || expushmark->op_targ != OP_PUSHMARK)
14123                 break;
14124
14125             exlist = (LISTOP *) OpSIBLING(expushmark);
14126             if (!exlist || exlist->op_type != OP_NULL
14127                 || exlist->op_targ != OP_LIST)
14128                 break;
14129
14130             if (exlist->op_last != o) {
14131                 /* Mmm. Was expecting to point back to this op.  */
14132                 break;
14133             }
14134             theirmark = exlist->op_first;
14135             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
14136                 break;
14137
14138             if (OpSIBLING(theirmark) != o) {
14139                 /* There's something between the mark and the reverse, eg
14140                    for (1, reverse (...))
14141                    so no go.  */
14142                 break;
14143             }
14144
14145             ourmark = ((LISTOP *)o)->op_first;
14146             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
14147                 break;
14148
14149             ourlast = ((LISTOP *)o)->op_last;
14150             if (!ourlast || ourlast->op_next != o)
14151                 break;
14152
14153             rv2av = OpSIBLING(ourmark);
14154             if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
14155                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
14156                 /* We're just reversing a single array.  */
14157                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
14158                 enter->op_flags |= OPf_STACKED;
14159             }
14160
14161             /* We don't have control over who points to theirmark, so sacrifice
14162                ours.  */
14163             theirmark->op_next = ourmark->op_next;
14164             theirmark->op_flags = ourmark->op_flags;
14165             ourlast->op_next = gvop ? gvop : (OP *) enter;
14166             op_null(ourmark);
14167             op_null(o);
14168             enter->op_private |= OPpITER_REVERSED;
14169             iter->op_private |= OPpITER_REVERSED;
14170
14171             oldoldop = NULL;
14172             oldop    = ourlast;
14173             o        = oldop->op_next;
14174             goto redo;
14175
14176             break;
14177         }
14178
14179         case OP_QR:
14180         case OP_MATCH:
14181             if (!(cPMOP->op_pmflags & PMf_ONCE)) {
14182                 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
14183             }
14184             break;
14185
14186         case OP_RUNCV:
14187             if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
14188              && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
14189             {
14190                 SV *sv;
14191                 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
14192                 else {
14193                     sv = newRV((SV *)PL_compcv);
14194                     sv_rvweaken(sv);
14195                     SvREADONLY_on(sv);
14196                 }
14197                 OpTYPE_set(o, OP_CONST);
14198                 o->op_flags |= OPf_SPECIAL;
14199                 cSVOPo->op_sv = sv;
14200             }
14201             break;
14202
14203         case OP_SASSIGN:
14204             if (OP_GIMME(o,0) == G_VOID
14205              || (  o->op_next->op_type == OP_LINESEQ
14206                 && (  o->op_next->op_next->op_type == OP_LEAVESUB
14207                    || (  o->op_next->op_next->op_type == OP_RETURN
14208                       && !CvLVALUE(PL_compcv)))))
14209             {
14210                 OP *right = cBINOP->op_first;
14211                 if (right) {
14212                     /*   sassign
14213                     *      RIGHT
14214                     *      substr
14215                     *         pushmark
14216                     *         arg1
14217                     *         arg2
14218                     *         ...
14219                     * becomes
14220                     *
14221                     *  ex-sassign
14222                     *     substr
14223                     *        pushmark
14224                     *        RIGHT
14225                     *        arg1
14226                     *        arg2
14227                     *        ...
14228                     */
14229                     OP *left = OpSIBLING(right);
14230                     if (left->op_type == OP_SUBSTR
14231                          && (left->op_private & 7) < 4) {
14232                         op_null(o);
14233                         /* cut out right */
14234                         op_sibling_splice(o, NULL, 1, NULL);
14235                         /* and insert it as second child of OP_SUBSTR */
14236                         op_sibling_splice(left, cBINOPx(left)->op_first, 0,
14237                                     right);
14238                         left->op_private |= OPpSUBSTR_REPL_FIRST;
14239                         left->op_flags =
14240                             (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
14241                     }
14242                 }
14243             }
14244             break;
14245
14246         case OP_AASSIGN: {
14247             int l, r, lr, lscalars, rscalars;
14248
14249             /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
14250                Note that we do this now rather than in newASSIGNOP(),
14251                since only by now are aliased lexicals flagged as such
14252
14253                See the essay "Common vars in list assignment" above for
14254                the full details of the rationale behind all the conditions
14255                below.
14256
14257                PL_generation sorcery:
14258                To detect whether there are common vars, the global var
14259                PL_generation is incremented for each assign op we scan.
14260                Then we run through all the lexical variables on the LHS,
14261                of the assignment, setting a spare slot in each of them to
14262                PL_generation.  Then we scan the RHS, and if any lexicals
14263                already have that value, we know we've got commonality.
14264                Also, if the generation number is already set to
14265                PERL_INT_MAX, then the variable is involved in aliasing, so
14266                we also have potential commonality in that case.
14267              */
14268
14269             PL_generation++;
14270             /* scan LHS */
14271             lscalars = 0;
14272             l = S_aassign_scan(aTHX_ cLISTOPo->op_last,  FALSE, 1, &lscalars);
14273             /* scan RHS */
14274             rscalars = 0;
14275             r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, 1, &rscalars);
14276             lr = (l|r);
14277
14278
14279             /* After looking for things which are *always* safe, this main
14280              * if/else chain selects primarily based on the type of the
14281              * LHS, gradually working its way down from the more dangerous
14282              * to the more restrictive and thus safer cases */
14283
14284             if (   !l                      /* () = ....; */
14285                 || !r                      /* .... = (); */
14286                 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
14287                 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
14288                 || (lscalars < 2)          /* ($x, undef) = ... */
14289             ) {
14290                 NOOP; /* always safe */
14291             }
14292             else if (l & AAS_DANGEROUS) {
14293                 /* always dangerous */
14294                 o->op_private |= OPpASSIGN_COMMON_SCALAR;
14295                 o->op_private |= OPpASSIGN_COMMON_AGG;
14296             }
14297             else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
14298                 /* package vars are always dangerous - too many
14299                  * aliasing possibilities */
14300                 if (l & AAS_PKG_SCALAR)
14301                     o->op_private |= OPpASSIGN_COMMON_SCALAR;
14302                 if (l & AAS_PKG_AGG)
14303                     o->op_private |= OPpASSIGN_COMMON_AGG;
14304             }
14305             else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
14306                           |AAS_LEX_SCALAR|AAS_LEX_AGG))
14307             {
14308                 /* LHS contains only lexicals and safe ops */
14309
14310                 if (l & (AAS_MY_AGG|AAS_LEX_AGG))
14311                     o->op_private |= OPpASSIGN_COMMON_AGG;
14312
14313                 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
14314                     if (lr & AAS_LEX_SCALAR_COMM)
14315                         o->op_private |= OPpASSIGN_COMMON_SCALAR;
14316                     else if (   !(l & AAS_LEX_SCALAR)
14317                              && (r & AAS_DEFAV))
14318                     {
14319                         /* falsely mark
14320                          *    my (...) = @_
14321                          * as scalar-safe for performance reasons.
14322                          * (it will still have been marked _AGG if necessary */
14323                         NOOP;
14324                     }
14325                     else if (r  & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
14326                         o->op_private |= OPpASSIGN_COMMON_RC1;
14327                 }
14328             }
14329
14330             /* ... = ($x)
14331              * may have to handle aggregate on LHS, but we can't
14332              * have common scalars. */
14333             if (rscalars < 2)
14334                 o->op_private &=
14335                         ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
14336
14337             break;
14338         }
14339
14340         case OP_CUSTOM: {
14341             Perl_cpeep_t cpeep =
14342                 XopENTRYCUSTOM(o, xop_peep);
14343             if (cpeep)
14344                 cpeep(aTHX_ o, oldop);
14345             break;
14346         }
14347
14348         }
14349         /* did we just null the current op? If so, re-process it to handle
14350          * eliding "empty" ops from the chain */
14351         if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
14352             o->op_opt = 0;
14353             o = oldop;
14354         }
14355         else {
14356             oldoldop = oldop;
14357             oldop = o;
14358         }
14359     }
14360     LEAVE;
14361 }
14362
14363 void
14364 Perl_peep(pTHX_ OP *o)
14365 {
14366     CALL_RPEEP(o);
14367 }
14368
14369 /*
14370 =head1 Custom Operators
14371
14372 =for apidoc Ao||custom_op_xop
14373 Return the XOP structure for a given custom op.  This macro should be
14374 considered internal to C<OP_NAME> and the other access macros: use them instead.
14375 This macro does call a function.  Prior
14376 to 5.19.6, this was implemented as a
14377 function.
14378
14379 =cut
14380 */
14381
14382 XOPRETANY
14383 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
14384 {
14385     SV *keysv;
14386     HE *he = NULL;
14387     XOP *xop;
14388
14389     static const XOP xop_null = { 0, 0, 0, 0, 0 };
14390
14391     PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
14392     assert(o->op_type == OP_CUSTOM);
14393
14394     /* This is wrong. It assumes a function pointer can be cast to IV,
14395      * which isn't guaranteed, but this is what the old custom OP code
14396      * did. In principle it should be safer to Copy the bytes of the
14397      * pointer into a PV: since the new interface is hidden behind
14398      * functions, this can be changed later if necessary.  */
14399     /* Change custom_op_xop if this ever happens */
14400     keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
14401
14402     if (PL_custom_ops)
14403         he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
14404
14405     /* assume noone will have just registered a desc */
14406     if (!he && PL_custom_op_names &&
14407         (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
14408     ) {
14409         const char *pv;
14410         STRLEN l;
14411
14412         /* XXX does all this need to be shared mem? */
14413         Newxz(xop, 1, XOP);
14414         pv = SvPV(HeVAL(he), l);
14415         XopENTRY_set(xop, xop_name, savepvn(pv, l));
14416         if (PL_custom_op_descs &&
14417             (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
14418         ) {
14419             pv = SvPV(HeVAL(he), l);
14420             XopENTRY_set(xop, xop_desc, savepvn(pv, l));
14421         }
14422         Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
14423     }
14424     else {
14425         if (!he)
14426             xop = (XOP *)&xop_null;
14427         else
14428             xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
14429     }
14430     {
14431         XOPRETANY any;
14432         if(field == XOPe_xop_ptr) {
14433             any.xop_ptr = xop;
14434         } else {
14435             const U32 flags = XopFLAGS(xop);
14436             if(flags & field) {
14437                 switch(field) {
14438                 case XOPe_xop_name:
14439                     any.xop_name = xop->xop_name;
14440                     break;
14441                 case XOPe_xop_desc:
14442                     any.xop_desc = xop->xop_desc;
14443                     break;
14444                 case XOPe_xop_class:
14445                     any.xop_class = xop->xop_class;
14446                     break;
14447                 case XOPe_xop_peep:
14448                     any.xop_peep = xop->xop_peep;
14449                     break;
14450                 default:
14451                     NOT_REACHED; /* NOTREACHED */
14452                     break;
14453                 }
14454             } else {
14455                 switch(field) {
14456                 case XOPe_xop_name:
14457                     any.xop_name = XOPd_xop_name;
14458                     break;
14459                 case XOPe_xop_desc:
14460                     any.xop_desc = XOPd_xop_desc;
14461                     break;
14462                 case XOPe_xop_class:
14463                     any.xop_class = XOPd_xop_class;
14464                     break;
14465                 case XOPe_xop_peep:
14466                     any.xop_peep = XOPd_xop_peep;
14467                     break;
14468                 default:
14469                     NOT_REACHED; /* NOTREACHED */
14470                     break;
14471                 }
14472             }
14473         }
14474         /* On some platforms (HP-UX, IA64) gcc emits a warning for this function:
14475          * op.c: In function 'Perl_custom_op_get_field':
14476          * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
14477          * This is because on those platforms (with -DEBUGGING) NOT_REACHED
14478          * expands to assert(0), which expands to ((0) ? (void)0 :
14479          * __assert(...)), and gcc doesn't know that __assert can never return. */
14480         return any;
14481     }
14482 }
14483
14484 /*
14485 =for apidoc Ao||custom_op_register
14486 Register a custom op.  See L<perlguts/"Custom Operators">.
14487
14488 =cut
14489 */
14490
14491 void
14492 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
14493 {
14494     SV *keysv;
14495
14496     PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
14497
14498     /* see the comment in custom_op_xop */
14499     keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
14500
14501     if (!PL_custom_ops)
14502         PL_custom_ops = newHV();
14503
14504     if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
14505         Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
14506 }
14507
14508 /*
14509
14510 =for apidoc core_prototype
14511
14512 This function assigns the prototype of the named core function to C<sv>, or
14513 to a new mortal SV if C<sv> is C<NULL>.  It returns the modified C<sv>, or
14514 C<NULL> if the core function has no prototype.  C<code> is a code as returned
14515 by C<keyword()>.  It must not be equal to 0.
14516
14517 =cut
14518 */
14519
14520 SV *
14521 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
14522                           int * const opnum)
14523 {
14524     int i = 0, n = 0, seen_question = 0, defgv = 0;
14525     I32 oa;
14526 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
14527     char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
14528     bool nullret = FALSE;
14529
14530     PERL_ARGS_ASSERT_CORE_PROTOTYPE;
14531
14532     assert (code);
14533
14534     if (!sv) sv = sv_newmortal();
14535
14536 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
14537
14538     switch (code < 0 ? -code : code) {
14539     case KEY_and   : case KEY_chop: case KEY_chomp:
14540     case KEY_cmp   : case KEY_defined: case KEY_delete: case KEY_exec  :
14541     case KEY_exists: case KEY_eq     : case KEY_ge    : case KEY_goto  :
14542     case KEY_grep  : case KEY_gt     : case KEY_last  : case KEY_le    :
14543     case KEY_lt    : case KEY_map    : case KEY_ne    : case KEY_next  :
14544     case KEY_or    : case KEY_print  : case KEY_printf: case KEY_qr    :
14545     case KEY_redo  : case KEY_require: case KEY_return: case KEY_say   :
14546     case KEY_select: case KEY_sort   : case KEY_split : case KEY_system:
14547     case KEY_x     : case KEY_xor    :
14548         if (!opnum) return NULL; nullret = TRUE; goto findopnum;
14549     case KEY_glob:    retsetpvs("_;", OP_GLOB);
14550     case KEY_keys:    retsetpvs("\\[%@]", OP_KEYS);
14551     case KEY_values:  retsetpvs("\\[%@]", OP_VALUES);
14552     case KEY_each:    retsetpvs("\\[%@]", OP_EACH);
14553     case KEY_push:    retsetpvs("\\@@", OP_PUSH);
14554     case KEY_unshift: retsetpvs("\\@@", OP_UNSHIFT);
14555     case KEY_pop:     retsetpvs(";\\@", OP_POP);
14556     case KEY_shift:   retsetpvs(";\\@", OP_SHIFT);
14557     case KEY_pos:     retsetpvs(";\\[$*]", OP_POS);
14558     case KEY_splice:
14559         retsetpvs("\\@;$$@", OP_SPLICE);
14560     case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
14561         retsetpvs("", 0);
14562     case KEY_evalbytes:
14563         name = "entereval"; break;
14564     case KEY_readpipe:
14565         name = "backtick";
14566     }
14567
14568 #undef retsetpvs
14569
14570   findopnum:
14571     while (i < MAXO) {  /* The slow way. */
14572         if (strEQ(name, PL_op_name[i])
14573             || strEQ(name, PL_op_desc[i]))
14574         {
14575             if (nullret) { assert(opnum); *opnum = i; return NULL; }
14576             goto found;
14577         }
14578         i++;
14579     }
14580     return NULL;
14581   found:
14582     defgv = PL_opargs[i] & OA_DEFGV;
14583     oa = PL_opargs[i] >> OASHIFT;
14584     while (oa) {
14585         if (oa & OA_OPTIONAL && !seen_question && (
14586               !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
14587         )) {
14588             seen_question = 1;
14589             str[n++] = ';';
14590         }
14591         if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
14592             && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
14593             /* But globs are already references (kinda) */
14594             && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
14595         ) {
14596             str[n++] = '\\';
14597         }
14598         if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
14599          && !scalar_mod_type(NULL, i)) {
14600             str[n++] = '[';
14601             str[n++] = '$';
14602             str[n++] = '@';
14603             str[n++] = '%';
14604             if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
14605             str[n++] = '*';
14606             str[n++] = ']';
14607         }
14608         else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
14609         if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
14610             str[n-1] = '_'; defgv = 0;
14611         }
14612         oa = oa >> 4;
14613     }
14614     if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
14615     str[n++] = '\0';
14616     sv_setpvn(sv, str, n - 1);
14617     if (opnum) *opnum = i;
14618     return sv;
14619 }
14620
14621 OP *
14622 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
14623                       const int opnum)
14624 {
14625     OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
14626     OP *o;
14627
14628     PERL_ARGS_ASSERT_CORESUB_OP;
14629
14630     switch(opnum) {
14631     case 0:
14632         return op_append_elem(OP_LINESEQ,
14633                        argop,
14634                        newSLICEOP(0,
14635                                   newSVOP(OP_CONST, 0, newSViv(-code % 3)),
14636                                   newOP(OP_CALLER,0)
14637                        )
14638                );
14639     case OP_SELECT: /* which represents OP_SSELECT as well */
14640         if (code)
14641             return newCONDOP(
14642                          0,
14643                          newBINOP(OP_GT, 0,
14644                                   newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
14645                                   newSVOP(OP_CONST, 0, newSVuv(1))
14646                                  ),
14647                          coresub_op(newSVuv((UV)OP_SSELECT), 0,
14648                                     OP_SSELECT),
14649                          coresub_op(coreargssv, 0, OP_SELECT)
14650                    );
14651         /* FALLTHROUGH */
14652     default:
14653         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
14654         case OA_BASEOP:
14655             return op_append_elem(
14656                         OP_LINESEQ, argop,
14657                         newOP(opnum,
14658                               opnum == OP_WANTARRAY || opnum == OP_RUNCV
14659                                 ? OPpOFFBYONE << 8 : 0)
14660                    );
14661         case OA_BASEOP_OR_UNOP:
14662             if (opnum == OP_ENTEREVAL) {
14663                 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
14664                 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
14665             }
14666             else o = newUNOP(opnum,0,argop);
14667             if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
14668             else {
14669           onearg:
14670               if (is_handle_constructor(o, 1))
14671                 argop->op_private |= OPpCOREARGS_DEREF1;
14672               if (scalar_mod_type(NULL, opnum))
14673                 argop->op_private |= OPpCOREARGS_SCALARMOD;
14674             }
14675             return o;
14676         default:
14677             o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
14678             if (is_handle_constructor(o, 2))
14679                 argop->op_private |= OPpCOREARGS_DEREF2;
14680             if (opnum == OP_SUBSTR) {
14681                 o->op_private |= OPpMAYBE_LVSUB;
14682                 return o;
14683             }
14684             else goto onearg;
14685         }
14686     }
14687 }
14688
14689 void
14690 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
14691                                SV * const *new_const_svp)
14692 {
14693     const char *hvname;
14694     bool is_const = !!CvCONST(old_cv);
14695     SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
14696
14697     PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
14698
14699     if (is_const && new_const_svp && old_const_sv == *new_const_svp)
14700         return;
14701         /* They are 2 constant subroutines generated from
14702            the same constant. This probably means that
14703            they are really the "same" proxy subroutine
14704            instantiated in 2 places. Most likely this is
14705            when a constant is exported twice.  Don't warn.
14706         */
14707     if (
14708         (ckWARN(WARN_REDEFINE)
14709          && !(
14710                 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
14711              && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
14712              && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
14713                  strEQ(hvname, "autouse"))
14714              )
14715         )
14716      || (is_const
14717          && ckWARN_d(WARN_REDEFINE)
14718          && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
14719         )
14720     )
14721         Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
14722                           is_const
14723                             ? "Constant subroutine %"SVf" redefined"
14724                             : "Subroutine %"SVf" redefined",
14725                           SVfARG(name));
14726 }
14727
14728 /*
14729 =head1 Hook manipulation
14730
14731 These functions provide convenient and thread-safe means of manipulating
14732 hook variables.
14733
14734 =cut
14735 */
14736
14737 /*
14738 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
14739
14740 Puts a C function into the chain of check functions for a specified op
14741 type.  This is the preferred way to manipulate the L</PL_check> array.
14742 C<opcode> specifies which type of op is to be affected.  C<new_checker>
14743 is a pointer to the C function that is to be added to that opcode's
14744 check chain, and C<old_checker_p> points to the storage location where a
14745 pointer to the next function in the chain will be stored.  The value of
14746 C<new_pointer> is written into the L</PL_check> array, while the value
14747 previously stored there is written to C<*old_checker_p>.
14748
14749 The function should be defined like this:
14750
14751     static OP *new_checker(pTHX_ OP *op) { ... }
14752
14753 It is intended to be called in this manner:
14754
14755     new_checker(aTHX_ op)
14756
14757 C<old_checker_p> should be defined like this:
14758
14759     static Perl_check_t old_checker_p;
14760
14761 L</PL_check> is global to an entire process, and a module wishing to
14762 hook op checking may find itself invoked more than once per process,
14763 typically in different threads.  To handle that situation, this function
14764 is idempotent.  The location C<*old_checker_p> must initially (once
14765 per process) contain a null pointer.  A C variable of static duration
14766 (declared at file scope, typically also marked C<static> to give
14767 it internal linkage) will be implicitly initialised appropriately,
14768 if it does not have an explicit initialiser.  This function will only
14769 actually modify the check chain if it finds C<*old_checker_p> to be null.
14770 This function is also thread safe on the small scale.  It uses appropriate
14771 locking to avoid race conditions in accessing L</PL_check>.
14772
14773 When this function is called, the function referenced by C<new_checker>
14774 must be ready to be called, except for C<*old_checker_p> being unfilled.
14775 In a threading situation, C<new_checker> may be called immediately,
14776 even before this function has returned.  C<*old_checker_p> will always
14777 be appropriately set before C<new_checker> is called.  If C<new_checker>
14778 decides not to do anything special with an op that it is given (which
14779 is the usual case for most uses of op check hooking), it must chain the
14780 check function referenced by C<*old_checker_p>.
14781
14782 If you want to influence compilation of calls to a specific subroutine,
14783 then use L</cv_set_call_checker> rather than hooking checking of all
14784 C<entersub> ops.
14785
14786 =cut
14787 */
14788
14789 void
14790 Perl_wrap_op_checker(pTHX_ Optype opcode,
14791     Perl_check_t new_checker, Perl_check_t *old_checker_p)
14792 {
14793     dVAR;
14794
14795     PERL_UNUSED_CONTEXT;
14796     PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
14797     if (*old_checker_p) return;
14798     OP_CHECK_MUTEX_LOCK;
14799     if (!*old_checker_p) {
14800         *old_checker_p = PL_check[opcode];
14801         PL_check[opcode] = new_checker;
14802     }
14803     OP_CHECK_MUTEX_UNLOCK;
14804 }
14805
14806 #include "XSUB.h"
14807
14808 /* Efficient sub that returns a constant scalar value. */
14809 static void
14810 const_sv_xsub(pTHX_ CV* cv)
14811 {
14812     dXSARGS;
14813     SV *const sv = MUTABLE_SV(XSANY.any_ptr);
14814     PERL_UNUSED_ARG(items);
14815     if (!sv) {
14816         XSRETURN(0);
14817     }
14818     EXTEND(sp, 1);
14819     ST(0) = sv;
14820     XSRETURN(1);
14821 }
14822
14823 static void
14824 const_av_xsub(pTHX_ CV* cv)
14825 {
14826     dXSARGS;
14827     AV * const av = MUTABLE_AV(XSANY.any_ptr);
14828     SP -= items;
14829     assert(av);
14830 #ifndef DEBUGGING
14831     if (!av) {
14832         XSRETURN(0);
14833     }
14834 #endif
14835     if (SvRMAGICAL(av))
14836         Perl_croak(aTHX_ "Magical list constants are not supported");
14837     if (GIMME_V != G_ARRAY) {
14838         EXTEND(SP, 1);
14839         ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
14840         XSRETURN(1);
14841     }
14842     EXTEND(SP, AvFILLp(av)+1);
14843     Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
14844     XSRETURN(AvFILLp(av)+1);
14845 }
14846
14847 /*
14848  * ex: set ts=8 sts=4 sw=4 et:
14849  */