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 = CX_CUR();
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     OP *old_next;
4262     SV * const oldwarnhook = PL_warnhook;
4263     SV * const olddiehook  = PL_diehook;
4264     COP not_compiling;
4265     U8 oldwarn = PL_dowarn;
4266     I32 old_cxix;
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     old_cxix = cxstack_ix;
4348     create_eval_scope(NULL, 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 we croaked, depending on how we croaked the eval scope
4400      * may or may not have already been popped */
4401     if (cxstack_ix > old_cxix) {
4402         assert(cxstack_ix == old_cxix + 1);
4403         assert(CxTYPE(CX_CUR()) == CXt_EVAL);
4404         delete_eval_scope();
4405     }
4406     if (ret)
4407         goto nope;
4408
4409     /* OP_STRINGIFY and constant folding are used to implement qq.
4410        Here the constant folding is an implementation detail that we
4411        want to hide.  If the stringify op is itself already marked
4412        folded, however, then it is actually a folded join.  */
4413     is_stringify = type == OP_STRINGIFY && !o->op_folded;
4414     op_free(o);
4415     assert(sv);
4416     if (is_stringify)
4417         SvPADTMP_off(sv);
4418     else if (!SvIMMORTAL(sv)) {
4419         SvPADTMP_on(sv);
4420         SvREADONLY_on(sv);
4421     }
4422     newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
4423     if (!is_stringify) newop->op_folded = 1;
4424     return newop;
4425
4426  nope:
4427     return o;
4428 }
4429
4430 static OP *
4431 S_gen_constant_list(pTHX_ OP *o)
4432 {
4433     dVAR;
4434     OP *curop;
4435     const SSize_t oldtmps_floor = PL_tmps_floor;
4436     SV **svp;
4437     AV *av;
4438
4439     list(o);
4440     if (PL_parser && PL_parser->error_count)
4441         return o;               /* Don't attempt to run with errors */
4442
4443     curop = LINKLIST(o);
4444     o->op_next = 0;
4445     CALL_PEEP(curop);
4446     S_prune_chain_head(&curop);
4447     PL_op = curop;
4448     Perl_pp_pushmark(aTHX);
4449     CALLRUNOPS(aTHX);
4450     PL_op = curop;
4451     assert (!(curop->op_flags & OPf_SPECIAL));
4452     assert(curop->op_type == OP_RANGE);
4453     Perl_pp_anonlist(aTHX);
4454     PL_tmps_floor = oldtmps_floor;
4455
4456     OpTYPE_set(o, OP_RV2AV);
4457     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
4458     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
4459     o->op_opt = 0;              /* needs to be revisited in rpeep() */
4460     av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
4461
4462     /* replace subtree with an OP_CONST */
4463     curop = ((UNOP*)o)->op_first;
4464     op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
4465     op_free(curop);
4466
4467     if (AvFILLp(av) != -1)
4468         for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
4469         {
4470             SvPADTMP_on(*svp);
4471             SvREADONLY_on(*svp);
4472         }
4473     LINKLIST(o);
4474     return list(o);
4475 }
4476
4477 /*
4478 =head1 Optree Manipulation Functions
4479 */
4480
4481 /* List constructors */
4482
4483 /*
4484 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
4485
4486 Append an item to the list of ops contained directly within a list-type
4487 op, returning the lengthened list.  C<first> is the list-type op,
4488 and C<last> is the op to append to the list.  C<optype> specifies the
4489 intended opcode for the list.  If C<first> is not already a list of the
4490 right type, it will be upgraded into one.  If either C<first> or C<last>
4491 is null, the other is returned unchanged.
4492
4493 =cut
4494 */
4495
4496 OP *
4497 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
4498 {
4499     if (!first)
4500         return last;
4501
4502     if (!last)
4503         return first;
4504
4505     if (first->op_type != (unsigned)type
4506         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
4507     {
4508         return newLISTOP(type, 0, first, last);
4509     }
4510
4511     op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
4512     first->op_flags |= OPf_KIDS;
4513     return first;
4514 }
4515
4516 /*
4517 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
4518
4519 Concatenate the lists of ops contained directly within two list-type ops,
4520 returning the combined list.  C<first> and C<last> are the list-type ops
4521 to concatenate.  C<optype> specifies the intended opcode for the list.
4522 If either C<first> or C<last> is not already a list of the right type,
4523 it will be upgraded into one.  If either C<first> or C<last> is null,
4524 the other is returned unchanged.
4525
4526 =cut
4527 */
4528
4529 OP *
4530 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
4531 {
4532     if (!first)
4533         return last;
4534
4535     if (!last)
4536         return first;
4537
4538     if (first->op_type != (unsigned)type)
4539         return op_prepend_elem(type, first, last);
4540
4541     if (last->op_type != (unsigned)type)
4542         return op_append_elem(type, first, last);
4543
4544     OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
4545     ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
4546     OpLASTSIB_set(((LISTOP*)first)->op_last, first);
4547     first->op_flags |= (last->op_flags & OPf_KIDS);
4548
4549     S_op_destroy(aTHX_ last);
4550
4551     return first;
4552 }
4553
4554 /*
4555 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
4556
4557 Prepend an item to the list of ops contained directly within a list-type
4558 op, returning the lengthened list.  C<first> is the op to prepend to the
4559 list, and C<last> is the list-type op.  C<optype> specifies the intended
4560 opcode for the list.  If C<last> is not already a list of the right type,
4561 it will be upgraded into one.  If either C<first> or C<last> is null,
4562 the other is returned unchanged.
4563
4564 =cut
4565 */
4566
4567 OP *
4568 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
4569 {
4570     if (!first)
4571         return last;
4572
4573     if (!last)
4574         return first;
4575
4576     if (last->op_type == (unsigned)type) {
4577         if (type == OP_LIST) {  /* already a PUSHMARK there */
4578             /* insert 'first' after pushmark */
4579             op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
4580             if (!(first->op_flags & OPf_PARENS))
4581                 last->op_flags &= ~OPf_PARENS;
4582         }
4583         else
4584             op_sibling_splice(last, NULL, 0, first);
4585         last->op_flags |= OPf_KIDS;
4586         return last;
4587     }
4588
4589     return newLISTOP(type, 0, first, last);
4590 }
4591
4592 /*
4593 =for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
4594
4595 Converts C<o> into a list op if it is not one already, and then converts it
4596 into the specified C<type>, calling its check function, allocating a target if
4597 it needs one, and folding constants.
4598
4599 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
4600 C<op_prepend_elem> and C<op_append_elem>.  Then finally it is passed to
4601 C<op_convert_list> to make it the right type.
4602
4603 =cut
4604 */
4605
4606 OP *
4607 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
4608 {
4609     dVAR;
4610     if (type < 0) type = -type, flags |= OPf_SPECIAL;
4611     if (!o || o->op_type != OP_LIST)
4612         o = force_list(o, 0);
4613     else
4614     {
4615         o->op_flags &= ~OPf_WANT;
4616         o->op_private &= ~OPpLVAL_INTRO;
4617     }
4618
4619     if (!(PL_opargs[type] & OA_MARK))
4620         op_null(cLISTOPo->op_first);
4621     else {
4622         OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
4623         if (kid2 && kid2->op_type == OP_COREARGS) {
4624             op_null(cLISTOPo->op_first);
4625             kid2->op_private |= OPpCOREARGS_PUSHMARK;
4626         }
4627     }
4628
4629     OpTYPE_set(o, type);
4630     o->op_flags |= flags;
4631     if (flags & OPf_FOLDED)
4632         o->op_folded = 1;
4633
4634     o = CHECKOP(type, o);
4635     if (o->op_type != (unsigned)type)
4636         return o;
4637
4638     return fold_constants(op_integerize(op_std_init(o)));
4639 }
4640
4641 /* Constructors */
4642
4643
4644 /*
4645 =head1 Optree construction
4646
4647 =for apidoc Am|OP *|newNULLLIST
4648
4649 Constructs, checks, and returns a new C<stub> op, which represents an
4650 empty list expression.
4651
4652 =cut
4653 */
4654
4655 OP *
4656 Perl_newNULLLIST(pTHX)
4657 {
4658     return newOP(OP_STUB, 0);
4659 }
4660
4661 /* promote o and any siblings to be a list if its not already; i.e.
4662  *
4663  *  o - A - B
4664  *
4665  * becomes
4666  *
4667  *  list
4668  *    |
4669  *  pushmark - o - A - B
4670  *
4671  * If nullit it true, the list op is nulled.
4672  */
4673
4674 static OP *
4675 S_force_list(pTHX_ OP *o, bool nullit)
4676 {
4677     if (!o || o->op_type != OP_LIST) {
4678         OP *rest = NULL;
4679         if (o) {
4680             /* manually detach any siblings then add them back later */
4681             rest = OpSIBLING(o);
4682             OpLASTSIB_set(o, NULL);
4683         }
4684         o = newLISTOP(OP_LIST, 0, o, NULL);
4685         if (rest)
4686             op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
4687     }
4688     if (nullit)
4689         op_null(o);
4690     return o;
4691 }
4692
4693 /*
4694 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
4695
4696 Constructs, checks, and returns an op of any list type.  C<type> is
4697 the opcode.  C<flags> gives the eight bits of C<op_flags>, except that
4698 C<OPf_KIDS> will be set automatically if required.  C<first> and C<last>
4699 supply up to two ops to be direct children of the list op; they are
4700 consumed by this function and become part of the constructed op tree.
4701
4702 For most list operators, the check function expects all the kid ops to be
4703 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
4704 appropriate.  What you want to do in that case is create an op of type
4705 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
4706 See L</op_convert_list> for more information.
4707
4708
4709 =cut
4710 */
4711
4712 OP *
4713 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4714 {
4715     dVAR;
4716     LISTOP *listop;
4717
4718     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
4719         || type == OP_CUSTOM);
4720
4721     NewOp(1101, listop, 1, LISTOP);
4722
4723     OpTYPE_set(listop, type);
4724     if (first || last)
4725         flags |= OPf_KIDS;
4726     listop->op_flags = (U8)flags;
4727
4728     if (!last && first)
4729         last = first;
4730     else if (!first && last)
4731         first = last;
4732     else if (first)
4733         OpMORESIB_set(first, last);
4734     listop->op_first = first;
4735     listop->op_last = last;
4736     if (type == OP_LIST) {
4737         OP* const pushop = newOP(OP_PUSHMARK, 0);
4738         OpMORESIB_set(pushop, first);
4739         listop->op_first = pushop;
4740         listop->op_flags |= OPf_KIDS;
4741         if (!last)
4742             listop->op_last = pushop;
4743     }
4744     if (listop->op_last)
4745         OpLASTSIB_set(listop->op_last, (OP*)listop);
4746
4747     return CHECKOP(type, listop);
4748 }
4749
4750 /*
4751 =for apidoc Am|OP *|newOP|I32 type|I32 flags
4752
4753 Constructs, checks, and returns an op of any base type (any type that
4754 has no extra fields).  C<type> is the opcode.  C<flags> gives the
4755 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
4756 of C<op_private>.
4757
4758 =cut
4759 */
4760
4761 OP *
4762 Perl_newOP(pTHX_ I32 type, I32 flags)
4763 {
4764     dVAR;
4765     OP *o;
4766
4767     if (type == -OP_ENTEREVAL) {
4768         type = OP_ENTEREVAL;
4769         flags |= OPpEVAL_BYTES<<8;
4770     }
4771
4772     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
4773         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4774         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4775         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4776
4777     NewOp(1101, o, 1, OP);
4778     OpTYPE_set(o, type);
4779     o->op_flags = (U8)flags;
4780
4781     o->op_next = o;
4782     o->op_private = (U8)(0 | (flags >> 8));
4783     if (PL_opargs[type] & OA_RETSCALAR)
4784         scalar(o);
4785     if (PL_opargs[type] & OA_TARGET)
4786         o->op_targ = pad_alloc(type, SVs_PADTMP);
4787     return CHECKOP(type, o);
4788 }
4789
4790 /*
4791 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
4792
4793 Constructs, checks, and returns an op of any unary type.  C<type> is
4794 the opcode.  C<flags> gives the eight bits of C<op_flags>, except that
4795 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
4796 bits, the eight bits of C<op_private>, except that the bit with value 1
4797 is automatically set.  C<first> supplies an optional op to be the direct
4798 child of the unary op; it is consumed by this function and become part
4799 of the constructed op tree.
4800
4801 =cut
4802 */
4803
4804 OP *
4805 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
4806 {
4807     dVAR;
4808     UNOP *unop;
4809
4810     if (type == -OP_ENTEREVAL) {
4811         type = OP_ENTEREVAL;
4812         flags |= OPpEVAL_BYTES<<8;
4813     }
4814
4815     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
4816         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4817         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4818         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
4819         || type == OP_SASSIGN
4820         || type == OP_ENTERTRY
4821         || type == OP_CUSTOM
4822         || type == OP_NULL );
4823
4824     if (!first)
4825         first = newOP(OP_STUB, 0);
4826     if (PL_opargs[type] & OA_MARK)
4827         first = force_list(first, 1);
4828
4829     NewOp(1101, unop, 1, UNOP);
4830     OpTYPE_set(unop, type);
4831     unop->op_first = first;
4832     unop->op_flags = (U8)(flags | OPf_KIDS);
4833     unop->op_private = (U8)(1 | (flags >> 8));
4834
4835     if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
4836         OpLASTSIB_set(first, (OP*)unop);
4837
4838     unop = (UNOP*) CHECKOP(type, unop);
4839     if (unop->op_next)
4840         return (OP*)unop;
4841
4842     return fold_constants(op_integerize(op_std_init((OP *) unop)));
4843 }
4844
4845 /*
4846 =for apidoc newUNOP_AUX
4847
4848 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
4849 initialised to C<aux>
4850
4851 =cut
4852 */
4853
4854 OP *
4855 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
4856 {
4857     dVAR;
4858     UNOP_AUX *unop;
4859
4860     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
4861         || type == OP_CUSTOM);
4862
4863     NewOp(1101, unop, 1, UNOP_AUX);
4864     unop->op_type = (OPCODE)type;
4865     unop->op_ppaddr = PL_ppaddr[type];
4866     unop->op_first = first;
4867     unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
4868     unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
4869     unop->op_aux = aux;
4870
4871     if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
4872         OpLASTSIB_set(first, (OP*)unop);
4873
4874     unop = (UNOP_AUX*) CHECKOP(type, unop);
4875
4876     return op_std_init((OP *) unop);
4877 }
4878
4879 /*
4880 =for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
4881
4882 Constructs, checks, and returns an op of method type with a method name
4883 evaluated at runtime.  C<type> is the opcode.  C<flags> gives the eight
4884 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
4885 and, shifted up eight bits, the eight bits of C<op_private>, except that
4886 the bit with value 1 is automatically set.  C<dynamic_meth> supplies an
4887 op which evaluates method name; it is consumed by this function and
4888 become part of the constructed op tree.
4889 Supported optypes: C<OP_METHOD>.
4890
4891 =cut
4892 */
4893
4894 static OP*
4895 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
4896     dVAR;
4897     METHOP *methop;
4898
4899     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
4900         || type == OP_CUSTOM);
4901
4902     NewOp(1101, methop, 1, METHOP);
4903     if (dynamic_meth) {
4904         if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
4905         methop->op_flags = (U8)(flags | OPf_KIDS);
4906         methop->op_u.op_first = dynamic_meth;
4907         methop->op_private = (U8)(1 | (flags >> 8));
4908
4909         if (!OpHAS_SIBLING(dynamic_meth))
4910             OpLASTSIB_set(dynamic_meth, (OP*)methop);
4911     }
4912     else {
4913         assert(const_meth);
4914         methop->op_flags = (U8)(flags & ~OPf_KIDS);
4915         methop->op_u.op_meth_sv = const_meth;
4916         methop->op_private = (U8)(0 | (flags >> 8));
4917         methop->op_next = (OP*)methop;
4918     }
4919
4920 #ifdef USE_ITHREADS
4921     methop->op_rclass_targ = 0;
4922 #else
4923     methop->op_rclass_sv = NULL;
4924 #endif
4925
4926     OpTYPE_set(methop, type);
4927     return CHECKOP(type, methop);
4928 }
4929
4930 OP *
4931 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
4932     PERL_ARGS_ASSERT_NEWMETHOP;
4933     return newMETHOP_internal(type, flags, dynamic_meth, NULL);
4934 }
4935
4936 /*
4937 =for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
4938
4939 Constructs, checks, and returns an op of method type with a constant
4940 method name.  C<type> is the opcode.  C<flags> gives the eight bits of
4941 C<op_flags>, and, shifted up eight bits, the eight bits of
4942 C<op_private>.  C<const_meth> supplies a constant method name;
4943 it must be a shared COW string.
4944 Supported optypes: C<OP_METHOD_NAMED>.
4945
4946 =cut
4947 */
4948
4949 OP *
4950 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
4951     PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
4952     return newMETHOP_internal(type, flags, NULL, const_meth);
4953 }
4954
4955 /*
4956 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
4957
4958 Constructs, checks, and returns an op of any binary type.  C<type>
4959 is the opcode.  C<flags> gives the eight bits of C<op_flags>, except
4960 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4961 the eight bits of C<op_private>, except that the bit with value 1 or
4962 2 is automatically set as required.  C<first> and C<last> supply up to
4963 two ops to be the direct children of the binary op; they are consumed
4964 by this function and become part of the constructed op tree.
4965
4966 =cut
4967 */
4968
4969 OP *
4970 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4971 {
4972     dVAR;
4973     BINOP *binop;
4974
4975     ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
4976         || type == OP_SASSIGN || type == OP_NULL || type == OP_CUSTOM);
4977
4978     NewOp(1101, binop, 1, BINOP);
4979
4980     if (!first)
4981         first = newOP(OP_NULL, 0);
4982
4983     OpTYPE_set(binop, type);
4984     binop->op_first = first;
4985     binop->op_flags = (U8)(flags | OPf_KIDS);
4986     if (!last) {
4987         last = first;
4988         binop->op_private = (U8)(1 | (flags >> 8));
4989     }
4990     else {
4991         binop->op_private = (U8)(2 | (flags >> 8));
4992         OpMORESIB_set(first, last);
4993     }
4994
4995     if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
4996         OpLASTSIB_set(last, (OP*)binop);
4997
4998     binop->op_last = OpSIBLING(binop->op_first);
4999     if (binop->op_last)
5000         OpLASTSIB_set(binop->op_last, (OP*)binop);
5001
5002     binop = (BINOP*)CHECKOP(type, binop);
5003     if (binop->op_next || binop->op_type != (OPCODE)type)
5004         return (OP*)binop;
5005
5006     return fold_constants(op_integerize(op_std_init((OP *)binop)));
5007 }
5008
5009 static int uvcompare(const void *a, const void *b)
5010     __attribute__nonnull__(1)
5011     __attribute__nonnull__(2)
5012     __attribute__pure__;
5013 static int uvcompare(const void *a, const void *b)
5014 {
5015     if (*((const UV *)a) < (*(const UV *)b))
5016         return -1;
5017     if (*((const UV *)a) > (*(const UV *)b))
5018         return 1;
5019     if (*((const UV *)a+1) < (*(const UV *)b+1))
5020         return -1;
5021     if (*((const UV *)a+1) > (*(const UV *)b+1))
5022         return 1;
5023     return 0;
5024 }
5025
5026 static OP *
5027 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
5028 {
5029     SV * const tstr = ((SVOP*)expr)->op_sv;
5030     SV * const rstr =
5031                               ((SVOP*)repl)->op_sv;
5032     STRLEN tlen;
5033     STRLEN rlen;
5034     const U8 *t = (U8*)SvPV_const(tstr, tlen);
5035     const U8 *r = (U8*)SvPV_const(rstr, rlen);
5036     I32 i;
5037     I32 j;
5038     I32 grows = 0;
5039     short *tbl;
5040
5041     const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
5042     const I32 squash     = o->op_private & OPpTRANS_SQUASH;
5043     I32 del              = o->op_private & OPpTRANS_DELETE;
5044     SV* swash;
5045
5046     PERL_ARGS_ASSERT_PMTRANS;
5047
5048     PL_hints |= HINT_BLOCK_SCOPE;
5049
5050     if (SvUTF8(tstr))
5051         o->op_private |= OPpTRANS_FROM_UTF;
5052
5053     if (SvUTF8(rstr))
5054         o->op_private |= OPpTRANS_TO_UTF;
5055
5056     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
5057         SV* const listsv = newSVpvs("# comment\n");
5058         SV* transv = NULL;
5059         const U8* tend = t + tlen;
5060         const U8* rend = r + rlen;
5061         STRLEN ulen;
5062         UV tfirst = 1;
5063         UV tlast = 0;
5064         IV tdiff;
5065         STRLEN tcount = 0;
5066         UV rfirst = 1;
5067         UV rlast = 0;
5068         IV rdiff;
5069         STRLEN rcount = 0;
5070         IV diff;
5071         I32 none = 0;
5072         U32 max = 0;
5073         I32 bits;
5074         I32 havefinal = 0;
5075         U32 final = 0;
5076         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
5077         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
5078         U8* tsave = NULL;
5079         U8* rsave = NULL;
5080         const U32 flags = UTF8_ALLOW_DEFAULT;
5081
5082         if (!from_utf) {
5083             STRLEN len = tlen;
5084             t = tsave = bytes_to_utf8(t, &len);
5085             tend = t + len;
5086         }
5087         if (!to_utf && rlen) {
5088             STRLEN len = rlen;
5089             r = rsave = bytes_to_utf8(r, &len);
5090             rend = r + len;
5091         }
5092
5093 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
5094  * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
5095  * odd.  */
5096
5097         if (complement) {
5098             U8 tmpbuf[UTF8_MAXBYTES+1];
5099             UV *cp;
5100             UV nextmin = 0;
5101             Newx(cp, 2*tlen, UV);
5102             i = 0;
5103             transv = newSVpvs("");
5104             while (t < tend) {
5105                 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
5106                 t += ulen;
5107                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
5108                     t++;
5109                     cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
5110                     t += ulen;
5111                 }
5112                 else {
5113                  cp[2*i+1] = cp[2*i];
5114                 }
5115                 i++;
5116             }
5117             qsort(cp, i, 2*sizeof(UV), uvcompare);
5118             for (j = 0; j < i; j++) {
5119                 UV  val = cp[2*j];
5120                 diff = val - nextmin;
5121                 if (diff > 0) {
5122                     t = uvchr_to_utf8(tmpbuf,nextmin);
5123                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5124                     if (diff > 1) {
5125                         U8  range_mark = ILLEGAL_UTF8_BYTE;
5126                         t = uvchr_to_utf8(tmpbuf, val - 1);
5127                         sv_catpvn(transv, (char *)&range_mark, 1);
5128                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5129                     }
5130                 }
5131                 val = cp[2*j+1];
5132                 if (val >= nextmin)
5133                     nextmin = val + 1;
5134             }
5135             t = uvchr_to_utf8(tmpbuf,nextmin);
5136             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5137             {
5138                 U8 range_mark = ILLEGAL_UTF8_BYTE;
5139                 sv_catpvn(transv, (char *)&range_mark, 1);
5140             }
5141             t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
5142             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5143             t = (const U8*)SvPVX_const(transv);
5144             tlen = SvCUR(transv);
5145             tend = t + tlen;
5146             Safefree(cp);
5147         }
5148         else if (!rlen && !del) {
5149             r = t; rlen = tlen; rend = tend;
5150         }
5151         if (!squash) {
5152                 if ((!rlen && !del) || t == r ||
5153                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
5154                 {
5155                     o->op_private |= OPpTRANS_IDENTICAL;
5156                 }
5157         }
5158
5159         while (t < tend || tfirst <= tlast) {
5160             /* see if we need more "t" chars */
5161             if (tfirst > tlast) {
5162                 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
5163                 t += ulen;
5164                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {      /* illegal utf8 val indicates range */
5165                     t++;
5166                     tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
5167                     t += ulen;
5168                 }
5169                 else
5170                     tlast = tfirst;
5171             }
5172
5173             /* now see if we need more "r" chars */
5174             if (rfirst > rlast) {
5175                 if (r < rend) {
5176                     rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
5177                     r += ulen;
5178                     if (r < rend && *r == ILLEGAL_UTF8_BYTE) {  /* illegal utf8 val indicates range */
5179                         r++;
5180                         rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
5181                         r += ulen;
5182                     }
5183                     else
5184                         rlast = rfirst;
5185                 }
5186                 else {
5187                     if (!havefinal++)
5188                         final = rlast;
5189                     rfirst = rlast = 0xffffffff;
5190                 }
5191             }
5192
5193             /* now see which range will peter out first, if either. */
5194             tdiff = tlast - tfirst;
5195             rdiff = rlast - rfirst;
5196             tcount += tdiff + 1;
5197             rcount += rdiff + 1;
5198
5199             if (tdiff <= rdiff)
5200                 diff = tdiff;
5201             else
5202                 diff = rdiff;
5203
5204             if (rfirst == 0xffffffff) {
5205                 diff = tdiff;   /* oops, pretend rdiff is infinite */
5206                 if (diff > 0)
5207                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
5208                                    (long)tfirst, (long)tlast);
5209                 else
5210                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
5211             }
5212             else {
5213                 if (diff > 0)
5214                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
5215                                    (long)tfirst, (long)(tfirst + diff),
5216                                    (long)rfirst);
5217                 else
5218                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
5219                                    (long)tfirst, (long)rfirst);
5220
5221                 if (rfirst + diff > max)
5222                     max = rfirst + diff;
5223                 if (!grows)
5224                     grows = (tfirst < rfirst &&
5225                              UVCHR_SKIP(tfirst) < UVCHR_SKIP(rfirst + diff));
5226                 rfirst += diff + 1;
5227             }
5228             tfirst += diff + 1;
5229         }
5230
5231         none = ++max;
5232         if (del)
5233             del = ++max;
5234
5235         if (max > 0xffff)
5236             bits = 32;
5237         else if (max > 0xff)
5238             bits = 16;
5239         else
5240             bits = 8;
5241
5242         swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
5243 #ifdef USE_ITHREADS
5244         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
5245         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
5246         PAD_SETSV(cPADOPo->op_padix, swash);
5247         SvPADTMP_on(swash);
5248         SvREADONLY_on(swash);
5249 #else
5250         cSVOPo->op_sv = swash;
5251 #endif
5252         SvREFCNT_dec(listsv);
5253         SvREFCNT_dec(transv);
5254
5255         if (!del && havefinal && rlen)
5256             (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
5257                            newSVuv((UV)final), 0);
5258
5259         Safefree(tsave);
5260         Safefree(rsave);
5261
5262         tlen = tcount;
5263         rlen = rcount;
5264         if (r < rend)
5265             rlen++;
5266         else if (rlast == 0xffffffff)
5267             rlen = 0;
5268
5269         goto warnins;
5270     }
5271
5272     tbl = (short*)PerlMemShared_calloc(
5273         (o->op_private & OPpTRANS_COMPLEMENT) &&
5274             !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
5275         sizeof(short));
5276     cPVOPo->op_pv = (char*)tbl;
5277     if (complement) {
5278         for (i = 0; i < (I32)tlen; i++)
5279             tbl[t[i]] = -1;
5280         for (i = 0, j = 0; i < 256; i++) {
5281             if (!tbl[i]) {
5282                 if (j >= (I32)rlen) {
5283                     if (del)
5284                         tbl[i] = -2;
5285                     else if (rlen)
5286                         tbl[i] = r[j-1];
5287                     else
5288                         tbl[i] = (short)i;
5289                 }
5290                 else {
5291                     if (i < 128 && r[j] >= 128)
5292                         grows = 1;
5293                     tbl[i] = r[j++];
5294                 }
5295             }
5296         }
5297         if (!del) {
5298             if (!rlen) {
5299                 j = rlen;
5300                 if (!squash)
5301                     o->op_private |= OPpTRANS_IDENTICAL;
5302             }
5303             else if (j >= (I32)rlen)
5304                 j = rlen - 1;
5305             else {
5306                 tbl =
5307                     (short *)
5308                     PerlMemShared_realloc(tbl,
5309                                           (0x101+rlen-j) * sizeof(short));
5310                 cPVOPo->op_pv = (char*)tbl;
5311             }
5312             tbl[0x100] = (short)(rlen - j);
5313             for (i=0; i < (I32)rlen - j; i++)
5314                 tbl[0x101+i] = r[j+i];
5315         }
5316     }
5317     else {
5318         if (!rlen && !del) {
5319             r = t; rlen = tlen;
5320             if (!squash)
5321                 o->op_private |= OPpTRANS_IDENTICAL;
5322         }
5323         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
5324             o->op_private |= OPpTRANS_IDENTICAL;
5325         }
5326         for (i = 0; i < 256; i++)
5327             tbl[i] = -1;
5328         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
5329             if (j >= (I32)rlen) {
5330                 if (del) {
5331                     if (tbl[t[i]] == -1)
5332                         tbl[t[i]] = -2;
5333                     continue;
5334                 }
5335                 --j;
5336             }
5337             if (tbl[t[i]] == -1) {
5338                 if (t[i] < 128 && r[j] >= 128)
5339                     grows = 1;
5340                 tbl[t[i]] = r[j];
5341             }
5342         }
5343     }
5344
5345   warnins:
5346     if(del && rlen == tlen) {
5347         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
5348     } else if(rlen > tlen && !complement) {
5349         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
5350     }
5351
5352     if (grows)
5353         o->op_private |= OPpTRANS_GROWS;
5354     op_free(expr);
5355     op_free(repl);
5356
5357     return o;
5358 }
5359
5360 /*
5361 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
5362
5363 Constructs, checks, and returns an op of any pattern matching type.
5364 C<type> is the opcode.  C<flags> gives the eight bits of C<op_flags>
5365 and, shifted up eight bits, the eight bits of C<op_private>.
5366
5367 =cut
5368 */
5369
5370 OP *
5371 Perl_newPMOP(pTHX_ I32 type, I32 flags)
5372 {
5373     dVAR;
5374     PMOP *pmop;
5375
5376     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
5377         || type == OP_CUSTOM);
5378
5379     NewOp(1101, pmop, 1, PMOP);
5380     OpTYPE_set(pmop, type);
5381     pmop->op_flags = (U8)flags;
5382     pmop->op_private = (U8)(0 | (flags >> 8));
5383     if (PL_opargs[type] & OA_RETSCALAR)
5384         scalar((OP *)pmop);
5385
5386     if (PL_hints & HINT_RE_TAINT)
5387         pmop->op_pmflags |= PMf_RETAINT;
5388 #ifdef USE_LOCALE_CTYPE
5389     if (IN_LC_COMPILETIME(LC_CTYPE)) {
5390         set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
5391     }
5392     else
5393 #endif
5394          if (IN_UNI_8_BIT) {
5395         set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
5396     }
5397     if (PL_hints & HINT_RE_FLAGS) {
5398         SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5399          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
5400         );
5401         if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
5402         reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5403          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
5404         );
5405         if (reflags && SvOK(reflags)) {
5406             set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
5407         }
5408     }
5409
5410
5411 #ifdef USE_ITHREADS
5412     assert(SvPOK(PL_regex_pad[0]));
5413     if (SvCUR(PL_regex_pad[0])) {
5414         /* Pop off the "packed" IV from the end.  */
5415         SV *const repointer_list = PL_regex_pad[0];
5416         const char *p = SvEND(repointer_list) - sizeof(IV);
5417         const IV offset = *((IV*)p);
5418
5419         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
5420
5421         SvEND_set(repointer_list, p);
5422
5423         pmop->op_pmoffset = offset;
5424         /* This slot should be free, so assert this:  */
5425         assert(PL_regex_pad[offset] == &PL_sv_undef);
5426     } else {
5427         SV * const repointer = &PL_sv_undef;
5428         av_push(PL_regex_padav, repointer);
5429         pmop->op_pmoffset = av_tindex(PL_regex_padav);
5430         PL_regex_pad = AvARRAY(PL_regex_padav);
5431     }
5432 #endif
5433
5434     return CHECKOP(type, pmop);
5435 }
5436
5437 static void
5438 S_set_haseval(pTHX)
5439 {
5440     PADOFFSET i = 1;
5441     PL_cv_has_eval = 1;
5442     /* Any pad names in scope are potentially lvalues.  */
5443     for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
5444         PADNAME *pn = PAD_COMPNAME_SV(i);
5445         if (!pn || !PadnameLEN(pn))
5446             continue;
5447         if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
5448             S_mark_padname_lvalue(aTHX_ pn);
5449     }
5450 }
5451
5452 /* Given some sort of match op o, and an expression expr containing a
5453  * pattern, either compile expr into a regex and attach it to o (if it's
5454  * constant), or convert expr into a runtime regcomp op sequence (if it's
5455  * not)
5456  *
5457  * isreg indicates that the pattern is part of a regex construct, eg
5458  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
5459  * split "pattern", which aren't. In the former case, expr will be a list
5460  * if the pattern contains more than one term (eg /a$b/).
5461  *
5462  * When the pattern has been compiled within a new anon CV (for
5463  * qr/(?{...})/ ), then floor indicates the savestack level just before
5464  * the new sub was created
5465  */
5466
5467 OP *
5468 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, bool isreg, I32 floor)
5469 {
5470     PMOP *pm;
5471     LOGOP *rcop;
5472     I32 repl_has_vars = 0;
5473     bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
5474     bool is_compiletime;
5475     bool has_code;
5476
5477     PERL_ARGS_ASSERT_PMRUNTIME;
5478
5479     if (is_trans) {
5480         return pmtrans(o, expr, repl);
5481     }
5482
5483     /* find whether we have any runtime or code elements;
5484      * at the same time, temporarily set the op_next of each DO block;
5485      * then when we LINKLIST, this will cause the DO blocks to be excluded
5486      * from the op_next chain (and from having LINKLIST recursively
5487      * applied to them). We fix up the DOs specially later */
5488
5489     is_compiletime = 1;
5490     has_code = 0;
5491     if (expr->op_type == OP_LIST) {
5492         OP *o;
5493         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
5494             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
5495                 has_code = 1;
5496                 assert(!o->op_next);
5497                 if (UNLIKELY(!OpHAS_SIBLING(o))) {
5498                     assert(PL_parser && PL_parser->error_count);
5499                     /* This can happen with qr/ (?{(^{})/.  Just fake up
5500                        the op we were expecting to see, to avoid crashing
5501                        elsewhere.  */
5502                     op_sibling_splice(expr, o, 0,
5503                                       newSVOP(OP_CONST, 0, &PL_sv_no));
5504                 }
5505                 o->op_next = OpSIBLING(o);
5506             }
5507             else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
5508                 is_compiletime = 0;
5509         }
5510     }
5511     else if (expr->op_type != OP_CONST)
5512         is_compiletime = 0;
5513
5514     LINKLIST(expr);
5515
5516     /* fix up DO blocks; treat each one as a separate little sub;
5517      * also, mark any arrays as LIST/REF */
5518
5519     if (expr->op_type == OP_LIST) {
5520         OP *o;
5521         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
5522
5523             if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
5524                 assert( !(o->op_flags  & OPf_WANT));
5525                 /* push the array rather than its contents. The regex
5526                  * engine will retrieve and join the elements later */
5527                 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
5528                 continue;
5529             }
5530
5531             if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
5532                 continue;
5533             o->op_next = NULL; /* undo temporary hack from above */
5534             scalar(o);
5535             LINKLIST(o);
5536             if (cLISTOPo->op_first->op_type == OP_LEAVE) {
5537                 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
5538                 /* skip ENTER */
5539                 assert(leaveop->op_first->op_type == OP_ENTER);
5540                 assert(OpHAS_SIBLING(leaveop->op_first));
5541                 o->op_next = OpSIBLING(leaveop->op_first);
5542                 /* skip leave */
5543                 assert(leaveop->op_flags & OPf_KIDS);
5544                 assert(leaveop->op_last->op_next == (OP*)leaveop);
5545                 leaveop->op_next = NULL; /* stop on last op */
5546                 op_null((OP*)leaveop);
5547             }
5548             else {
5549                 /* skip SCOPE */
5550                 OP *scope = cLISTOPo->op_first;
5551                 assert(scope->op_type == OP_SCOPE);
5552                 assert(scope->op_flags & OPf_KIDS);
5553                 scope->op_next = NULL; /* stop on last op */
5554                 op_null(scope);
5555             }
5556             /* have to peep the DOs individually as we've removed it from
5557              * the op_next chain */
5558             CALL_PEEP(o);
5559             S_prune_chain_head(&(o->op_next));
5560             if (is_compiletime)
5561                 /* runtime finalizes as part of finalizing whole tree */
5562                 finalize_optree(o);
5563         }
5564     }
5565     else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
5566         assert( !(expr->op_flags  & OPf_WANT));
5567         /* push the array rather than its contents. The regex
5568          * engine will retrieve and join the elements later */
5569         expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
5570     }
5571
5572     PL_hints |= HINT_BLOCK_SCOPE;
5573     pm = (PMOP*)o;
5574     assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
5575
5576     if (is_compiletime) {
5577         U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
5578         regexp_engine const *eng = current_re_engine();
5579
5580         if (o->op_flags & OPf_SPECIAL)
5581             rx_flags |= RXf_SPLIT;
5582
5583         if (!has_code || !eng->op_comp) {
5584             /* compile-time simple constant pattern */
5585
5586             if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
5587                 /* whoops! we guessed that a qr// had a code block, but we
5588                  * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
5589                  * that isn't required now. Note that we have to be pretty
5590                  * confident that nothing used that CV's pad while the
5591                  * regex was parsed, except maybe op targets for \Q etc.
5592                  * If there were any op targets, though, they should have
5593                  * been stolen by constant folding.
5594                  */
5595 #ifdef DEBUGGING
5596                 SSize_t i = 0;
5597                 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
5598                 while (++i <= AvFILLp(PL_comppad)) {
5599                     assert(!PL_curpad[i]);
5600                 }
5601 #endif
5602                 /* But we know that one op is using this CV's slab. */
5603                 cv_forget_slab(PL_compcv);
5604                 LEAVE_SCOPE(floor);
5605                 pm->op_pmflags &= ~PMf_HAS_CV;
5606             }
5607
5608             PM_SETRE(pm,
5609                 eng->op_comp
5610                     ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5611                                         rx_flags, pm->op_pmflags)
5612                     : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5613                                         rx_flags, pm->op_pmflags)
5614             );
5615             op_free(expr);
5616         }
5617         else {
5618             /* compile-time pattern that includes literal code blocks */
5619             REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5620                         rx_flags,
5621                         (pm->op_pmflags |
5622                             ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
5623                     );
5624             PM_SETRE(pm, re);
5625             if (pm->op_pmflags & PMf_HAS_CV) {
5626                 CV *cv;
5627                 /* this QR op (and the anon sub we embed it in) is never
5628                  * actually executed. It's just a placeholder where we can
5629                  * squirrel away expr in op_code_list without the peephole
5630                  * optimiser etc processing it for a second time */
5631                 OP *qr = newPMOP(OP_QR, 0);
5632                 ((PMOP*)qr)->op_code_list = expr;
5633
5634                 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
5635                 SvREFCNT_inc_simple_void(PL_compcv);
5636                 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
5637                 ReANY(re)->qr_anoncv = cv;
5638
5639                 /* attach the anon CV to the pad so that
5640                  * pad_fixup_inner_anons() can find it */
5641                 (void)pad_add_anon(cv, o->op_type);
5642                 SvREFCNT_inc_simple_void(cv);
5643             }
5644             else {
5645                 pm->op_code_list = expr;
5646             }
5647         }
5648     }
5649     else {
5650         /* runtime pattern: build chain of regcomp etc ops */
5651         bool reglist;
5652         PADOFFSET cv_targ = 0;
5653
5654         reglist = isreg && expr->op_type == OP_LIST;
5655         if (reglist)
5656             op_null(expr);
5657
5658         if (has_code) {
5659             pm->op_code_list = expr;
5660             /* don't free op_code_list; its ops are embedded elsewhere too */
5661             pm->op_pmflags |= PMf_CODELIST_PRIVATE;
5662         }
5663
5664         if (o->op_flags & OPf_SPECIAL)
5665             pm->op_pmflags |= PMf_SPLIT;
5666
5667         /* the OP_REGCMAYBE is a placeholder in the non-threaded case
5668          * to allow its op_next to be pointed past the regcomp and
5669          * preceding stacking ops;
5670          * OP_REGCRESET is there to reset taint before executing the
5671          * stacking ops */
5672         if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
5673             expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
5674
5675         if (pm->op_pmflags & PMf_HAS_CV) {
5676             /* we have a runtime qr with literal code. This means
5677              * that the qr// has been wrapped in a new CV, which
5678              * means that runtime consts, vars etc will have been compiled
5679              * against a new pad. So... we need to execute those ops
5680              * within the environment of the new CV. So wrap them in a call
5681              * to a new anon sub. i.e. for
5682              *
5683              *     qr/a$b(?{...})/,
5684              *
5685              * we build an anon sub that looks like
5686              *
5687              *     sub { "a", $b, '(?{...})' }
5688              *
5689              * and call it, passing the returned list to regcomp.
5690              * Or to put it another way, the list of ops that get executed
5691              * are:
5692              *
5693              *     normal              PMf_HAS_CV
5694              *     ------              -------------------
5695              *                         pushmark (for regcomp)
5696              *                         pushmark (for entersub)
5697              *                         anoncode
5698              *                         srefgen
5699              *                         entersub
5700              *     regcreset                  regcreset
5701              *     pushmark                   pushmark
5702              *     const("a")                 const("a")
5703              *     gvsv(b)                    gvsv(b)
5704              *     const("(?{...})")          const("(?{...})")
5705              *                                leavesub
5706              *     regcomp             regcomp
5707              */
5708
5709             SvREFCNT_inc_simple_void(PL_compcv);
5710             CvLVALUE_on(PL_compcv);
5711             /* these lines are just an unrolled newANONATTRSUB */
5712             expr = newSVOP(OP_ANONCODE, 0,
5713                     MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
5714             cv_targ = expr->op_targ;
5715             expr = newUNOP(OP_REFGEN, 0, expr);
5716
5717             expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
5718         }
5719
5720         rcop = S_alloc_LOGOP(aTHX_ OP_REGCOMP, scalar(expr), o);
5721         rcop->op_flags |=  ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
5722                            | (reglist ? OPf_STACKED : 0);
5723         rcop->op_targ = cv_targ;
5724
5725         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
5726         if (PL_hints & HINT_RE_EVAL)
5727             S_set_haseval(aTHX);
5728
5729         /* establish postfix order */
5730         if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
5731             LINKLIST(expr);
5732             rcop->op_next = expr;
5733             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
5734         }
5735         else {
5736             rcop->op_next = LINKLIST(expr);
5737             expr->op_next = (OP*)rcop;
5738         }
5739
5740         op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
5741     }
5742
5743     if (repl) {
5744         OP *curop = repl;
5745         bool konst;
5746         /* If we are looking at s//.../e with a single statement, get past
5747            the implicit do{}. */
5748         if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
5749              && cUNOPx(curop)->op_first->op_type == OP_SCOPE
5750              && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
5751          {
5752             OP *sib;
5753             OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
5754             if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
5755              && !OpHAS_SIBLING(sib))
5756                 curop = sib;
5757         }
5758         if (curop->op_type == OP_CONST)
5759             konst = TRUE;
5760         else if (( (curop->op_type == OP_RV2SV ||
5761                     curop->op_type == OP_RV2AV ||
5762                     curop->op_type == OP_RV2HV ||
5763                     curop->op_type == OP_RV2GV)
5764                    && cUNOPx(curop)->op_first
5765                    && cUNOPx(curop)->op_first->op_type == OP_GV )
5766                 || curop->op_type == OP_PADSV
5767                 || curop->op_type == OP_PADAV
5768                 || curop->op_type == OP_PADHV
5769                 || curop->op_type == OP_PADANY) {
5770             repl_has_vars = 1;
5771             konst = TRUE;
5772         }
5773         else konst = FALSE;
5774         if (konst
5775             && !(repl_has_vars
5776                  && (!PM_GETRE(pm)
5777                      || !RX_PRELEN(PM_GETRE(pm))
5778                      || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
5779         {
5780             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
5781             op_prepend_elem(o->op_type, scalar(repl), o);
5782         }
5783         else {
5784             rcop = S_alloc_LOGOP(aTHX_ OP_SUBSTCONT, scalar(repl), o);
5785             rcop->op_private = 1;
5786
5787             /* establish postfix order */
5788             rcop->op_next = LINKLIST(repl);
5789             repl->op_next = (OP*)rcop;
5790
5791             pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
5792             assert(!(pm->op_pmflags & PMf_ONCE));
5793             pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
5794             rcop->op_next = 0;
5795         }
5796     }
5797
5798     return (OP*)pm;
5799 }
5800
5801 /*
5802 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
5803
5804 Constructs, checks, and returns an op of any type that involves an
5805 embedded SV.  C<type> is the opcode.  C<flags> gives the eight bits
5806 of C<op_flags>.  C<sv> gives the SV to embed in the op; this function
5807 takes ownership of one reference to it.
5808
5809 =cut
5810 */
5811
5812 OP *
5813 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
5814 {
5815     dVAR;
5816     SVOP *svop;
5817
5818     PERL_ARGS_ASSERT_NEWSVOP;
5819
5820     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5821         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5822         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5823         || type == OP_CUSTOM);
5824
5825     NewOp(1101, svop, 1, SVOP);
5826     OpTYPE_set(svop, type);
5827     svop->op_sv = sv;
5828     svop->op_next = (OP*)svop;
5829     svop->op_flags = (U8)flags;
5830     svop->op_private = (U8)(0 | (flags >> 8));
5831     if (PL_opargs[type] & OA_RETSCALAR)
5832         scalar((OP*)svop);
5833     if (PL_opargs[type] & OA_TARGET)
5834         svop->op_targ = pad_alloc(type, SVs_PADTMP);
5835     return CHECKOP(type, svop);
5836 }
5837
5838 /*
5839 =for apidoc Am|OP *|newDEFSVOP|
5840
5841 Constructs and returns an op to access C<$_>.
5842
5843 =cut
5844 */
5845
5846 OP *
5847 Perl_newDEFSVOP(pTHX)
5848 {
5849         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
5850 }
5851
5852 #ifdef USE_ITHREADS
5853
5854 /*
5855 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
5856
5857 Constructs, checks, and returns an op of any type that involves a
5858 reference to a pad element.  C<type> is the opcode.  C<flags> gives the
5859 eight bits of C<op_flags>.  A pad slot is automatically allocated, and
5860 is populated with C<sv>; this function takes ownership of one reference
5861 to it.
5862
5863 This function only exists if Perl has been compiled to use ithreads.
5864
5865 =cut
5866 */
5867
5868 OP *
5869 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
5870 {
5871     dVAR;
5872     PADOP *padop;
5873
5874     PERL_ARGS_ASSERT_NEWPADOP;
5875
5876     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5877         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5878         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5879         || type == OP_CUSTOM);
5880
5881     NewOp(1101, padop, 1, PADOP);
5882     OpTYPE_set(padop, type);
5883     padop->op_padix =
5884         pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
5885     SvREFCNT_dec(PAD_SVl(padop->op_padix));
5886     PAD_SETSV(padop->op_padix, sv);
5887     assert(sv);
5888     padop->op_next = (OP*)padop;
5889     padop->op_flags = (U8)flags;
5890     if (PL_opargs[type] & OA_RETSCALAR)
5891         scalar((OP*)padop);
5892     if (PL_opargs[type] & OA_TARGET)
5893         padop->op_targ = pad_alloc(type, SVs_PADTMP);
5894     return CHECKOP(type, padop);
5895 }
5896
5897 #endif /* USE_ITHREADS */
5898
5899 /*
5900 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
5901
5902 Constructs, checks, and returns an op of any type that involves an
5903 embedded reference to a GV.  C<type> is the opcode.  C<flags> gives the
5904 eight bits of C<op_flags>.  C<gv> identifies the GV that the op should
5905 reference; calling this function does not transfer ownership of any
5906 reference to it.
5907
5908 =cut
5909 */
5910
5911 OP *
5912 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
5913 {
5914     PERL_ARGS_ASSERT_NEWGVOP;
5915
5916 #ifdef USE_ITHREADS
5917     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5918 #else
5919     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5920 #endif
5921 }
5922
5923 /*
5924 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
5925
5926 Constructs, checks, and returns an op of any type that involves an
5927 embedded C-level pointer (PV).  C<type> is the opcode.  C<flags> gives
5928 the eight bits of C<op_flags>.  C<pv> supplies the C-level pointer, which
5929 must have been allocated using C<PerlMemShared_malloc>; the memory will
5930 be freed when the op is destroyed.
5931
5932 =cut
5933 */
5934
5935 OP *
5936 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
5937 {
5938     dVAR;
5939     const bool utf8 = cBOOL(flags & SVf_UTF8);
5940     PVOP *pvop;
5941
5942     flags &= ~SVf_UTF8;
5943
5944     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5945         || type == OP_RUNCV || type == OP_CUSTOM
5946         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5947
5948     NewOp(1101, pvop, 1, PVOP);
5949     OpTYPE_set(pvop, type);
5950     pvop->op_pv = pv;
5951     pvop->op_next = (OP*)pvop;
5952     pvop->op_flags = (U8)flags;
5953     pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
5954     if (PL_opargs[type] & OA_RETSCALAR)
5955         scalar((OP*)pvop);
5956     if (PL_opargs[type] & OA_TARGET)
5957         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
5958     return CHECKOP(type, pvop);
5959 }
5960
5961 void
5962 Perl_package(pTHX_ OP *o)
5963 {
5964     SV *const sv = cSVOPo->op_sv;
5965
5966     PERL_ARGS_ASSERT_PACKAGE;
5967
5968     SAVEGENERICSV(PL_curstash);
5969     save_item(PL_curstname);
5970
5971     PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
5972
5973     sv_setsv(PL_curstname, sv);
5974
5975     PL_hints |= HINT_BLOCK_SCOPE;
5976     PL_parser->copline = NOLINE;
5977
5978     op_free(o);
5979 }
5980
5981 void
5982 Perl_package_version( pTHX_ OP *v )
5983 {
5984     U32 savehints = PL_hints;
5985     PERL_ARGS_ASSERT_PACKAGE_VERSION;
5986     PL_hints &= ~HINT_STRICT_VARS;
5987     sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
5988     PL_hints = savehints;
5989     op_free(v);
5990 }
5991
5992 void
5993 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
5994 {
5995     OP *pack;
5996     OP *imop;
5997     OP *veop;
5998     SV *use_version = NULL;
5999
6000     PERL_ARGS_ASSERT_UTILIZE;
6001
6002     if (idop->op_type != OP_CONST)
6003         Perl_croak(aTHX_ "Module name must be constant");
6004
6005     veop = NULL;
6006
6007     if (version) {
6008         SV * const vesv = ((SVOP*)version)->op_sv;
6009
6010         if (!arg && !SvNIOKp(vesv)) {
6011             arg = version;
6012         }
6013         else {
6014             OP *pack;
6015             SV *meth;
6016
6017             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
6018                 Perl_croak(aTHX_ "Version number must be a constant number");
6019
6020             /* Make copy of idop so we don't free it twice */
6021             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
6022
6023             /* Fake up a method call to VERSION */
6024             meth = newSVpvs_share("VERSION");
6025             veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
6026                             op_append_elem(OP_LIST,
6027                                         op_prepend_elem(OP_LIST, pack, version),
6028                                         newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
6029         }
6030     }
6031
6032     /* Fake up an import/unimport */
6033     if (arg && arg->op_type == OP_STUB) {
6034         imop = arg;             /* no import on explicit () */
6035     }
6036     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
6037         imop = NULL;            /* use 5.0; */
6038         if (aver)
6039             use_version = ((SVOP*)idop)->op_sv;
6040         else
6041             idop->op_private |= OPpCONST_NOVER;
6042     }
6043     else {
6044         SV *meth;
6045
6046         /* Make copy of idop so we don't free it twice */
6047         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
6048
6049         /* Fake up a method call to import/unimport */
6050         meth = aver
6051             ? newSVpvs_share("import") : newSVpvs_share("unimport");
6052         imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
6053                        op_append_elem(OP_LIST,
6054                                    op_prepend_elem(OP_LIST, pack, arg),
6055                                    newMETHOP_named(OP_METHOD_NAMED, 0, meth)
6056                        ));
6057     }
6058
6059     /* Fake up the BEGIN {}, which does its thing immediately. */
6060     newATTRSUB(floor,
6061         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
6062         NULL,
6063         NULL,
6064         op_append_elem(OP_LINESEQ,
6065             op_append_elem(OP_LINESEQ,
6066                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
6067                 newSTATEOP(0, NULL, veop)),
6068             newSTATEOP(0, NULL, imop) ));
6069
6070     if (use_version) {
6071         /* Enable the
6072          * feature bundle that corresponds to the required version. */
6073         use_version = sv_2mortal(new_version(use_version));
6074         S_enable_feature_bundle(aTHX_ use_version);
6075
6076         /* If a version >= 5.11.0 is requested, strictures are on by default! */
6077         if (vcmp(use_version,
6078                  sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
6079             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
6080                 PL_hints |= HINT_STRICT_REFS;
6081             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
6082                 PL_hints |= HINT_STRICT_SUBS;
6083             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
6084                 PL_hints |= HINT_STRICT_VARS;
6085         }
6086         /* otherwise they are off */
6087         else {
6088             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
6089                 PL_hints &= ~HINT_STRICT_REFS;
6090             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
6091                 PL_hints &= ~HINT_STRICT_SUBS;
6092             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
6093                 PL_hints &= ~HINT_STRICT_VARS;
6094         }
6095     }
6096
6097     /* The "did you use incorrect case?" warning used to be here.
6098      * The problem is that on case-insensitive filesystems one
6099      * might get false positives for "use" (and "require"):
6100      * "use Strict" or "require CARP" will work.  This causes
6101      * portability problems for the script: in case-strict
6102      * filesystems the script will stop working.
6103      *
6104      * The "incorrect case" warning checked whether "use Foo"
6105      * imported "Foo" to your namespace, but that is wrong, too:
6106      * there is no requirement nor promise in the language that
6107      * a Foo.pm should or would contain anything in package "Foo".
6108      *
6109      * There is very little Configure-wise that can be done, either:
6110      * the case-sensitivity of the build filesystem of Perl does not
6111      * help in guessing the case-sensitivity of the runtime environment.
6112      */
6113
6114     PL_hints |= HINT_BLOCK_SCOPE;
6115     PL_parser->copline = NOLINE;
6116     COP_SEQMAX_INC; /* Purely for B::*'s benefit */
6117 }
6118
6119 /*
6120 =head1 Embedding Functions
6121
6122 =for apidoc load_module
6123
6124 Loads the module whose name is pointed to by the string part of name.
6125 Note that the actual module name, not its filename, should be given.
6126 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
6127 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
6128 (or 0 for no flags).  ver, if specified
6129 and not NULL, provides version semantics
6130 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
6131 arguments can be used to specify arguments to the module's C<import()>
6132 method, similar to C<use Foo::Bar VERSION LIST>.  They must be
6133 terminated with a final C<NULL> pointer.  Note that this list can only
6134 be omitted when the C<PERL_LOADMOD_NOIMPORT> flag has been used.
6135 Otherwise at least a single C<NULL> pointer to designate the default
6136 import list is required.
6137
6138 The reference count for each specified C<SV*> parameter is decremented.
6139
6140 =cut */
6141
6142 void
6143 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
6144 {
6145     va_list args;
6146
6147     PERL_ARGS_ASSERT_LOAD_MODULE;
6148
6149     va_start(args, ver);
6150     vload_module(flags, name, ver, &args);
6151     va_end(args);
6152 }
6153
6154 #ifdef PERL_IMPLICIT_CONTEXT
6155 void
6156 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
6157 {
6158     dTHX;
6159     va_list args;
6160     PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
6161     va_start(args, ver);
6162     vload_module(flags, name, ver, &args);
6163     va_end(args);
6164 }
6165 #endif
6166
6167 void
6168 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
6169 {
6170     OP *veop, *imop;
6171     OP * const modname = newSVOP(OP_CONST, 0, name);
6172
6173     PERL_ARGS_ASSERT_VLOAD_MODULE;
6174
6175     modname->op_private |= OPpCONST_BARE;
6176     if (ver) {
6177         veop = newSVOP(OP_CONST, 0, ver);
6178     }
6179     else
6180         veop = NULL;
6181     if (flags & PERL_LOADMOD_NOIMPORT) {
6182         imop = sawparens(newNULLLIST());
6183     }
6184     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
6185         imop = va_arg(*args, OP*);
6186     }
6187     else {
6188         SV *sv;
6189         imop = NULL;
6190         sv = va_arg(*args, SV*);
6191         while (sv) {
6192             imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
6193             sv = va_arg(*args, SV*);
6194         }
6195     }
6196
6197     /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
6198      * that it has a PL_parser to play with while doing that, and also
6199      * that it doesn't mess with any existing parser, by creating a tmp
6200      * new parser with lex_start(). This won't actually be used for much,
6201      * since pp_require() will create another parser for the real work.
6202      * The ENTER/LEAVE pair protect callers from any side effects of use.  */
6203
6204     ENTER;
6205     SAVEVPTR(PL_curcop);
6206     lex_start(NULL, NULL, LEX_START_SAME_FILTER);
6207     utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
6208             veop, modname, imop);
6209     LEAVE;
6210 }
6211
6212 PERL_STATIC_INLINE OP *
6213 S_new_entersubop(pTHX_ GV *gv, OP *arg)
6214 {
6215     return newUNOP(OP_ENTERSUB, OPf_STACKED,
6216                    newLISTOP(OP_LIST, 0, arg,
6217                              newUNOP(OP_RV2CV, 0,
6218                                      newGVOP(OP_GV, 0, gv))));
6219 }
6220
6221 OP *
6222 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
6223 {
6224     OP *doop;
6225     GV *gv;
6226
6227     PERL_ARGS_ASSERT_DOFILE;
6228
6229     if (!force_builtin && (gv = gv_override("do", 2))) {
6230         doop = S_new_entersubop(aTHX_ gv, term);
6231     }
6232     else {
6233         doop = newUNOP(OP_DOFILE, 0, scalar(term));
6234     }
6235     return doop;
6236 }
6237
6238 /*
6239 =head1 Optree construction
6240
6241 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
6242
6243 Constructs, checks, and returns an C<lslice> (list slice) op.  C<flags>
6244 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
6245 be set automatically, and, shifted up eight bits, the eight bits of
6246 C<op_private>, except that the bit with value 1 or 2 is automatically
6247 set as required.  C<listval> and C<subscript> supply the parameters of
6248 the slice; they are consumed by this function and become part of the
6249 constructed op tree.
6250
6251 =cut
6252 */
6253
6254 OP *
6255 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
6256 {
6257     return newBINOP(OP_LSLICE, flags,
6258             list(force_list(subscript, 1)),
6259             list(force_list(listval,   1)) );
6260 }
6261
6262 #define ASSIGN_LIST   1
6263 #define ASSIGN_REF    2
6264
6265 STATIC I32
6266 S_assignment_type(pTHX_ const OP *o)
6267 {
6268     unsigned type;
6269     U8 flags;
6270     U8 ret;
6271
6272     if (!o)
6273         return TRUE;
6274
6275     if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
6276         o = cUNOPo->op_first;
6277
6278     flags = o->op_flags;
6279     type = o->op_type;
6280     if (type == OP_COND_EXPR) {
6281         OP * const sib = OpSIBLING(cLOGOPo->op_first);
6282         const I32 t = assignment_type(sib);
6283         const I32 f = assignment_type(OpSIBLING(sib));
6284
6285         if (t == ASSIGN_LIST && f == ASSIGN_LIST)
6286             return ASSIGN_LIST;
6287         if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
6288             yyerror("Assignment to both a list and a scalar");
6289         return FALSE;
6290     }
6291
6292     if (type == OP_SREFGEN)
6293     {
6294         OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
6295         type = kid->op_type;
6296         flags |= kid->op_flags;
6297         if (!(flags & OPf_PARENS)
6298           && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
6299               kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
6300             return ASSIGN_REF;
6301         ret = ASSIGN_REF;
6302     }
6303     else ret = 0;
6304
6305     if (type == OP_LIST &&
6306         (flags & OPf_WANT) == OPf_WANT_SCALAR &&
6307         o->op_private & OPpLVAL_INTRO)
6308         return ret;
6309
6310     if (type == OP_LIST || flags & OPf_PARENS ||
6311         type == OP_RV2AV || type == OP_RV2HV ||
6312         type == OP_ASLICE || type == OP_HSLICE ||
6313         type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
6314         return TRUE;
6315
6316     if (type == OP_PADAV || type == OP_PADHV)
6317         return TRUE;
6318
6319     if (type == OP_RV2SV)
6320         return ret;
6321
6322     return ret;
6323 }
6324
6325
6326 /*
6327 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
6328
6329 Constructs, checks, and returns an assignment op.  C<left> and C<right>
6330 supply the parameters of the assignment; they are consumed by this
6331 function and become part of the constructed op tree.
6332
6333 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
6334 a suitable conditional optree is constructed.  If C<optype> is the opcode
6335 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
6336 performs the binary operation and assigns the result to the left argument.
6337 Either way, if C<optype> is non-zero then C<flags> has no effect.
6338
6339 If C<optype> is zero, then a plain scalar or list assignment is
6340 constructed.  Which type of assignment it is is automatically determined.
6341 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6342 will be set automatically, and, shifted up eight bits, the eight bits
6343 of C<op_private>, except that the bit with value 1 or 2 is automatically
6344 set as required.
6345
6346 =cut
6347 */
6348
6349 OP *
6350 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
6351 {
6352     OP *o;
6353     I32 assign_type;
6354
6355     if (optype) {
6356         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
6357             return newLOGOP(optype, 0,
6358                 op_lvalue(scalar(left), optype),
6359                 newUNOP(OP_SASSIGN, 0, scalar(right)));
6360         }
6361         else {
6362             return newBINOP(optype, OPf_STACKED,
6363                 op_lvalue(scalar(left), optype), scalar(right));
6364         }
6365     }
6366
6367     if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
6368         static const char no_list_state[] = "Initialization of state variables"
6369             " in list context currently forbidden";
6370         OP *curop;
6371
6372         if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
6373             left->op_private &= ~ OPpSLICEWARNING;
6374
6375         PL_modcount = 0;
6376         left = op_lvalue(left, OP_AASSIGN);
6377         curop = list(force_list(left, 1));
6378         o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
6379         o->op_private = (U8)(0 | (flags >> 8));
6380
6381         if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
6382         {
6383             OP* lop = ((LISTOP*)left)->op_first;
6384             while (lop) {
6385                 if ((lop->op_type == OP_PADSV ||
6386                      lop->op_type == OP_PADAV ||
6387                      lop->op_type == OP_PADHV ||
6388                      lop->op_type == OP_PADANY)
6389                   && (lop->op_private & OPpPAD_STATE)
6390                 )
6391                     yyerror(no_list_state);
6392                 lop = OpSIBLING(lop);
6393             }
6394         }
6395         else if (  (left->op_private & OPpLVAL_INTRO)
6396                 && (left->op_private & OPpPAD_STATE)
6397                 && (   left->op_type == OP_PADSV
6398                     || left->op_type == OP_PADAV
6399                     || left->op_type == OP_PADHV
6400                     || left->op_type == OP_PADANY)
6401         ) {
6402                 /* All single variable list context state assignments, hence
6403                    state ($a) = ...
6404                    (state $a) = ...
6405                    state @a = ...
6406                    state (@a) = ...
6407                    (state @a) = ...
6408                    state %a = ...
6409                    state (%a) = ...
6410                    (state %a) = ...
6411                 */
6412                 yyerror(no_list_state);
6413         }
6414
6415         if (right && right->op_type == OP_SPLIT
6416          && !(right->op_flags & OPf_STACKED)) {
6417             OP* tmpop = ((LISTOP*)right)->op_first;
6418             PMOP * const pm = (PMOP*)tmpop;
6419             assert (tmpop && (tmpop->op_type == OP_PUSHRE));
6420             if (
6421 #ifdef USE_ITHREADS
6422                     !pm->op_pmreplrootu.op_pmtargetoff
6423 #else
6424                     !pm->op_pmreplrootu.op_pmtargetgv
6425 #endif
6426                  && !pm->op_targ
6427                 ) {
6428                     if (!(left->op_private & OPpLVAL_INTRO) &&
6429                         ( (left->op_type == OP_RV2AV &&
6430                           (tmpop=((UNOP*)left)->op_first)->op_type==OP_GV)
6431                         || left->op_type == OP_PADAV )
6432                         ) {
6433                         if (tmpop != (OP *)pm) {
6434 #ifdef USE_ITHREADS
6435                           pm->op_pmreplrootu.op_pmtargetoff
6436                             = cPADOPx(tmpop)->op_padix;
6437                           cPADOPx(tmpop)->op_padix = 0; /* steal it */
6438 #else
6439                           pm->op_pmreplrootu.op_pmtargetgv
6440                             = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
6441                           cSVOPx(tmpop)->op_sv = NULL;  /* steal it */
6442 #endif
6443                           right->op_private |=
6444                             left->op_private & OPpOUR_INTRO;
6445                         }
6446                         else {
6447                             pm->op_targ = left->op_targ;
6448                             left->op_targ = 0; /* filch it */
6449                         }
6450                       detach_split:
6451                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
6452                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
6453                         /* detach rest of siblings from o subtree,
6454                          * and free subtree */
6455                         op_sibling_splice(cUNOPo->op_first, tmpop, -1, NULL);
6456                         op_free(o);                     /* blow off assign */
6457                         right->op_flags &= ~OPf_WANT;
6458                                 /* "I don't know and I don't care." */
6459                         return right;
6460                     }
6461                     else if (left->op_type == OP_RV2AV
6462                           || left->op_type == OP_PADAV)
6463                     {
6464                         /* Detach the array.  */
6465 #ifdef DEBUGGING
6466                         OP * const ary =
6467 #endif
6468                         op_sibling_splice(cBINOPo->op_last,
6469                                           cUNOPx(cBINOPo->op_last)
6470                                                 ->op_first, 1, NULL);
6471                         assert(ary == left);
6472                         /* Attach it to the split.  */
6473                         op_sibling_splice(right, cLISTOPx(right)->op_last,
6474                                           0, left);
6475                         right->op_flags |= OPf_STACKED;
6476                         /* Detach split and expunge aassign as above.  */
6477                         goto detach_split;
6478                     }
6479                     else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
6480                             ((LISTOP*)right)->op_last->op_type == OP_CONST)
6481                     {
6482                         SV ** const svp =
6483                             &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
6484                         SV * const sv = *svp;
6485                         if (SvIOK(sv) && SvIVX(sv) == 0)
6486                         {
6487                           if (right->op_private & OPpSPLIT_IMPLIM) {
6488                             /* our own SV, created in ck_split */
6489                             SvREADONLY_off(sv);
6490                             sv_setiv(sv, PL_modcount+1);
6491                           }
6492                           else {
6493                             /* SV may belong to someone else */
6494                             SvREFCNT_dec(sv);
6495                             *svp = newSViv(PL_modcount+1);
6496                           }
6497                         }
6498                     }
6499             }
6500         }
6501         return o;
6502     }
6503     if (assign_type == ASSIGN_REF)
6504         return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
6505     if (!right)
6506         right = newOP(OP_UNDEF, 0);
6507     if (right->op_type == OP_READLINE) {
6508         right->op_flags |= OPf_STACKED;
6509         return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
6510                 scalar(right));
6511     }
6512     else {
6513         o = newBINOP(OP_SASSIGN, flags,
6514             scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
6515     }
6516     return o;
6517 }
6518
6519 /*
6520 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
6521
6522 Constructs a state op (COP).  The state op is normally a C<nextstate> op,
6523 but will be a C<dbstate> op if debugging is enabled for currently-compiled
6524 code.  The state op is populated from C<PL_curcop> (or C<PL_compiling>).
6525 If C<label> is non-null, it supplies the name of a label to attach to
6526 the state op; this function takes ownership of the memory pointed at by
6527 C<label>, and will free it.  C<flags> gives the eight bits of C<op_flags>
6528 for the state op.
6529
6530 If C<o> is null, the state op is returned.  Otherwise the state op is
6531 combined with C<o> into a C<lineseq> list op, which is returned.  C<o>
6532 is consumed by this function and becomes part of the returned op tree.
6533
6534 =cut
6535 */
6536
6537 OP *
6538 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
6539 {
6540     dVAR;
6541     const U32 seq = intro_my();
6542     const U32 utf8 = flags & SVf_UTF8;
6543     COP *cop;
6544
6545     PL_parser->parsed_sub = 0;
6546
6547     flags &= ~SVf_UTF8;
6548
6549     NewOp(1101, cop, 1, COP);
6550     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
6551         OpTYPE_set(cop, OP_DBSTATE);
6552     }
6553     else {
6554         OpTYPE_set(cop, OP_NEXTSTATE);
6555     }
6556     cop->op_flags = (U8)flags;
6557     CopHINTS_set(cop, PL_hints);
6558 #ifdef VMS
6559     if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
6560 #endif
6561     cop->op_next = (OP*)cop;
6562
6563     cop->cop_seq = seq;
6564     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
6565     CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
6566     if (label) {
6567         Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
6568
6569         PL_hints |= HINT_BLOCK_SCOPE;
6570         /* It seems that we need to defer freeing this pointer, as other parts
6571            of the grammar end up wanting to copy it after this op has been
6572            created. */
6573         SAVEFREEPV(label);
6574     }
6575
6576     if (PL_parser->preambling != NOLINE) {
6577         CopLINE_set(cop, PL_parser->preambling);
6578         PL_parser->copline = NOLINE;
6579     }
6580     else if (PL_parser->copline == NOLINE)
6581         CopLINE_set(cop, CopLINE(PL_curcop));
6582     else {
6583         CopLINE_set(cop, PL_parser->copline);
6584         PL_parser->copline = NOLINE;
6585     }
6586 #ifdef USE_ITHREADS
6587     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
6588 #else
6589     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
6590 #endif
6591     CopSTASH_set(cop, PL_curstash);
6592
6593     if (cop->op_type == OP_DBSTATE) {
6594         /* this line can have a breakpoint - store the cop in IV */
6595         AV *av = CopFILEAVx(PL_curcop);
6596         if (av) {
6597             SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
6598             if (svp && *svp != &PL_sv_undef ) {
6599                 (void)SvIOK_on(*svp);
6600                 SvIV_set(*svp, PTR2IV(cop));
6601             }
6602         }
6603     }
6604
6605     if (flags & OPf_SPECIAL)
6606         op_null((OP*)cop);
6607     return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
6608 }
6609
6610 /*
6611 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
6612
6613 Constructs, checks, and returns a logical (flow control) op.  C<type>
6614 is the opcode.  C<flags> gives the eight bits of C<op_flags>, except
6615 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6616 the eight bits of C<op_private>, except that the bit with value 1 is
6617 automatically set.  C<first> supplies the expression controlling the
6618 flow, and C<other> supplies the side (alternate) chain of ops; they are
6619 consumed by this function and become part of the constructed op tree.
6620
6621 =cut
6622 */
6623
6624 OP *
6625 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
6626 {
6627     PERL_ARGS_ASSERT_NEWLOGOP;
6628
6629     return new_logop(type, flags, &first, &other);
6630 }
6631
6632 STATIC OP *
6633 S_search_const(pTHX_ OP *o)
6634 {
6635     PERL_ARGS_ASSERT_SEARCH_CONST;
6636
6637     switch (o->op_type) {
6638         case OP_CONST:
6639             return o;
6640         case OP_NULL:
6641             if (o->op_flags & OPf_KIDS)
6642                 return search_const(cUNOPo->op_first);
6643             break;
6644         case OP_LEAVE:
6645         case OP_SCOPE:
6646         case OP_LINESEQ:
6647         {
6648             OP *kid;
6649             if (!(o->op_flags & OPf_KIDS))
6650                 return NULL;
6651             kid = cLISTOPo->op_first;
6652             do {
6653                 switch (kid->op_type) {
6654                     case OP_ENTER:
6655                     case OP_NULL:
6656                     case OP_NEXTSTATE:
6657                         kid = OpSIBLING(kid);
6658                         break;
6659                     default:
6660                         if (kid != cLISTOPo->op_last)
6661                             return NULL;
6662                         goto last;
6663                 }
6664             } while (kid);
6665             if (!kid)
6666                 kid = cLISTOPo->op_last;
6667           last:
6668             return search_const(kid);
6669         }
6670     }
6671
6672     return NULL;
6673 }
6674
6675 STATIC OP *
6676 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
6677 {
6678     dVAR;
6679     LOGOP *logop;
6680     OP *o;
6681     OP *first;
6682     OP *other;
6683     OP *cstop = NULL;
6684     int prepend_not = 0;
6685
6686     PERL_ARGS_ASSERT_NEW_LOGOP;
6687
6688     first = *firstp;
6689     other = *otherp;
6690
6691     /* [perl #59802]: Warn about things like "return $a or $b", which
6692        is parsed as "(return $a) or $b" rather than "return ($a or
6693        $b)".  NB: This also applies to xor, which is why we do it
6694        here.
6695      */
6696     switch (first->op_type) {
6697     case OP_NEXT:
6698     case OP_LAST:
6699     case OP_REDO:
6700         /* XXX: Perhaps we should emit a stronger warning for these.
6701            Even with the high-precedence operator they don't seem to do
6702            anything sensible.
6703
6704            But until we do, fall through here.
6705          */
6706     case OP_RETURN:
6707     case OP_EXIT:
6708     case OP_DIE:
6709     case OP_GOTO:
6710         /* XXX: Currently we allow people to "shoot themselves in the
6711            foot" by explicitly writing "(return $a) or $b".
6712
6713            Warn unless we are looking at the result from folding or if
6714            the programmer explicitly grouped the operators like this.
6715            The former can occur with e.g.
6716
6717                 use constant FEATURE => ( $] >= ... );
6718                 sub { not FEATURE and return or do_stuff(); }
6719          */
6720         if (!first->op_folded && !(first->op_flags & OPf_PARENS))
6721             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6722                            "Possible precedence issue with control flow operator");
6723         /* XXX: Should we optimze this to "return $a;" (i.e. remove
6724            the "or $b" part)?
6725         */
6726         break;
6727     }
6728
6729     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
6730         return newBINOP(type, flags, scalar(first), scalar(other));
6731
6732     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
6733         || type == OP_CUSTOM);
6734
6735     scalarboolean(first);
6736     /* optimize AND and OR ops that have NOTs as children */
6737     if (first->op_type == OP_NOT
6738         && (first->op_flags & OPf_KIDS)
6739         && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
6740             || (other->op_type == OP_NOT))  /* if (!$x && !$y) { } */
6741         ) {
6742         if (type == OP_AND || type == OP_OR) {
6743             if (type == OP_AND)
6744                 type = OP_OR;
6745             else
6746                 type = OP_AND;
6747             op_null(first);
6748             if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
6749                 op_null(other);
6750                 prepend_not = 1; /* prepend a NOT op later */
6751             }
6752         }
6753     }
6754     /* search for a constant op that could let us fold the test */
6755     if ((cstop = search_const(first))) {
6756         if (cstop->op_private & OPpCONST_STRICT)
6757             no_bareword_allowed(cstop);
6758         else if ((cstop->op_private & OPpCONST_BARE))
6759                 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
6760         if ((type == OP_AND &&  SvTRUE(((SVOP*)cstop)->op_sv)) ||
6761             (type == OP_OR  && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
6762             (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
6763             *firstp = NULL;
6764             if (other->op_type == OP_CONST)
6765                 other->op_private |= OPpCONST_SHORTCIRCUIT;
6766             op_free(first);
6767             if (other->op_type == OP_LEAVE)
6768                 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
6769             else if (other->op_type == OP_MATCH
6770                   || other->op_type == OP_SUBST
6771                   || other->op_type == OP_TRANSR
6772                   || other->op_type == OP_TRANS)
6773                 /* Mark the op as being unbindable with =~ */
6774                 other->op_flags |= OPf_SPECIAL;
6775
6776             other->op_folded = 1;
6777             return other;
6778         }
6779         else {
6780             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
6781             const OP *o2 = other;
6782             if ( ! (o2->op_type == OP_LIST
6783                     && (( o2 = cUNOPx(o2)->op_first))
6784                     && o2->op_type == OP_PUSHMARK
6785                     && (( o2 = OpSIBLING(o2))) )
6786             )
6787                 o2 = other;
6788             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
6789                         || o2->op_type == OP_PADHV)
6790                 && o2->op_private & OPpLVAL_INTRO
6791                 && !(o2->op_private & OPpPAD_STATE))
6792             {
6793                 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6794                                  "Deprecated use of my() in false conditional");
6795             }
6796
6797             *otherp = NULL;
6798             if (cstop->op_type == OP_CONST)
6799                 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
6800                 op_free(other);
6801             return first;
6802         }
6803     }
6804     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
6805         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
6806     {
6807         const OP * const k1 = ((UNOP*)first)->op_first;
6808         const OP * const k2 = OpSIBLING(k1);
6809         OPCODE warnop = 0;
6810         switch (first->op_type)
6811         {
6812         case OP_NULL:
6813             if (k2 && k2->op_type == OP_READLINE
6814                   && (k2->op_flags & OPf_STACKED)
6815                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6816             {
6817                 warnop = k2->op_type;
6818             }
6819             break;
6820
6821         case OP_SASSIGN:
6822             if (k1->op_type == OP_READDIR
6823                   || k1->op_type == OP_GLOB
6824                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6825                  || k1->op_type == OP_EACH
6826                  || k1->op_type == OP_AEACH)
6827             {
6828                 warnop = ((k1->op_type == OP_NULL)
6829                           ? (OPCODE)k1->op_targ : k1->op_type);
6830             }
6831             break;
6832         }
6833         if (warnop) {
6834             const line_t oldline = CopLINE(PL_curcop);
6835             /* This ensures that warnings are reported at the first line
6836                of the construction, not the last.  */
6837             CopLINE_set(PL_curcop, PL_parser->copline);
6838             Perl_warner(aTHX_ packWARN(WARN_MISC),
6839                  "Value of %s%s can be \"0\"; test with defined()",
6840                  PL_op_desc[warnop],
6841                  ((warnop == OP_READLINE || warnop == OP_GLOB)
6842                   ? " construct" : "() operator"));
6843             CopLINE_set(PL_curcop, oldline);
6844         }
6845     }
6846
6847     if (!other)
6848         return first;
6849
6850     if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
6851         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
6852
6853     logop = S_alloc_LOGOP(aTHX_ type, first, LINKLIST(other));
6854     logop->op_flags |= (U8)flags;
6855     logop->op_private = (U8)(1 | (flags >> 8));
6856
6857     /* establish postfix order */
6858     logop->op_next = LINKLIST(first);
6859     first->op_next = (OP*)logop;
6860     assert(!OpHAS_SIBLING(first));
6861     op_sibling_splice((OP*)logop, first, 0, other);
6862
6863     CHECKOP(type,logop);
6864
6865     o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
6866                 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
6867                 (OP*)logop);
6868     other->op_next = o;
6869
6870     return o;
6871 }
6872
6873 /*
6874 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
6875
6876 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
6877 op.  C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6878 will be set automatically, and, shifted up eight bits, the eight bits of
6879 C<op_private>, except that the bit with value 1 is automatically set.
6880 C<first> supplies the expression selecting between the two branches,
6881 and C<trueop> and C<falseop> supply the branches; they are consumed by
6882 this function and become part of the constructed op tree.
6883
6884 =cut
6885 */
6886
6887 OP *
6888 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
6889 {
6890     dVAR;
6891     LOGOP *logop;
6892     OP *start;
6893     OP *o;
6894     OP *cstop;
6895
6896     PERL_ARGS_ASSERT_NEWCONDOP;
6897
6898     if (!falseop)
6899         return newLOGOP(OP_AND, 0, first, trueop);
6900     if (!trueop)
6901         return newLOGOP(OP_OR, 0, first, falseop);
6902
6903     scalarboolean(first);
6904     if ((cstop = search_const(first))) {
6905         /* Left or right arm of the conditional?  */
6906         const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
6907         OP *live = left ? trueop : falseop;
6908         OP *const dead = left ? falseop : trueop;
6909         if (cstop->op_private & OPpCONST_BARE &&
6910             cstop->op_private & OPpCONST_STRICT) {
6911             no_bareword_allowed(cstop);
6912         }
6913         op_free(first);
6914         op_free(dead);
6915         if (live->op_type == OP_LEAVE)
6916             live = newUNOP(OP_NULL, OPf_SPECIAL, live);
6917         else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
6918               || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
6919             /* Mark the op as being unbindable with =~ */
6920             live->op_flags |= OPf_SPECIAL;
6921         live->op_folded = 1;
6922         return live;
6923     }
6924     logop = S_alloc_LOGOP(aTHX_ OP_COND_EXPR, first, LINKLIST(trueop));
6925     logop->op_flags |= (U8)flags;
6926     logop->op_private = (U8)(1 | (flags >> 8));
6927     logop->op_next = LINKLIST(falseop);
6928
6929     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
6930             logop);
6931
6932     /* establish postfix order */
6933     start = LINKLIST(first);
6934     first->op_next = (OP*)logop;
6935
6936     /* make first, trueop, falseop siblings */
6937     op_sibling_splice((OP*)logop, first,  0, trueop);
6938     op_sibling_splice((OP*)logop, trueop, 0, falseop);
6939
6940     o = newUNOP(OP_NULL, 0, (OP*)logop);
6941
6942     trueop->op_next = falseop->op_next = o;
6943
6944     o->op_next = start;
6945     return o;
6946 }
6947
6948 /*
6949 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
6950
6951 Constructs and returns a C<range> op, with subordinate C<flip> and
6952 C<flop> ops.  C<flags> gives the eight bits of C<op_flags> for the
6953 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
6954 for both the C<flip> and C<range> ops, except that the bit with value
6955 1 is automatically set.  C<left> and C<right> supply the expressions
6956 controlling the endpoints of the range; they are consumed by this function
6957 and become part of the constructed op tree.
6958
6959 =cut
6960 */
6961
6962 OP *
6963 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
6964 {
6965     LOGOP *range;
6966     OP *flip;
6967     OP *flop;
6968     OP *leftstart;
6969     OP *o;
6970
6971     PERL_ARGS_ASSERT_NEWRANGE;
6972
6973     range = S_alloc_LOGOP(aTHX_ OP_RANGE, left, LINKLIST(right));
6974     range->op_flags = OPf_KIDS;
6975     leftstart = LINKLIST(left);
6976     range->op_private = (U8)(1 | (flags >> 8));
6977
6978     /* make left and right siblings */
6979     op_sibling_splice((OP*)range, left, 0, right);
6980
6981     range->op_next = (OP*)range;
6982     flip = newUNOP(OP_FLIP, flags, (OP*)range);
6983     flop = newUNOP(OP_FLOP, 0, flip);
6984     o = newUNOP(OP_NULL, 0, flop);
6985     LINKLIST(flop);
6986     range->op_next = leftstart;
6987
6988     left->op_next = flip;
6989     right->op_next = flop;
6990
6991     range->op_targ =
6992         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
6993     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
6994     flip->op_targ =
6995         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
6996     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
6997     SvPADTMP_on(PAD_SV(flip->op_targ));
6998
6999     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
7000     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
7001
7002     /* check barewords before they might be optimized aways */
7003     if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
7004         no_bareword_allowed(left);
7005     if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
7006         no_bareword_allowed(right);
7007
7008     flip->op_next = o;
7009     if (!flip->op_private || !flop->op_private)
7010         LINKLIST(o);            /* blow off optimizer unless constant */
7011
7012     return o;
7013 }
7014
7015 /*
7016 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
7017
7018 Constructs, checks, and returns an op tree expressing a loop.  This is
7019 only a loop in the control flow through the op tree; it does not have
7020 the heavyweight loop structure that allows exiting the loop by C<last>
7021 and suchlike.  C<flags> gives the eight bits of C<op_flags> for the
7022 top-level op, except that some bits will be set automatically as required.
7023 C<expr> supplies the expression controlling loop iteration, and C<block>
7024 supplies the body of the loop; they are consumed by this function and
7025 become part of the constructed op tree.  C<debuggable> is currently
7026 unused and should always be 1.
7027
7028 =cut
7029 */
7030
7031 OP *
7032 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
7033 {
7034     OP* listop;
7035     OP* o;
7036     const bool once = block && block->op_flags & OPf_SPECIAL &&
7037                       block->op_type == OP_NULL;
7038
7039     PERL_UNUSED_ARG(debuggable);
7040
7041     if (expr) {
7042         if (once && (
7043               (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
7044            || (  expr->op_type == OP_NOT
7045               && cUNOPx(expr)->op_first->op_type == OP_CONST
7046               && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
7047               )
7048            ))
7049             /* Return the block now, so that S_new_logop does not try to
7050                fold it away. */
7051             return block;       /* do {} while 0 does once */
7052         if (expr->op_type == OP_READLINE
7053             || expr->op_type == OP_READDIR
7054             || expr->op_type == OP_GLOB
7055             || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
7056             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
7057             expr = newUNOP(OP_DEFINED, 0,
7058                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
7059         } else if (expr->op_flags & OPf_KIDS) {
7060             const OP * const k1 = ((UNOP*)expr)->op_first;
7061             const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
7062             switch (expr->op_type) {
7063               case OP_NULL:
7064                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
7065                       && (k2->op_flags & OPf_STACKED)
7066                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7067                     expr = newUNOP(OP_DEFINED, 0, expr);
7068                 break;
7069
7070               case OP_SASSIGN:
7071                 if (k1 && (k1->op_type == OP_READDIR
7072                       || k1->op_type == OP_GLOB
7073                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7074                      || k1->op_type == OP_EACH
7075                      || k1->op_type == OP_AEACH))
7076                     expr = newUNOP(OP_DEFINED, 0, expr);
7077                 break;
7078             }
7079         }
7080     }
7081
7082     /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
7083      * op, in listop. This is wrong. [perl #27024] */
7084     if (!block)
7085         block = newOP(OP_NULL, 0);
7086     listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
7087     o = new_logop(OP_AND, 0, &expr, &listop);
7088
7089     if (once) {
7090         ASSUME(listop);
7091     }
7092
7093     if (listop)
7094         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
7095
7096     if (once && o != listop)
7097     {
7098         assert(cUNOPo->op_first->op_type == OP_AND
7099             || cUNOPo->op_first->op_type == OP_OR);
7100         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
7101     }
7102
7103     if (o == listop)
7104         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
7105
7106     o->op_flags |= flags;
7107     o = op_scope(o);
7108     o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
7109     return o;
7110 }
7111
7112 /*
7113 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
7114
7115 Constructs, checks, and returns an op tree expressing a C<while> loop.
7116 This is a heavyweight loop, with structure that allows exiting the loop
7117 by C<last> and suchlike.
7118
7119 C<loop> is an optional preconstructed C<enterloop> op to use in the
7120 loop; if it is null then a suitable op will be constructed automatically.
7121 C<expr> supplies the loop's controlling expression.  C<block> supplies the
7122 main body of the loop, and C<cont> optionally supplies a C<continue> block
7123 that operates as a second half of the body.  All of these optree inputs
7124 are consumed by this function and become part of the constructed op tree.
7125
7126 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7127 op and, shifted up eight bits, the eight bits of C<op_private> for
7128 the C<leaveloop> op, except that (in both cases) some bits will be set
7129 automatically.  C<debuggable> is currently unused and should always be 1.
7130 C<has_my> can be supplied as true to force the
7131 loop body to be enclosed in its own scope.
7132
7133 =cut
7134 */
7135
7136 OP *
7137 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
7138         OP *expr, OP *block, OP *cont, I32 has_my)
7139 {
7140     dVAR;
7141     OP *redo;
7142     OP *next = NULL;
7143     OP *listop;
7144     OP *o;
7145     U8 loopflags = 0;
7146
7147     PERL_UNUSED_ARG(debuggable);
7148
7149     if (expr) {
7150         if (expr->op_type == OP_READLINE
7151          || expr->op_type == OP_READDIR
7152          || expr->op_type == OP_GLOB
7153          || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
7154                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
7155             expr = newUNOP(OP_DEFINED, 0,
7156                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
7157         } else if (expr->op_flags & OPf_KIDS) {
7158             const OP * const k1 = ((UNOP*)expr)->op_first;
7159             const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
7160             switch (expr->op_type) {
7161               case OP_NULL:
7162                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
7163                       && (k2->op_flags & OPf_STACKED)
7164                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7165                     expr = newUNOP(OP_DEFINED, 0, expr);
7166                 break;
7167
7168               case OP_SASSIGN:
7169                 if (k1 && (k1->op_type == OP_READDIR
7170                       || k1->op_type == OP_GLOB
7171                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7172                      || k1->op_type == OP_EACH
7173                      || k1->op_type == OP_AEACH))
7174                     expr = newUNOP(OP_DEFINED, 0, expr);
7175                 break;
7176             }
7177         }
7178     }
7179
7180     if (!block)
7181         block = newOP(OP_NULL, 0);
7182     else if (cont || has_my) {
7183         block = op_scope(block);
7184     }
7185
7186     if (cont) {
7187         next = LINKLIST(cont);
7188     }
7189     if (expr) {
7190         OP * const unstack = newOP(OP_UNSTACK, 0);
7191         if (!next)
7192             next = unstack;
7193         cont = op_append_elem(OP_LINESEQ, cont, unstack);
7194     }
7195
7196     assert(block);
7197     listop = op_append_list(OP_LINESEQ, block, cont);
7198     assert(listop);
7199     redo = LINKLIST(listop);
7200
7201     if (expr) {
7202         scalar(listop);
7203         o = new_logop(OP_AND, 0, &expr, &listop);
7204         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
7205             op_free((OP*)loop);
7206             return expr;                /* listop already freed by new_logop */
7207         }
7208         if (listop)
7209             ((LISTOP*)listop)->op_last->op_next =
7210                 (o == listop ? redo : LINKLIST(o));
7211     }
7212     else
7213         o = listop;
7214
7215     if (!loop) {
7216         NewOp(1101,loop,1,LOOP);
7217         OpTYPE_set(loop, OP_ENTERLOOP);
7218         loop->op_private = 0;
7219         loop->op_next = (OP*)loop;
7220     }
7221
7222     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
7223
7224     loop->op_redoop = redo;
7225     loop->op_lastop = o;
7226     o->op_private |= loopflags;
7227
7228     if (next)
7229         loop->op_nextop = next;
7230     else
7231         loop->op_nextop = o;
7232
7233     o->op_flags |= flags;
7234     o->op_private |= (flags >> 8);
7235     return o;
7236 }
7237
7238 /*
7239 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
7240
7241 Constructs, checks, and returns an op tree expressing a C<foreach>
7242 loop (iteration through a list of values).  This is a heavyweight loop,
7243 with structure that allows exiting the loop by C<last> and suchlike.
7244
7245 C<sv> optionally supplies the variable that will be aliased to each
7246 item in turn; if null, it defaults to C<$_>.
7247 C<expr> supplies the list of values to iterate over.  C<block> supplies
7248 the main body of the loop, and C<cont> optionally supplies a C<continue>
7249 block that operates as a second half of the body.  All of these optree
7250 inputs are consumed by this function and become part of the constructed
7251 op tree.
7252
7253 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7254 op and, shifted up eight bits, the eight bits of C<op_private> for
7255 the C<leaveloop> op, except that (in both cases) some bits will be set
7256 automatically.
7257
7258 =cut
7259 */
7260
7261 OP *
7262 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
7263 {
7264     dVAR;
7265     LOOP *loop;
7266     OP *wop;
7267     PADOFFSET padoff = 0;
7268     I32 iterflags = 0;
7269     I32 iterpflags = 0;
7270
7271     PERL_ARGS_ASSERT_NEWFOROP;
7272
7273     if (sv) {
7274         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
7275             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
7276             OpTYPE_set(sv, OP_RV2GV);
7277
7278             /* The op_type check is needed to prevent a possible segfault
7279              * if the loop variable is undeclared and 'strict vars' is in
7280              * effect. This is illegal but is nonetheless parsed, so we
7281              * may reach this point with an OP_CONST where we're expecting
7282              * an OP_GV.
7283              */
7284             if (cUNOPx(sv)->op_first->op_type == OP_GV
7285              && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
7286                 iterpflags |= OPpITER_DEF;
7287         }
7288         else if (sv->op_type == OP_PADSV) { /* private variable */
7289             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
7290             padoff = sv->op_targ;
7291             sv->op_targ = 0;
7292             op_free(sv);
7293             sv = NULL;
7294             PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
7295         }
7296         else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
7297             NOOP;
7298         else
7299             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
7300         if (padoff) {
7301             PADNAME * const pn = PAD_COMPNAME(padoff);
7302             const char * const name = PadnamePV(pn);
7303
7304             if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
7305                 iterpflags |= OPpITER_DEF;
7306         }
7307     }
7308     else {
7309         sv = newGVOP(OP_GV, 0, PL_defgv);
7310         iterpflags |= OPpITER_DEF;
7311     }
7312
7313     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
7314         expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
7315         iterflags |= OPf_STACKED;
7316     }
7317     else if (expr->op_type == OP_NULL &&
7318              (expr->op_flags & OPf_KIDS) &&
7319              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
7320     {
7321         /* Basically turn for($x..$y) into the same as for($x,$y), but we
7322          * set the STACKED flag to indicate that these values are to be
7323          * treated as min/max values by 'pp_enteriter'.
7324          */
7325         const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
7326         LOGOP* const range = (LOGOP*) flip->op_first;
7327         OP* const left  = range->op_first;
7328         OP* const right = OpSIBLING(left);
7329         LISTOP* listop;
7330
7331         range->op_flags &= ~OPf_KIDS;
7332         /* detach range's children */
7333         op_sibling_splice((OP*)range, NULL, -1, NULL);
7334
7335         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
7336         listop->op_first->op_next = range->op_next;
7337         left->op_next = range->op_other;
7338         right->op_next = (OP*)listop;
7339         listop->op_next = listop->op_first;
7340
7341         op_free(expr);
7342         expr = (OP*)(listop);
7343         op_null(expr);
7344         iterflags |= OPf_STACKED;
7345     }
7346     else {
7347         expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
7348     }
7349
7350     loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
7351                                   op_append_elem(OP_LIST, list(expr),
7352                                                  scalar(sv)));
7353     assert(!loop->op_next);
7354     /* for my  $x () sets OPpLVAL_INTRO;
7355      * for our $x () sets OPpOUR_INTRO */
7356     loop->op_private = (U8)iterpflags;
7357     if (loop->op_slabbed
7358      && DIFF(loop, OpSLOT(loop)->opslot_next)
7359          < SIZE_TO_PSIZE(sizeof(LOOP)))
7360     {
7361         LOOP *tmp;
7362         NewOp(1234,tmp,1,LOOP);
7363         Copy(loop,tmp,1,LISTOP);
7364 #ifdef PERL_OP_PARENT
7365         assert(loop->op_last->op_sibparent == (OP*)loop);
7366         OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
7367 #endif
7368         S_op_destroy(aTHX_ (OP*)loop);
7369         loop = tmp;
7370     }
7371     else if (!loop->op_slabbed)
7372     {
7373         loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
7374 #ifdef PERL_OP_PARENT
7375         OpLASTSIB_set(loop->op_last, (OP*)loop);
7376 #endif
7377     }
7378     loop->op_targ = padoff;
7379     wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
7380     return wop;
7381 }
7382
7383 /*
7384 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
7385
7386 Constructs, checks, and returns a loop-exiting op (such as C<goto>
7387 or C<last>).  C<type> is the opcode.  C<label> supplies the parameter
7388 determining the target of the op; it is consumed by this function and
7389 becomes part of the constructed op tree.
7390
7391 =cut
7392 */
7393
7394 OP*
7395 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
7396 {
7397     OP *o = NULL;
7398
7399     PERL_ARGS_ASSERT_NEWLOOPEX;
7400
7401     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
7402         || type == OP_CUSTOM);
7403
7404     if (type != OP_GOTO) {
7405         /* "last()" means "last" */
7406         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
7407             o = newOP(type, OPf_SPECIAL);
7408         }
7409     }
7410     else {
7411         /* Check whether it's going to be a goto &function */
7412         if (label->op_type == OP_ENTERSUB
7413                 && !(label->op_flags & OPf_STACKED))
7414             label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
7415     }
7416
7417     /* Check for a constant argument */
7418     if (label->op_type == OP_CONST) {
7419             SV * const sv = ((SVOP *)label)->op_sv;
7420             STRLEN l;
7421             const char *s = SvPV_const(sv,l);
7422             if (l == strlen(s)) {
7423                 o = newPVOP(type,
7424                             SvUTF8(((SVOP*)label)->op_sv),
7425                             savesharedpv(
7426                                 SvPV_nolen_const(((SVOP*)label)->op_sv)));
7427             }
7428     }
7429
7430     /* If we have already created an op, we do not need the label. */
7431     if (o)
7432                 op_free(label);
7433     else o = newUNOP(type, OPf_STACKED, label);
7434
7435     PL_hints |= HINT_BLOCK_SCOPE;
7436     return o;
7437 }
7438
7439 /* if the condition is a literal array or hash
7440    (or @{ ... } etc), make a reference to it.
7441  */
7442 STATIC OP *
7443 S_ref_array_or_hash(pTHX_ OP *cond)
7444 {
7445     if (cond
7446     && (cond->op_type == OP_RV2AV
7447     ||  cond->op_type == OP_PADAV
7448     ||  cond->op_type == OP_RV2HV
7449     ||  cond->op_type == OP_PADHV))
7450
7451         return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
7452
7453     else if(cond
7454     && (cond->op_type == OP_ASLICE
7455     ||  cond->op_type == OP_KVASLICE
7456     ||  cond->op_type == OP_HSLICE
7457     ||  cond->op_type == OP_KVHSLICE)) {
7458
7459         /* anonlist now needs a list from this op, was previously used in
7460          * scalar context */
7461         cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
7462         cond->op_flags |= OPf_WANT_LIST;
7463
7464         return newANONLIST(op_lvalue(cond, OP_ANONLIST));
7465     }
7466
7467     else
7468         return cond;
7469 }
7470
7471 /* These construct the optree fragments representing given()
7472    and when() blocks.
7473
7474    entergiven and enterwhen are LOGOPs; the op_other pointer
7475    points up to the associated leave op. We need this so we
7476    can put it in the context and make break/continue work.
7477    (Also, of course, pp_enterwhen will jump straight to
7478    op_other if the match fails.)
7479  */
7480
7481 STATIC OP *
7482 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
7483                    I32 enter_opcode, I32 leave_opcode,
7484                    PADOFFSET entertarg)
7485 {
7486     dVAR;
7487     LOGOP *enterop;
7488     OP *o;
7489
7490     PERL_ARGS_ASSERT_NEWGIVWHENOP;
7491     PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
7492
7493     enterop = S_alloc_LOGOP(aTHX_ enter_opcode, block, NULL);
7494     enterop->op_targ = 0;
7495     enterop->op_private = 0;
7496
7497     o = newUNOP(leave_opcode, 0, (OP *) enterop);
7498
7499     if (cond) {
7500         /* prepend cond if we have one */
7501         op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
7502
7503         o->op_next = LINKLIST(cond);
7504         cond->op_next = (OP *) enterop;
7505     }
7506     else {
7507         /* This is a default {} block */
7508         enterop->op_flags |= OPf_SPECIAL;
7509         o      ->op_flags |= OPf_SPECIAL;
7510
7511         o->op_next = (OP *) enterop;
7512     }
7513
7514     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
7515                                        entergiven and enterwhen both
7516                                        use ck_null() */
7517
7518     enterop->op_next = LINKLIST(block);
7519     block->op_next = enterop->op_other = o;
7520
7521     return o;
7522 }
7523
7524 /* Does this look like a boolean operation? For these purposes
7525    a boolean operation is:
7526      - a subroutine call [*]
7527      - a logical connective
7528      - a comparison operator
7529      - a filetest operator, with the exception of -s -M -A -C
7530      - defined(), exists() or eof()
7531      - /$re/ or $foo =~ /$re/
7532
7533    [*] possibly surprising
7534  */
7535 STATIC bool
7536 S_looks_like_bool(pTHX_ const OP *o)
7537 {
7538     PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
7539
7540     switch(o->op_type) {
7541         case OP_OR:
7542         case OP_DOR:
7543             return looks_like_bool(cLOGOPo->op_first);
7544
7545         case OP_AND:
7546         {
7547             OP* sibl = OpSIBLING(cLOGOPo->op_first);
7548             ASSUME(sibl);
7549             return (
7550                 looks_like_bool(cLOGOPo->op_first)
7551              && looks_like_bool(sibl));
7552         }
7553
7554         case OP_NULL:
7555         case OP_SCALAR:
7556             return (
7557                 o->op_flags & OPf_KIDS
7558             && looks_like_bool(cUNOPo->op_first));
7559
7560         case OP_ENTERSUB:
7561
7562         case OP_NOT:    case OP_XOR:
7563
7564         case OP_EQ:     case OP_NE:     case OP_LT:
7565         case OP_GT:     case OP_LE:     case OP_GE:
7566
7567         case OP_I_EQ:   case OP_I_NE:   case OP_I_LT:
7568         case OP_I_GT:   case OP_I_LE:   case OP_I_GE:
7569
7570         case OP_SEQ:    case OP_SNE:    case OP_SLT:
7571         case OP_SGT:    case OP_SLE:    case OP_SGE:
7572
7573         case OP_SMARTMATCH:
7574
7575         case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
7576         case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
7577         case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
7578         case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
7579         case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
7580         case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
7581         case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
7582         case OP_FTTEXT:   case OP_FTBINARY:
7583
7584         case OP_DEFINED: case OP_EXISTS:
7585         case OP_MATCH:   case OP_EOF:
7586
7587         case OP_FLOP:
7588
7589             return TRUE;
7590
7591         case OP_CONST:
7592             /* Detect comparisons that have been optimized away */
7593             if (cSVOPo->op_sv == &PL_sv_yes
7594             ||  cSVOPo->op_sv == &PL_sv_no)
7595
7596                 return TRUE;
7597             else
7598                 return FALSE;
7599
7600         /* FALLTHROUGH */
7601         default:
7602             return FALSE;
7603     }
7604 }
7605
7606 /*
7607 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
7608
7609 Constructs, checks, and returns an op tree expressing a C<given> block.
7610 C<cond> supplies the expression that will be locally assigned to a lexical
7611 variable, and C<block> supplies the body of the C<given> construct; they
7612 are consumed by this function and become part of the constructed op tree.
7613 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
7614
7615 =cut
7616 */
7617
7618 OP *
7619 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
7620 {
7621     PERL_ARGS_ASSERT_NEWGIVENOP;
7622     PERL_UNUSED_ARG(defsv_off);
7623
7624     assert(!defsv_off);
7625     return newGIVWHENOP(
7626         ref_array_or_hash(cond),
7627         block,
7628         OP_ENTERGIVEN, OP_LEAVEGIVEN,
7629         0);
7630 }
7631
7632 /*
7633 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
7634
7635 Constructs, checks, and returns an op tree expressing a C<when> block.
7636 C<cond> supplies the test expression, and C<block> supplies the block
7637 that will be executed if the test evaluates to true; they are consumed
7638 by this function and become part of the constructed op tree.  C<cond>
7639 will be interpreted DWIMically, often as a comparison against C<$_>,
7640 and may be null to generate a C<default> block.
7641
7642 =cut
7643 */
7644
7645 OP *
7646 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
7647 {
7648     const bool cond_llb = (!cond || looks_like_bool(cond));
7649     OP *cond_op;
7650
7651     PERL_ARGS_ASSERT_NEWWHENOP;
7652
7653     if (cond_llb)
7654         cond_op = cond;
7655     else {
7656         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
7657                 newDEFSVOP(),
7658                 scalar(ref_array_or_hash(cond)));
7659     }
7660
7661     return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
7662 }
7663
7664 /* must not conflict with SVf_UTF8 */
7665 #define CV_CKPROTO_CURSTASH     0x1
7666
7667 void
7668 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
7669                     const STRLEN len, const U32 flags)
7670 {
7671     SV *name = NULL, *msg;
7672     const char * cvp = SvROK(cv)
7673                         ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
7674                            ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
7675                            : ""
7676                         : CvPROTO(cv);
7677     STRLEN clen = CvPROTOLEN(cv), plen = len;
7678
7679     PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
7680
7681     if (p == NULL && cvp == NULL)
7682         return;
7683
7684     if (!ckWARN_d(WARN_PROTOTYPE))
7685         return;
7686
7687     if (p && cvp) {
7688         p = S_strip_spaces(aTHX_ p, &plen);
7689         cvp = S_strip_spaces(aTHX_ cvp, &clen);
7690         if ((flags & SVf_UTF8) == SvUTF8(cv)) {
7691             if (plen == clen && memEQ(cvp, p, plen))
7692                 return;
7693         } else {
7694             if (flags & SVf_UTF8) {
7695                 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
7696                     return;
7697             }
7698             else {
7699                 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
7700                     return;
7701             }
7702         }
7703     }
7704
7705     msg = sv_newmortal();
7706
7707     if (gv)
7708     {
7709         if (isGV(gv))
7710             gv_efullname3(name = sv_newmortal(), gv, NULL);
7711         else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
7712             name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
7713         else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
7714             name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
7715             sv_catpvs(name, "::");
7716             if (SvROK(gv)) {
7717                 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
7718                 assert (CvNAMED(SvRV_const(gv)));
7719                 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
7720             }
7721             else sv_catsv(name, (SV *)gv);
7722         }
7723         else name = (SV *)gv;
7724     }
7725     sv_setpvs(msg, "Prototype mismatch:");
7726     if (name)
7727         Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
7728     if (cvp)
7729         Perl_sv_catpvf(aTHX_ msg, " (%"UTF8f")",
7730             UTF8fARG(SvUTF8(cv),clen,cvp)
7731         );
7732     else
7733         sv_catpvs(msg, ": none");
7734     sv_catpvs(msg, " vs ");
7735     if (p)
7736         Perl_sv_catpvf(aTHX_ msg, "(%"UTF8f")", UTF8fARG(flags & SVf_UTF8,len,p));
7737     else
7738         sv_catpvs(msg, "none");
7739     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
7740 }
7741
7742 static void const_sv_xsub(pTHX_ CV* cv);
7743 static void const_av_xsub(pTHX_ CV* cv);
7744
7745 /*
7746
7747 =head1 Optree Manipulation Functions
7748
7749 =for apidoc cv_const_sv
7750
7751 If C<cv> is a constant sub eligible for inlining, returns the constant
7752 value returned by the sub.  Otherwise, returns C<NULL>.
7753
7754 Constant subs can be created with C<newCONSTSUB> or as described in
7755 L<perlsub/"Constant Functions">.
7756
7757 =cut
7758 */
7759 SV *
7760 Perl_cv_const_sv(const CV *const cv)
7761 {
7762     SV *sv;
7763     if (!cv)
7764         return NULL;
7765     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
7766         return NULL;
7767     sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7768     if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
7769     return sv;
7770 }
7771
7772 SV *
7773 Perl_cv_const_sv_or_av(const CV * const cv)
7774 {
7775     if (!cv)
7776         return NULL;
7777     if (SvROK(cv)) return SvRV((SV *)cv);
7778     assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
7779     return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7780 }
7781
7782 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
7783  * Can be called in 2 ways:
7784  *
7785  * !allow_lex
7786  *      look for a single OP_CONST with attached value: return the value
7787  *
7788  * allow_lex && !CvCONST(cv);
7789  *
7790  *      examine the clone prototype, and if contains only a single
7791  *      OP_CONST, return the value; or if it contains a single PADSV ref-
7792  *      erencing an outer lexical, turn on CvCONST to indicate the CV is
7793  *      a candidate for "constizing" at clone time, and return NULL.
7794  */
7795
7796 static SV *
7797 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
7798 {
7799     SV *sv = NULL;
7800     bool padsv = FALSE;
7801
7802     assert(o);
7803     assert(cv);
7804
7805     for (; o; o = o->op_next) {
7806         const OPCODE type = o->op_type;
7807
7808         if (type == OP_NEXTSTATE || type == OP_LINESEQ
7809              || type == OP_NULL
7810              || type == OP_PUSHMARK)
7811                 continue;
7812         if (type == OP_DBSTATE)
7813                 continue;
7814         if (type == OP_LEAVESUB)
7815             break;
7816         if (sv)
7817             return NULL;
7818         if (type == OP_CONST && cSVOPo->op_sv)
7819             sv = cSVOPo->op_sv;
7820         else if (type == OP_UNDEF && !o->op_private) {
7821             sv = newSV(0);
7822             SAVEFREESV(sv);
7823         }
7824         else if (allow_lex && type == OP_PADSV) {
7825                 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
7826                 {
7827                     sv = &PL_sv_undef; /* an arbitrary non-null value */
7828                     padsv = TRUE;
7829                 }
7830                 else
7831                     return NULL;
7832         }
7833         else {
7834             return NULL;
7835         }
7836     }
7837     if (padsv) {
7838         CvCONST_on(cv);
7839         return NULL;
7840     }
7841     return sv;
7842 }
7843
7844 static bool
7845 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
7846                         PADNAME * const name, SV ** const const_svp)
7847 {
7848     assert (cv);
7849     assert (o || name);
7850     assert (const_svp);
7851     if ((!block
7852          )) {
7853         if (CvFLAGS(PL_compcv)) {
7854             /* might have had built-in attrs applied */
7855             const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
7856             if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
7857              && ckWARN(WARN_MISC))
7858             {
7859                 /* protect against fatal warnings leaking compcv */
7860                 SAVEFREESV(PL_compcv);
7861                 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
7862                 SvREFCNT_inc_simple_void_NN(PL_compcv);
7863             }
7864             CvFLAGS(cv) |=
7865                 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
7866                   & ~(CVf_LVALUE * pureperl));
7867         }
7868         return FALSE;
7869     }
7870
7871     /* redundant check for speed: */
7872     if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
7873         const line_t oldline = CopLINE(PL_curcop);
7874         SV *namesv = o
7875             ? cSVOPo->op_sv
7876             : sv_2mortal(newSVpvn_utf8(
7877                 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
7878               ));
7879         if (PL_parser && PL_parser->copline != NOLINE)
7880             /* This ensures that warnings are reported at the first
7881                line of a redefinition, not the last.  */
7882             CopLINE_set(PL_curcop, PL_parser->copline);
7883         /* protect against fatal warnings leaking compcv */
7884         SAVEFREESV(PL_compcv);
7885         report_redefined_cv(namesv, cv, const_svp);
7886         SvREFCNT_inc_simple_void_NN(PL_compcv);
7887         CopLINE_set(PL_curcop, oldline);
7888     }
7889     SAVEFREESV(cv);
7890     return TRUE;
7891 }
7892
7893 CV *
7894 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
7895 {
7896     CV **spot;
7897     SV **svspot;
7898     const char *ps;
7899     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
7900     U32 ps_utf8 = 0;
7901     CV *cv = NULL;
7902     CV *compcv = PL_compcv;
7903     SV *const_sv;
7904     PADNAME *name;
7905     PADOFFSET pax = o->op_targ;
7906     CV *outcv = CvOUTSIDE(PL_compcv);
7907     CV *clonee = NULL;
7908     HEK *hek = NULL;
7909     bool reusable = FALSE;
7910     OP *start = NULL;
7911 #ifdef PERL_DEBUG_READONLY_OPS
7912     OPSLAB *slab = NULL;
7913 #endif
7914
7915     PERL_ARGS_ASSERT_NEWMYSUB;
7916
7917     /* Find the pad slot for storing the new sub.
7918        We cannot use PL_comppad, as it is the pad owned by the new sub.  We
7919        need to look in CvOUTSIDE and find the pad belonging to the enclos-
7920        ing sub.  And then we need to dig deeper if this is a lexical from
7921        outside, as in:
7922            my sub foo; sub { sub foo { } }
7923      */
7924    redo:
7925     name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
7926     if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
7927         pax = PARENT_PAD_INDEX(name);
7928         outcv = CvOUTSIDE(outcv);
7929         assert(outcv);
7930         goto redo;
7931     }
7932     svspot =
7933         &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
7934                         [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
7935     spot = (CV **)svspot;
7936
7937     if (!(PL_parser && PL_parser->error_count))
7938         move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name));
7939
7940     if (proto) {
7941         assert(proto->op_type == OP_CONST);
7942         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
7943         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
7944     }
7945     else
7946         ps = NULL;
7947
7948     if (proto)
7949         SAVEFREEOP(proto);
7950     if (attrs)
7951         SAVEFREEOP(attrs);
7952
7953     if (PL_parser && PL_parser->error_count) {
7954         op_free(block);
7955         SvREFCNT_dec(PL_compcv);
7956         PL_compcv = 0;
7957         goto done;
7958     }
7959
7960     if (CvDEPTH(outcv) && CvCLONE(compcv)) {
7961         cv = *spot;
7962         svspot = (SV **)(spot = &clonee);
7963     }
7964     else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
7965         cv = *spot;
7966     else {
7967         assert (SvTYPE(*spot) == SVt_PVCV);
7968         if (CvNAMED(*spot))
7969             hek = CvNAME_HEK(*spot);
7970         else {
7971             dVAR;
7972             U32 hash;
7973             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
7974             CvNAME_HEK_set(*spot, hek =
7975                 share_hek(
7976                     PadnamePV(name)+1,
7977                     (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
7978                     hash
7979                 )
7980             );
7981             CvLEXICAL_on(*spot);
7982         }
7983         cv = PadnamePROTOCV(name);
7984         svspot = (SV **)(spot = &PadnamePROTOCV(name));
7985     }
7986
7987     if (block) {
7988         /* This makes sub {}; work as expected.  */
7989         if (block->op_type == OP_STUB) {
7990             const line_t l = PL_parser->copline;
7991             op_free(block);
7992             block = newSTATEOP(0, NULL, 0);
7993             PL_parser->copline = l;
7994         }
7995         block = CvLVALUE(compcv)
7996              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
7997                    ? newUNOP(OP_LEAVESUBLV, 0,
7998                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
7999                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
8000         start = LINKLIST(block);
8001         block->op_next = 0;
8002         if (ps && !*ps && !attrs && !CvLVALUE(compcv))
8003             const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
8004         else
8005             const_sv = NULL;
8006     }
8007     else
8008         const_sv = NULL;
8009
8010     if (cv) {
8011         const bool exists = CvROOT(cv) || CvXSUB(cv);
8012
8013         /* if the subroutine doesn't exist and wasn't pre-declared
8014          * with a prototype, assume it will be AUTOLOADed,
8015          * skipping the prototype check
8016          */
8017         if (exists || SvPOK(cv))
8018             cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
8019                                  ps_utf8);
8020         /* already defined? */
8021         if (exists) {
8022             if (S_already_defined(aTHX_ cv,block,NULL,name,&const_sv))
8023                 cv = NULL;
8024             else {
8025                 if (attrs) goto attrs;
8026                 /* just a "sub foo;" when &foo is already defined */
8027                 SAVEFREESV(compcv);
8028                 goto done;
8029             }
8030         }
8031         else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
8032             cv = NULL;
8033             reusable = TRUE;
8034         }
8035     }
8036     if (const_sv) {
8037         SvREFCNT_inc_simple_void_NN(const_sv);
8038         SvFLAGS(const_sv) |= SVs_PADTMP;
8039         if (cv) {
8040             assert(!CvROOT(cv) && !CvCONST(cv));
8041             cv_forget_slab(cv);
8042         }
8043         else {
8044             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8045             CvFILE_set_from_cop(cv, PL_curcop);
8046             CvSTASH_set(cv, PL_curstash);
8047             *spot = cv;
8048         }
8049         sv_setpvs(MUTABLE_SV(cv), "");  /* prototype is "" */
8050         CvXSUBANY(cv).any_ptr = const_sv;
8051         CvXSUB(cv) = const_sv_xsub;
8052         CvCONST_on(cv);
8053         CvISXSUB_on(cv);
8054         PoisonPADLIST(cv);
8055         CvFLAGS(cv) |= CvMETHOD(compcv);
8056         op_free(block);
8057         SvREFCNT_dec(compcv);
8058         PL_compcv = NULL;
8059         goto setname;
8060     }
8061     /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
8062        determine whether this sub definition is in the same scope as its
8063        declaration.  If this sub definition is inside an inner named pack-
8064        age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
8065        the package sub.  So check PadnameOUTER(name) too.
8066      */
8067     if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
8068         assert(!CvWEAKOUTSIDE(compcv));
8069         SvREFCNT_dec(CvOUTSIDE(compcv));
8070         CvWEAKOUTSIDE_on(compcv);
8071     }
8072     /* XXX else do we have a circular reference? */
8073     if (cv) {   /* must reuse cv in case stub is referenced elsewhere */
8074         /* transfer PL_compcv to cv */
8075         if (block
8076         ) {
8077             cv_flags_t preserved_flags =
8078                 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
8079             PADLIST *const temp_padl = CvPADLIST(cv);
8080             CV *const temp_cv = CvOUTSIDE(cv);
8081             const cv_flags_t other_flags =
8082                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8083             OP * const cvstart = CvSTART(cv);
8084
8085             SvPOK_off(cv);
8086             CvFLAGS(cv) =
8087                 CvFLAGS(compcv) | preserved_flags;
8088             CvOUTSIDE(cv) = CvOUTSIDE(compcv);
8089             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
8090             CvPADLIST_set(cv, CvPADLIST(compcv));
8091             CvOUTSIDE(compcv) = temp_cv;
8092             CvPADLIST_set(compcv, temp_padl);
8093             CvSTART(cv) = CvSTART(compcv);
8094             CvSTART(compcv) = cvstart;
8095             CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8096             CvFLAGS(compcv) |= other_flags;
8097
8098             if (CvFILE(cv) && CvDYNFILE(cv)) {
8099                 Safefree(CvFILE(cv));
8100             }
8101
8102             /* inner references to compcv must be fixed up ... */
8103             pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
8104             if (PERLDB_INTER)/* Advice debugger on the new sub. */
8105               ++PL_sub_generation;
8106         }
8107         else {
8108             /* Might have had built-in attributes applied -- propagate them. */
8109             CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
8110         }
8111         /* ... before we throw it away */
8112         SvREFCNT_dec(compcv);
8113         PL_compcv = compcv = cv;
8114     }
8115     else {
8116         cv = compcv;
8117         *spot = cv;
8118     }
8119    setname:
8120     CvLEXICAL_on(cv);
8121     if (!CvNAME_HEK(cv)) {
8122         if (hek) (void)share_hek_hek(hek);
8123         else {
8124             dVAR;
8125             U32 hash;
8126             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
8127             hek = share_hek(PadnamePV(name)+1,
8128                       (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
8129                       hash);
8130         }
8131         CvNAME_HEK_set(cv, hek);
8132     }
8133     if (const_sv) goto clone;
8134
8135     CvFILE_set_from_cop(cv, PL_curcop);
8136     CvSTASH_set(cv, PL_curstash);
8137
8138     if (ps) {
8139         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8140         if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
8141     }
8142
8143     if (!block)
8144         goto attrs;
8145
8146     /* If we assign an optree to a PVCV, then we've defined a subroutine that
8147        the debugger could be able to set a breakpoint in, so signal to
8148        pp_entereval that it should not throw away any saved lines at scope
8149        exit.  */
8150
8151     PL_breakable_sub_gen++;
8152     CvROOT(cv) = block;
8153     CvROOT(cv)->op_private |= OPpREFCOUNTED;
8154     OpREFCNT_set(CvROOT(cv), 1);
8155     /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8156        itself has a refcount. */
8157     CvSLABBED_off(cv);
8158     OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8159 #ifdef PERL_DEBUG_READONLY_OPS
8160     slab = (OPSLAB *)CvSTART(cv);
8161 #endif
8162     CvSTART(cv) = start;
8163     CALL_PEEP(start);
8164     finalize_optree(CvROOT(cv));
8165     S_prune_chain_head(&CvSTART(cv));
8166
8167     /* now that optimizer has done its work, adjust pad values */
8168
8169     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8170
8171   attrs:
8172     if (attrs) {
8173         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8174         apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
8175     }
8176
8177     if (block) {
8178         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8179             SV * const tmpstr = sv_newmortal();
8180             GV * const db_postponed = gv_fetchpvs("DB::postponed",
8181                                                   GV_ADDMULTI, SVt_PVHV);
8182             HV *hv;
8183             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8184                                           CopFILE(PL_curcop),
8185                                           (long)PL_subline,
8186                                           (long)CopLINE(PL_curcop));
8187             if (HvNAME_HEK(PL_curstash)) {
8188                 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
8189                 sv_catpvs(tmpstr, "::");
8190             }
8191             else sv_setpvs(tmpstr, "__ANON__::");
8192             sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
8193                             PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
8194             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8195                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8196             hv = GvHVn(db_postponed);
8197             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8198                 CV * const pcv = GvCV(db_postponed);
8199                 if (pcv) {
8200                     dSP;
8201                     PUSHMARK(SP);
8202                     XPUSHs(tmpstr);
8203                     PUTBACK;
8204                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
8205                 }
8206             }
8207         }
8208     }
8209
8210   clone:
8211     if (clonee) {
8212         assert(CvDEPTH(outcv));
8213         spot = (CV **)
8214             &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
8215         if (reusable) cv_clone_into(clonee, *spot);
8216         else *spot = cv_clone(clonee);
8217         SvREFCNT_dec_NN(clonee);
8218         cv = *spot;
8219     }
8220     if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
8221         PADOFFSET depth = CvDEPTH(outcv);
8222         while (--depth) {
8223             SV *oldcv;
8224             svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
8225             oldcv = *svspot;
8226             *svspot = SvREFCNT_inc_simple_NN(cv);
8227             SvREFCNT_dec(oldcv);
8228         }
8229     }
8230
8231   done:
8232     if (PL_parser)
8233         PL_parser->copline = NOLINE;
8234     LEAVE_SCOPE(floor);
8235 #ifdef PERL_DEBUG_READONLY_OPS
8236     if (slab)
8237         Slab_to_ro(slab);
8238 #endif
8239     op_free(o);
8240     return cv;
8241 }
8242
8243 /* _x = extended */
8244 CV *
8245 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
8246                             OP *block, bool o_is_gv)
8247 {
8248     GV *gv;
8249     const char *ps;
8250     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
8251     U32 ps_utf8 = 0;
8252     CV *cv = NULL;
8253     SV *const_sv;
8254     const bool ec = PL_parser && PL_parser->error_count;
8255     /* If the subroutine has no body, no attributes, and no builtin attributes
8256        then it's just a sub declaration, and we may be able to get away with
8257        storing with a placeholder scalar in the symbol table, rather than a
8258        full CV.  If anything is present then it will take a full CV to
8259        store it.  */
8260     const I32 gv_fetch_flags
8261         = ec ? GV_NOADD_NOINIT :
8262         (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
8263         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
8264     STRLEN namlen = 0;
8265     const char * const name =
8266          o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
8267     bool has_name;
8268     bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
8269     bool evanescent = FALSE;
8270     OP *start = NULL;
8271 #ifdef PERL_DEBUG_READONLY_OPS
8272     OPSLAB *slab = NULL;
8273 #endif
8274
8275     if (o_is_gv) {
8276         gv = (GV*)o;
8277         o = NULL;
8278         has_name = TRUE;
8279     } else if (name) {
8280         /* Try to optimise and avoid creating a GV.  Instead, the CV’s name
8281            hek and CvSTASH pointer together can imply the GV.  If the name
8282            contains a package name, then GvSTASH(CvGV(cv)) may differ from
8283            CvSTASH, so forego the optimisation if we find any.
8284            Also, we may be called from load_module at run time, so
8285            PL_curstash (which sets CvSTASH) may not point to the stash the
8286            sub is stored in.  */
8287         const I32 flags =
8288            ec ? GV_NOADD_NOINIT
8289               :   PL_curstash != CopSTASH(PL_curcop)
8290                || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
8291                     ? gv_fetch_flags
8292                     : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
8293         gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
8294         has_name = TRUE;
8295     } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
8296         SV * const sv = sv_newmortal();
8297         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
8298                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
8299                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
8300         gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
8301         has_name = TRUE;
8302     } else if (PL_curstash) {
8303         gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
8304         has_name = FALSE;
8305     } else {
8306         gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
8307         has_name = FALSE;
8308     }
8309     if (!ec) {
8310         if (isGV(gv)) {
8311             move_proto_attr(&proto, &attrs, gv);
8312         } else {
8313             assert(cSVOPo);
8314             move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv);
8315         }
8316     }
8317
8318     if (proto) {
8319         assert(proto->op_type == OP_CONST);
8320         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
8321         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
8322     }
8323     else
8324         ps = NULL;
8325
8326     if (o)
8327         SAVEFREEOP(o);
8328     if (proto)
8329         SAVEFREEOP(proto);
8330     if (attrs)
8331         SAVEFREEOP(attrs);
8332
8333     if (ec) {
8334         op_free(block);
8335         if (name) SvREFCNT_dec(PL_compcv);
8336         else cv = PL_compcv;
8337         PL_compcv = 0;
8338         if (name && block) {
8339             const char *s = strrchr(name, ':');
8340             s = s ? s+1 : name;
8341             if (strEQ(s, "BEGIN")) {
8342                 if (PL_in_eval & EVAL_KEEPERR)
8343                     Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
8344                 else {
8345                     SV * const errsv = ERRSV;
8346                     /* force display of errors found but not reported */
8347                     sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
8348                     Perl_croak_nocontext("%"SVf, SVfARG(errsv));
8349                 }
8350             }
8351         }
8352         goto done;
8353     }
8354
8355     if (!block && SvTYPE(gv) != SVt_PVGV) {
8356       /* If we are not defining a new sub and the existing one is not a
8357          full GV + CV... */
8358       if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
8359         /* We are applying attributes to an existing sub, so we need it
8360            upgraded if it is a constant.  */
8361         if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
8362             gv_init_pvn(gv, PL_curstash, name, namlen,
8363                         SVf_UTF8 * name_is_utf8);
8364       }
8365       else {                    /* Maybe prototype now, and had at maximum
8366                                    a prototype or const/sub ref before.  */
8367         if (SvTYPE(gv) > SVt_NULL) {
8368             cv_ckproto_len_flags((const CV *)gv,
8369                                  o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8370                                  ps_len, ps_utf8);
8371         }
8372         if (!SvROK(gv)) {
8373           if (ps) {
8374             sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
8375             if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
8376           }
8377           else
8378             sv_setiv(MUTABLE_SV(gv), -1);
8379         }
8380
8381         SvREFCNT_dec(PL_compcv);
8382         cv = PL_compcv = NULL;
8383         goto done;
8384       }
8385     }
8386
8387     cv = (!name || (isGV(gv) && GvCVGEN(gv)))
8388         ? NULL
8389         : isGV(gv)
8390             ? GvCV(gv)
8391             : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
8392                 ? (CV *)SvRV(gv)
8393                 : NULL;
8394
8395     if (block) {
8396         assert(PL_parser);
8397         /* This makes sub {}; work as expected.  */
8398         if (block->op_type == OP_STUB) {
8399             const line_t l = PL_parser->copline;
8400             op_free(block);
8401             block = newSTATEOP(0, NULL, 0);
8402             PL_parser->copline = l;
8403         }
8404         block = CvLVALUE(PL_compcv)
8405              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
8406                     && (!isGV(gv) || !GvASSUMECV(gv)))
8407                    ? newUNOP(OP_LEAVESUBLV, 0,
8408                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
8409                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
8410         start = LINKLIST(block);
8411         block->op_next = 0;
8412         if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
8413             const_sv =
8414                 S_op_const_sv(aTHX_ start, PL_compcv,
8415                                         cBOOL(CvCLONE(PL_compcv)));
8416         else
8417             const_sv = NULL;
8418     }
8419     else
8420         const_sv = NULL;
8421
8422     if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
8423         cv_ckproto_len_flags((const CV *)gv,
8424                              o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8425                              ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
8426         if (SvROK(gv)) {
8427             /* All the other code for sub redefinition warnings expects the
8428                clobbered sub to be a CV.  Instead of making all those code
8429                paths more complex, just inline the RV version here.  */
8430             const line_t oldline = CopLINE(PL_curcop);
8431             assert(IN_PERL_COMPILETIME);
8432             if (PL_parser && PL_parser->copline != NOLINE)
8433                 /* This ensures that warnings are reported at the first
8434                    line of a redefinition, not the last.  */
8435                 CopLINE_set(PL_curcop, PL_parser->copline);
8436             /* protect against fatal warnings leaking compcv */
8437             SAVEFREESV(PL_compcv);
8438
8439             if (ckWARN(WARN_REDEFINE)
8440              || (  ckWARN_d(WARN_REDEFINE)
8441                 && (  !const_sv || SvRV(gv) == const_sv
8442                    || sv_cmp(SvRV(gv), const_sv)  )))
8443                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8444                           "Constant subroutine %"SVf" redefined",
8445                           SVfARG(cSVOPo->op_sv));
8446
8447             SvREFCNT_inc_simple_void_NN(PL_compcv);
8448             CopLINE_set(PL_curcop, oldline);
8449             SvREFCNT_dec(SvRV(gv));
8450         }
8451     }
8452
8453     if (cv) {
8454         const bool exists = CvROOT(cv) || CvXSUB(cv);
8455
8456         /* if the subroutine doesn't exist and wasn't pre-declared
8457          * with a prototype, assume it will be AUTOLOADed,
8458          * skipping the prototype check
8459          */
8460         if (exists || SvPOK(cv))
8461             cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
8462         /* already defined (or promised)? */
8463         if (exists || (isGV(gv) && GvASSUMECV(gv))) {
8464             if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv))
8465                 cv = NULL;
8466             else {
8467                 if (attrs) goto attrs;
8468                 /* just a "sub foo;" when &foo is already defined */
8469                 SAVEFREESV(PL_compcv);
8470                 goto done;
8471             }
8472         }
8473     }
8474     if (const_sv) {
8475         SvREFCNT_inc_simple_void_NN(const_sv);
8476         SvFLAGS(const_sv) |= SVs_PADTMP;
8477         if (cv) {
8478             assert(!CvROOT(cv) && !CvCONST(cv));
8479             cv_forget_slab(cv);
8480             sv_setpvs(MUTABLE_SV(cv), "");  /* prototype is "" */
8481             CvXSUBANY(cv).any_ptr = const_sv;
8482             CvXSUB(cv) = const_sv_xsub;
8483             CvCONST_on(cv);
8484             CvISXSUB_on(cv);
8485             PoisonPADLIST(cv);
8486             CvFLAGS(cv) |= CvMETHOD(PL_compcv);
8487         }
8488         else {
8489             if (isGV(gv) || CvMETHOD(PL_compcv)) {
8490                 if (name && isGV(gv))
8491                     GvCV_set(gv, NULL);
8492                 cv = newCONSTSUB_flags(
8493                     NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
8494                     const_sv
8495                 );
8496                 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
8497             }
8498             else {
8499                 if (!SvROK(gv)) {
8500                     SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8501                     prepare_SV_for_RV((SV *)gv);
8502                     SvOK_off((SV *)gv);
8503                     SvROK_on(gv);
8504                 }
8505                 SvRV_set(gv, const_sv);
8506             }
8507         }
8508         op_free(block);
8509         SvREFCNT_dec(PL_compcv);
8510         PL_compcv = NULL;
8511         goto done;
8512     }
8513     if (cv) {                           /* must reuse cv if autoloaded */
8514         /* transfer PL_compcv to cv */
8515         if (block
8516         ) {
8517             cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
8518             PADLIST *const temp_av = CvPADLIST(cv);
8519             CV *const temp_cv = CvOUTSIDE(cv);
8520             const cv_flags_t other_flags =
8521                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8522             OP * const cvstart = CvSTART(cv);
8523
8524             if (isGV(gv)) {
8525                 CvGV_set(cv,gv);
8526                 assert(!CvCVGV_RC(cv));
8527                 assert(CvGV(cv) == gv);
8528             }
8529             else {
8530                 dVAR;
8531                 U32 hash;
8532                 PERL_HASH(hash, name, namlen);
8533                 CvNAME_HEK_set(cv,
8534                                share_hek(name,
8535                                          name_is_utf8
8536                                             ? -(SSize_t)namlen
8537                                             :  (SSize_t)namlen,
8538                                          hash));
8539             }
8540
8541             SvPOK_off(cv);
8542             CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
8543                                              | CvNAMED(cv);
8544             CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
8545             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
8546             CvPADLIST_set(cv,CvPADLIST(PL_compcv));
8547             CvOUTSIDE(PL_compcv) = temp_cv;
8548             CvPADLIST_set(PL_compcv, temp_av);
8549             CvSTART(cv) = CvSTART(PL_compcv);
8550             CvSTART(PL_compcv) = cvstart;
8551             CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8552             CvFLAGS(PL_compcv) |= other_flags;
8553
8554             if (CvFILE(cv) && CvDYNFILE(cv)) {
8555                 Safefree(CvFILE(cv));
8556     }
8557             CvFILE_set_from_cop(cv, PL_curcop);
8558             CvSTASH_set(cv, PL_curstash);
8559
8560             /* inner references to PL_compcv must be fixed up ... */
8561             pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
8562             if (PERLDB_INTER)/* Advice debugger on the new sub. */
8563               ++PL_sub_generation;
8564         }
8565         else {
8566             /* Might have had built-in attributes applied -- propagate them. */
8567             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
8568         }
8569         /* ... before we throw it away */
8570         SvREFCNT_dec(PL_compcv);
8571         PL_compcv = cv;
8572     }
8573     else {
8574         cv = PL_compcv;
8575         if (name && isGV(gv)) {
8576             GvCV_set(gv, cv);
8577             GvCVGEN(gv) = 0;
8578             if (HvENAME_HEK(GvSTASH(gv)))
8579                 /* sub Foo::bar { (shift)+1 } */
8580                 gv_method_changed(gv);
8581         }
8582         else if (name) {
8583             if (!SvROK(gv)) {
8584                 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8585                 prepare_SV_for_RV((SV *)gv);
8586                 SvOK_off((SV *)gv);
8587                 SvROK_on(gv);
8588             }
8589             SvRV_set(gv, (SV *)cv);
8590         }
8591     }
8592     if (!CvHASGV(cv)) {
8593         if (isGV(gv)) CvGV_set(cv, gv);
8594         else {
8595             dVAR;
8596             U32 hash;
8597             PERL_HASH(hash, name, namlen);
8598             CvNAME_HEK_set(cv, share_hek(name,
8599                                          name_is_utf8
8600                                             ? -(SSize_t)namlen
8601                                             :  (SSize_t)namlen,
8602                                          hash));
8603         }
8604         CvFILE_set_from_cop(cv, PL_curcop);
8605         CvSTASH_set(cv, PL_curstash);
8606     }
8607
8608     if (ps) {
8609         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8610         if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
8611     }
8612
8613     if (!block)
8614         goto attrs;
8615
8616     /* If we assign an optree to a PVCV, then we've defined a subroutine that
8617        the debugger could be able to set a breakpoint in, so signal to
8618        pp_entereval that it should not throw away any saved lines at scope
8619        exit.  */
8620
8621     PL_breakable_sub_gen++;
8622     CvROOT(cv) = block;
8623     CvROOT(cv)->op_private |= OPpREFCOUNTED;
8624     OpREFCNT_set(CvROOT(cv), 1);
8625     /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8626        itself has a refcount. */
8627     CvSLABBED_off(cv);
8628     OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8629 #ifdef PERL_DEBUG_READONLY_OPS
8630     slab = (OPSLAB *)CvSTART(cv);
8631 #endif
8632     CvSTART(cv) = start;
8633     CALL_PEEP(start);
8634     finalize_optree(CvROOT(cv));
8635     S_prune_chain_head(&CvSTART(cv));
8636
8637     /* now that optimizer has done its work, adjust pad values */
8638
8639     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8640
8641   attrs:
8642     if (attrs) {
8643         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8644         HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
8645                         ? GvSTASH(CvGV(cv))
8646                         : PL_curstash;
8647         if (!name) SAVEFREESV(cv);
8648         apply_attrs(stash, MUTABLE_SV(cv), attrs);
8649         if (!name) SvREFCNT_inc_simple_void_NN(cv);
8650     }
8651
8652     if (block && has_name) {
8653         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8654             SV * const tmpstr = cv_name(cv,NULL,0);
8655             GV * const db_postponed = gv_fetchpvs("DB::postponed",
8656                                                   GV_ADDMULTI, SVt_PVHV);
8657             HV *hv;
8658             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8659                                           CopFILE(PL_curcop),
8660                                           (long)PL_subline,
8661                                           (long)CopLINE(PL_curcop));
8662             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8663                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8664             hv = GvHVn(db_postponed);
8665             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8666                 CV * const pcv = GvCV(db_postponed);
8667                 if (pcv) {
8668                     dSP;
8669                     PUSHMARK(SP);
8670                     XPUSHs(tmpstr);
8671                     PUTBACK;
8672                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
8673                 }
8674             }
8675         }
8676
8677         if (name) {
8678             if (PL_parser && PL_parser->error_count)
8679                 clear_special_blocks(name, gv, cv);
8680             else
8681                 evanescent =
8682                     process_special_blocks(floor, name, gv, cv);
8683         }
8684     }
8685
8686   done:
8687     if (PL_parser)
8688         PL_parser->copline = NOLINE;
8689     LEAVE_SCOPE(floor);
8690     if (!evanescent) {
8691 #ifdef PERL_DEBUG_READONLY_OPS
8692       if (slab)
8693         Slab_to_ro(slab);
8694 #endif
8695       if (cv && name && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
8696         pad_add_weakref(cv);
8697     }
8698     return cv;
8699 }
8700
8701 STATIC void
8702 S_clear_special_blocks(pTHX_ const char *const fullname,
8703                        GV *const gv, CV *const cv) {
8704     const char *colon;
8705     const char *name;
8706
8707     PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
8708
8709     colon = strrchr(fullname,':');
8710     name = colon ? colon + 1 : fullname;
8711
8712     if ((*name == 'B' && strEQ(name, "BEGIN"))
8713         || (*name == 'E' && strEQ(name, "END"))
8714         || (*name == 'U' && strEQ(name, "UNITCHECK"))
8715         || (*name == 'C' && strEQ(name, "CHECK"))
8716         || (*name == 'I' && strEQ(name, "INIT"))) {
8717         if (!isGV(gv)) {
8718             (void)CvGV(cv);
8719             assert(isGV(gv));
8720         }
8721         GvCV_set(gv, NULL);
8722         SvREFCNT_dec_NN(MUTABLE_SV(cv));
8723     }
8724 }
8725
8726 /* Returns true if the sub has been freed.  */
8727 STATIC bool
8728 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
8729                          GV *const gv,
8730                          CV *const cv)
8731 {
8732     const char *const colon = strrchr(fullname,':');
8733     const char *const name = colon ? colon + 1 : fullname;
8734
8735     PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
8736
8737     if (*name == 'B') {
8738         if (strEQ(name, "BEGIN")) {
8739             const I32 oldscope = PL_scopestack_ix;
8740             dSP;
8741             (void)CvGV(cv);
8742             if (floor) LEAVE_SCOPE(floor);
8743             ENTER;
8744             PUSHSTACKi(PERLSI_REQUIRE);
8745             SAVECOPFILE(&PL_compiling);
8746             SAVECOPLINE(&PL_compiling);
8747             SAVEVPTR(PL_curcop);
8748
8749             DEBUG_x( dump_sub(gv) );
8750             Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
8751             GvCV_set(gv,0);             /* cv has been hijacked */
8752             call_list(oldscope, PL_beginav);
8753
8754             POPSTACK;
8755             LEAVE;
8756             return !PL_savebegin;
8757         }
8758         else
8759             return FALSE;
8760     } else {
8761         if (*name == 'E') {
8762             if strEQ(name, "END") {
8763                 DEBUG_x( dump_sub(gv) );
8764                 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
8765             } else
8766                 return FALSE;
8767         } else if (*name == 'U') {
8768             if (strEQ(name, "UNITCHECK")) {
8769                 /* It's never too late to run a unitcheck block */
8770                 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
8771             }
8772             else
8773                 return FALSE;
8774         } else if (*name == 'C') {
8775             if (strEQ(name, "CHECK")) {
8776                 if (PL_main_start)
8777                     /* diag_listed_as: Too late to run %s block */
8778                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8779                                    "Too late to run CHECK block");
8780                 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
8781             }
8782             else
8783                 return FALSE;
8784         } else if (*name == 'I') {
8785             if (strEQ(name, "INIT")) {
8786                 if (PL_main_start)
8787                     /* diag_listed_as: Too late to run %s block */
8788                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8789                                    "Too late to run INIT block");
8790                 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
8791             }
8792             else
8793                 return FALSE;
8794         } else
8795             return FALSE;
8796         DEBUG_x( dump_sub(gv) );
8797         (void)CvGV(cv);
8798         GvCV_set(gv,0);         /* cv has been hijacked */
8799         return FALSE;
8800     }
8801 }
8802
8803 /*
8804 =for apidoc newCONSTSUB
8805
8806 See L</newCONSTSUB_flags>.
8807
8808 =cut
8809 */
8810
8811 CV *
8812 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
8813 {
8814     return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
8815 }
8816
8817 /*
8818 =for apidoc newCONSTSUB_flags
8819
8820 Creates a constant sub equivalent to Perl S<C<sub FOO () { 123 }>> which is
8821 eligible for inlining at compile-time.
8822
8823 Currently, the only useful value for C<flags> is C<SVf_UTF8>.
8824
8825 The newly created subroutine takes ownership of a reference to the passed in
8826 SV.
8827
8828 Passing C<NULL> for SV creates a constant sub equivalent to S<C<sub BAR () {}>>,
8829 which won't be called if used as a destructor, but will suppress the overhead
8830 of a call to C<AUTOLOAD>.  (This form, however, isn't eligible for inlining at
8831 compile time.)
8832
8833 =cut
8834 */
8835
8836 CV *
8837 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
8838                              U32 flags, SV *sv)
8839 {
8840     CV* cv;
8841     const char *const file = CopFILE(PL_curcop);
8842
8843     ENTER;
8844
8845     if (IN_PERL_RUNTIME) {
8846         /* at runtime, it's not safe to manipulate PL_curcop: it may be
8847          * an op shared between threads. Use a non-shared COP for our
8848          * dirty work */
8849          SAVEVPTR(PL_curcop);
8850          SAVECOMPILEWARNINGS();
8851          PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
8852          PL_curcop = &PL_compiling;
8853     }
8854     SAVECOPLINE(PL_curcop);
8855     CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
8856
8857     SAVEHINTS();
8858     PL_hints &= ~HINT_BLOCK_SCOPE;
8859
8860     if (stash) {
8861         SAVEGENERICSV(PL_curstash);
8862         PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
8863     }
8864
8865     /* Protect sv against leakage caused by fatal warnings. */
8866     if (sv) SAVEFREESV(sv);
8867
8868     /* file becomes the CvFILE. For an XS, it's usually static storage,
8869        and so doesn't get free()d.  (It's expected to be from the C pre-
8870        processor __FILE__ directive). But we need a dynamically allocated one,
8871        and we need it to get freed.  */
8872     cv = newXS_len_flags(name, len,
8873                          sv && SvTYPE(sv) == SVt_PVAV
8874                              ? const_av_xsub
8875                              : const_sv_xsub,
8876                          file ? file : "", "",
8877                          &sv, XS_DYNAMIC_FILENAME | flags);
8878     CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
8879     CvCONST_on(cv);
8880
8881     LEAVE;
8882
8883     return cv;
8884 }
8885
8886 /*
8887 =for apidoc U||newXS
8888
8889 Used by C<xsubpp> to hook up XSUBs as Perl subs.  C<filename> needs to be
8890 static storage, as it is used directly as CvFILE(), without a copy being made.
8891
8892 =cut
8893 */
8894
8895 CV *
8896 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
8897 {
8898     PERL_ARGS_ASSERT_NEWXS;
8899     return newXS_len_flags(
8900         name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
8901     );
8902 }
8903
8904 CV *
8905 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
8906                  const char *const filename, const char *const proto,
8907                  U32 flags)
8908 {
8909     PERL_ARGS_ASSERT_NEWXS_FLAGS;
8910     return newXS_len_flags(
8911        name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
8912     );
8913 }
8914
8915 CV *
8916 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
8917 {
8918     PERL_ARGS_ASSERT_NEWXS_DEFFILE;
8919     return newXS_len_flags(
8920         name, strlen(name), subaddr, NULL, NULL, NULL, 0
8921     );
8922 }
8923
8924 CV *
8925 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
8926                            XSUBADDR_t subaddr, const char *const filename,
8927                            const char *const proto, SV **const_svp,
8928                            U32 flags)
8929 {
8930     CV *cv;
8931     bool interleave = FALSE;
8932
8933     PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
8934
8935     {
8936         GV * const gv = gv_fetchpvn(
8937                             name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
8938                             name ? len : PL_curstash ? sizeof("__ANON__") - 1:
8939                                 sizeof("__ANON__::__ANON__") - 1,
8940                             GV_ADDMULTI | flags, SVt_PVCV);
8941
8942         if ((cv = (name ? GvCV(gv) : NULL))) {
8943             if (GvCVGEN(gv)) {
8944                 /* just a cached method */
8945                 SvREFCNT_dec(cv);
8946                 cv = NULL;
8947             }
8948             else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
8949                 /* already defined (or promised) */
8950                 /* Redundant check that allows us to avoid creating an SV
8951                    most of the time: */
8952                 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
8953                     report_redefined_cv(newSVpvn_flags(
8954                                          name,len,(flags&SVf_UTF8)|SVs_TEMP
8955                                         ),
8956                                         cv, const_svp);
8957                 }
8958                 interleave = TRUE;
8959                 ENTER;
8960                 SAVEFREESV(cv);
8961                 cv = NULL;
8962             }
8963         }
8964
8965         if (cv)                         /* must reuse cv if autoloaded */
8966             cv_undef(cv);
8967         else {
8968             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8969             if (name) {
8970                 GvCV_set(gv,cv);
8971                 GvCVGEN(gv) = 0;
8972                 if (HvENAME_HEK(GvSTASH(gv)))
8973                     gv_method_changed(gv); /* newXS */
8974             }
8975         }
8976
8977         CvGV_set(cv, gv);
8978         if(filename) {
8979             /* XSUBs can't be perl lang/perl5db.pl debugged
8980             if (PERLDB_LINE_OR_SAVESRC)
8981                 (void)gv_fetchfile(filename); */
8982             assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
8983             if (flags & XS_DYNAMIC_FILENAME) {
8984                 CvDYNFILE_on(cv);
8985                 CvFILE(cv) = savepv(filename);
8986             } else {
8987             /* NOTE: not copied, as it is expected to be an external constant string */
8988                 CvFILE(cv) = (char *)filename;
8989             }
8990         } else {
8991             assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
8992             CvFILE(cv) = (char*)PL_xsubfilename;
8993         }
8994         CvISXSUB_on(cv);
8995         CvXSUB(cv) = subaddr;
8996 #ifndef PERL_IMPLICIT_CONTEXT
8997         CvHSCXT(cv) = &PL_stack_sp;
8998 #else
8999         PoisonPADLIST(cv);
9000 #endif
9001
9002         if (name)
9003             process_special_blocks(0, name, gv, cv);
9004         else
9005             CvANON_on(cv);
9006     } /* <- not a conditional branch */
9007
9008
9009     sv_setpv(MUTABLE_SV(cv), proto);
9010     if (interleave) LEAVE;
9011     return cv;
9012 }
9013
9014 CV *
9015 Perl_newSTUB(pTHX_ GV *gv, bool fake)
9016 {
9017     CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9018     GV *cvgv;
9019     PERL_ARGS_ASSERT_NEWSTUB;
9020     assert(!GvCVu(gv));
9021     GvCV_set(gv, cv);
9022     GvCVGEN(gv) = 0;
9023     if (!fake && HvENAME_HEK(GvSTASH(gv)))
9024         gv_method_changed(gv);
9025     if (SvFAKE(gv)) {
9026         cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
9027         SvFAKE_off(cvgv);
9028     }
9029     else cvgv = gv;
9030     CvGV_set(cv, cvgv);
9031     CvFILE_set_from_cop(cv, PL_curcop);
9032     CvSTASH_set(cv, PL_curstash);
9033     GvMULTI_on(gv);
9034     return cv;
9035 }
9036
9037 void
9038 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
9039 {
9040     CV *cv;
9041
9042     GV *gv;
9043
9044     if (PL_parser && PL_parser->error_count) {
9045         op_free(block);
9046         goto finish;
9047     }
9048
9049     gv = o
9050         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
9051         : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
9052
9053     GvMULTI_on(gv);
9054     if ((cv = GvFORM(gv))) {
9055         if (ckWARN(WARN_REDEFINE)) {
9056             const line_t oldline = CopLINE(PL_curcop);
9057             if (PL_parser && PL_parser->copline != NOLINE)
9058                 CopLINE_set(PL_curcop, PL_parser->copline);
9059             if (o) {
9060                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9061                             "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
9062             } else {
9063                 /* diag_listed_as: Format %s redefined */
9064                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9065                             "Format STDOUT redefined");
9066             }
9067             CopLINE_set(PL_curcop, oldline);
9068         }
9069         SvREFCNT_dec(cv);
9070     }
9071     cv = PL_compcv;
9072     GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
9073     CvGV_set(cv, gv);
9074     CvFILE_set_from_cop(cv, PL_curcop);
9075
9076
9077     pad_tidy(padtidy_FORMAT);
9078     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
9079     CvROOT(cv)->op_private |= OPpREFCOUNTED;
9080     OpREFCNT_set(CvROOT(cv), 1);
9081     CvSTART(cv) = LINKLIST(CvROOT(cv));
9082     CvROOT(cv)->op_next = 0;
9083     CALL_PEEP(CvSTART(cv));
9084     finalize_optree(CvROOT(cv));
9085     S_prune_chain_head(&CvSTART(cv));
9086     cv_forget_slab(cv);
9087
9088   finish:
9089     op_free(o);
9090     if (PL_parser)
9091         PL_parser->copline = NOLINE;
9092     LEAVE_SCOPE(floor);
9093     PL_compiling.cop_seq = 0;
9094 }
9095
9096 OP *
9097 Perl_newANONLIST(pTHX_ OP *o)
9098 {
9099     return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
9100 }
9101
9102 OP *
9103 Perl_newANONHASH(pTHX_ OP *o)
9104 {
9105     return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
9106 }
9107
9108 OP *
9109 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
9110 {
9111     return newANONATTRSUB(floor, proto, NULL, block);
9112 }
9113
9114 OP *
9115 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
9116 {
9117     SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
9118     OP * anoncode =
9119         newSVOP(OP_ANONCODE, 0,
9120                 cv);
9121     if (CvANONCONST(cv))
9122         anoncode = newUNOP(OP_ANONCONST, 0,
9123                            op_convert_list(OP_ENTERSUB,
9124                                            OPf_STACKED|OPf_WANT_SCALAR,
9125                                            anoncode));
9126     return newUNOP(OP_REFGEN, 0, anoncode);
9127 }
9128
9129 OP *
9130 Perl_oopsAV(pTHX_ OP *o)
9131 {
9132     dVAR;
9133
9134     PERL_ARGS_ASSERT_OOPSAV;
9135
9136     switch (o->op_type) {
9137     case OP_PADSV:
9138     case OP_PADHV:
9139         OpTYPE_set(o, OP_PADAV);
9140         return ref(o, OP_RV2AV);
9141
9142     case OP_RV2SV:
9143     case OP_RV2HV:
9144         OpTYPE_set(o, OP_RV2AV);
9145         ref(o, OP_RV2AV);
9146         break;
9147
9148     default:
9149         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
9150         break;
9151     }
9152     return o;
9153 }
9154
9155 OP *
9156 Perl_oopsHV(pTHX_ OP *o)
9157 {
9158     dVAR;
9159
9160     PERL_ARGS_ASSERT_OOPSHV;
9161
9162     switch (o->op_type) {
9163     case OP_PADSV:
9164     case OP_PADAV:
9165         OpTYPE_set(o, OP_PADHV);
9166         return ref(o, OP_RV2HV);
9167
9168     case OP_RV2SV:
9169     case OP_RV2AV:
9170         OpTYPE_set(o, OP_RV2HV);
9171         ref(o, OP_RV2HV);
9172         break;
9173
9174     default:
9175         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
9176         break;
9177     }
9178     return o;
9179 }
9180
9181 OP *
9182 Perl_newAVREF(pTHX_ OP *o)
9183 {
9184     dVAR;
9185
9186     PERL_ARGS_ASSERT_NEWAVREF;
9187
9188     if (o->op_type == OP_PADANY) {
9189         OpTYPE_set(o, OP_PADAV);
9190         return o;
9191     }
9192     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
9193         Perl_croak(aTHX_ "Can't use an array as a reference");
9194     }
9195     return newUNOP(OP_RV2AV, 0, scalar(o));
9196 }
9197
9198 OP *
9199 Perl_newGVREF(pTHX_ I32 type, OP *o)
9200 {
9201     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
9202         return newUNOP(OP_NULL, 0, o);
9203     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
9204 }
9205
9206 OP *
9207 Perl_newHVREF(pTHX_ OP *o)
9208 {
9209     dVAR;
9210
9211     PERL_ARGS_ASSERT_NEWHVREF;
9212
9213     if (o->op_type == OP_PADANY) {
9214         OpTYPE_set(o, OP_PADHV);
9215         return o;
9216     }
9217     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
9218         Perl_croak(aTHX_ "Can't use a hash as a reference");
9219     }
9220     return newUNOP(OP_RV2HV, 0, scalar(o));
9221 }
9222
9223 OP *
9224 Perl_newCVREF(pTHX_ I32 flags, OP *o)
9225 {
9226     if (o->op_type == OP_PADANY) {
9227         dVAR;
9228         OpTYPE_set(o, OP_PADCV);
9229     }
9230     return newUNOP(OP_RV2CV, flags, scalar(o));
9231 }
9232
9233 OP *
9234 Perl_newSVREF(pTHX_ OP *o)
9235 {
9236     dVAR;
9237
9238     PERL_ARGS_ASSERT_NEWSVREF;
9239
9240     if (o->op_type == OP_PADANY) {
9241         OpTYPE_set(o, OP_PADSV);
9242         scalar(o);
9243         return o;
9244     }
9245     return newUNOP(OP_RV2SV, 0, scalar(o));
9246 }
9247
9248 /* Check routines. See the comments at the top of this file for details
9249  * on when these are called */
9250
9251 OP *
9252 Perl_ck_anoncode(pTHX_ OP *o)
9253 {
9254     PERL_ARGS_ASSERT_CK_ANONCODE;
9255
9256     cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
9257     cSVOPo->op_sv = NULL;
9258     return o;
9259 }
9260
9261 static void
9262 S_io_hints(pTHX_ OP *o)
9263 {
9264 #if O_BINARY != 0 || O_TEXT != 0
9265     HV * const table =
9266         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
9267     if (table) {
9268         SV **svp = hv_fetchs(table, "open_IN", FALSE);
9269         if (svp && *svp) {
9270             STRLEN len = 0;
9271             const char *d = SvPV_const(*svp, len);
9272             const I32 mode = mode_from_discipline(d, len);
9273             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9274 #  if O_BINARY != 0
9275             if (mode & O_BINARY)
9276                 o->op_private |= OPpOPEN_IN_RAW;
9277 #  endif
9278 #  if O_TEXT != 0
9279             if (mode & O_TEXT)
9280                 o->op_private |= OPpOPEN_IN_CRLF;
9281 #  endif
9282         }
9283
9284         svp = hv_fetchs(table, "open_OUT", FALSE);
9285         if (svp && *svp) {
9286             STRLEN len = 0;
9287             const char *d = SvPV_const(*svp, len);
9288             const I32 mode = mode_from_discipline(d, len);
9289             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9290 #  if O_BINARY != 0
9291             if (mode & O_BINARY)
9292                 o->op_private |= OPpOPEN_OUT_RAW;
9293 #  endif
9294 #  if O_TEXT != 0
9295             if (mode & O_TEXT)
9296                 o->op_private |= OPpOPEN_OUT_CRLF;
9297 #  endif
9298         }
9299     }
9300 #else
9301     PERL_UNUSED_CONTEXT;
9302     PERL_UNUSED_ARG(o);
9303 #endif
9304 }
9305
9306 OP *
9307 Perl_ck_backtick(pTHX_ OP *o)
9308 {
9309     GV *gv;
9310     OP *newop = NULL;
9311     OP *sibl;
9312     PERL_ARGS_ASSERT_CK_BACKTICK;
9313     /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
9314     if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
9315      && (gv = gv_override("readpipe",8)))
9316     {
9317         /* detach rest of siblings from o and its first child */
9318         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
9319         newop = S_new_entersubop(aTHX_ gv, sibl);
9320     }
9321     else if (!(o->op_flags & OPf_KIDS))
9322         newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
9323     if (newop) {
9324         op_free(o);
9325         return newop;
9326     }
9327     S_io_hints(aTHX_ o);
9328     return o;
9329 }
9330
9331 OP *
9332 Perl_ck_bitop(pTHX_ OP *o)
9333 {
9334     PERL_ARGS_ASSERT_CK_BITOP;
9335
9336     o->op_private = (U8)(PL_hints & HINT_INTEGER);
9337
9338     if (o->op_type == OP_NBIT_OR     || o->op_type == OP_SBIT_OR
9339      || o->op_type == OP_NBIT_XOR    || o->op_type == OP_SBIT_XOR
9340      || o->op_type == OP_NBIT_AND    || o->op_type == OP_SBIT_AND
9341      || o->op_type == OP_NCOMPLEMENT || o->op_type == OP_SCOMPLEMENT)
9342         Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__BITWISE),
9343                               "The bitwise feature is experimental");
9344     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
9345             && OP_IS_INFIX_BIT(o->op_type))
9346     {
9347         const OP * const left = cBINOPo->op_first;
9348         const OP * const right = OpSIBLING(left);
9349         if ((OP_IS_NUMCOMPARE(left->op_type) &&
9350                 (left->op_flags & OPf_PARENS) == 0) ||
9351             (OP_IS_NUMCOMPARE(right->op_type) &&
9352                 (right->op_flags & OPf_PARENS) == 0))
9353             Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
9354                           "Possible precedence problem on bitwise %s operator",
9355                            o->op_type ==  OP_BIT_OR
9356                          ||o->op_type == OP_NBIT_OR  ? "|"
9357                         :  o->op_type ==  OP_BIT_AND
9358                          ||o->op_type == OP_NBIT_AND ? "&"
9359                         :  o->op_type ==  OP_BIT_XOR
9360                          ||o->op_type == OP_NBIT_XOR ? "^"
9361                         :  o->op_type == OP_SBIT_OR  ? "|."
9362                         :  o->op_type == OP_SBIT_AND ? "&." : "^."
9363                            );
9364     }
9365     return o;
9366 }
9367
9368 PERL_STATIC_INLINE bool
9369 is_dollar_bracket(pTHX_ const OP * const o)
9370 {
9371     const OP *kid;
9372     PERL_UNUSED_CONTEXT;
9373     return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
9374         && (kid = cUNOPx(o)->op_first)
9375         && kid->op_type == OP_GV
9376         && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
9377 }
9378
9379 OP *
9380 Perl_ck_cmp(pTHX_ OP *o)
9381 {
9382     PERL_ARGS_ASSERT_CK_CMP;
9383     if (ckWARN(WARN_SYNTAX)) {
9384         const OP *kid = cUNOPo->op_first;
9385         if (kid &&
9386             (
9387                 (   is_dollar_bracket(aTHX_ kid)
9388                  && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
9389                 )
9390              || (   kid->op_type == OP_CONST
9391                  && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
9392                 )
9393            )
9394         )
9395             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9396                         "$[ used in %s (did you mean $] ?)", OP_DESC(o));
9397     }
9398     return o;
9399 }
9400
9401 OP *
9402 Perl_ck_concat(pTHX_ OP *o)
9403 {
9404     const OP * const kid = cUNOPo->op_first;
9405
9406     PERL_ARGS_ASSERT_CK_CONCAT;
9407     PERL_UNUSED_CONTEXT;
9408
9409     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
9410             !(kUNOP->op_first->op_flags & OPf_MOD))
9411         o->op_flags |= OPf_STACKED;
9412     return o;
9413 }
9414
9415 OP *
9416 Perl_ck_spair(pTHX_ OP *o)
9417 {
9418     dVAR;
9419
9420     PERL_ARGS_ASSERT_CK_SPAIR;
9421
9422     if (o->op_flags & OPf_KIDS) {
9423         OP* newop;
9424         OP* kid;
9425         OP* kidkid;
9426         const OPCODE type = o->op_type;
9427         o = modkids(ck_fun(o), type);
9428         kid    = cUNOPo->op_first;
9429         kidkid = kUNOP->op_first;
9430         newop = OpSIBLING(kidkid);
9431         if (newop) {
9432             const OPCODE type = newop->op_type;
9433             if (OpHAS_SIBLING(newop))
9434                 return o;
9435             if (o->op_type == OP_REFGEN
9436              && (  type == OP_RV2CV
9437                 || (  !(newop->op_flags & OPf_PARENS)
9438                    && (  type == OP_RV2AV || type == OP_PADAV
9439                       || type == OP_RV2HV || type == OP_PADHV))))
9440                 NOOP; /* OK (allow srefgen for \@a and \%h) */
9441             else if (OP_GIMME(newop,0) != G_SCALAR)
9442                 return o;
9443         }
9444         /* excise first sibling */
9445         op_sibling_splice(kid, NULL, 1, NULL);
9446         op_free(kidkid);
9447     }
9448     /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
9449      * and OP_CHOMP into OP_SCHOMP */
9450     o->op_ppaddr = PL_ppaddr[++o->op_type];
9451     return ck_fun(o);
9452 }
9453
9454 OP *
9455 Perl_ck_delete(pTHX_ OP *o)
9456 {
9457     PERL_ARGS_ASSERT_CK_DELETE;
9458
9459     o = ck_fun(o);
9460     o->op_private = 0;
9461     if (o->op_flags & OPf_KIDS) {
9462         OP * const kid = cUNOPo->op_first;
9463         switch (kid->op_type) {
9464         case OP_ASLICE:
9465             o->op_flags |= OPf_SPECIAL;
9466             /* FALLTHROUGH */
9467         case OP_HSLICE:
9468             o->op_private |= OPpSLICE;
9469             break;
9470         case OP_AELEM:
9471             o->op_flags |= OPf_SPECIAL;
9472             /* FALLTHROUGH */
9473         case OP_HELEM:
9474             break;
9475         case OP_KVASLICE:
9476             Perl_croak(aTHX_ "delete argument is index/value array slice,"
9477                              " use array slice");
9478         case OP_KVHSLICE:
9479             Perl_croak(aTHX_ "delete argument is key/value hash slice, use"
9480                              " hash slice");
9481         default:
9482             Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
9483                              "element or slice");
9484         }
9485         if (kid->op_private & OPpLVAL_INTRO)
9486             o->op_private |= OPpLVAL_INTRO;
9487         op_null(kid);
9488     }
9489     return o;
9490 }
9491
9492 OP *
9493 Perl_ck_eof(pTHX_ OP *o)
9494 {
9495     PERL_ARGS_ASSERT_CK_EOF;
9496
9497     if (o->op_flags & OPf_KIDS) {
9498         OP *kid;
9499         if (cLISTOPo->op_first->op_type == OP_STUB) {
9500             OP * const newop
9501                 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
9502             op_free(o);
9503             o = newop;
9504         }
9505         o = ck_fun(o);
9506         kid = cLISTOPo->op_first;
9507         if (kid->op_type == OP_RV2GV)
9508             kid->op_private |= OPpALLOW_FAKE;
9509     }
9510     return o;
9511 }
9512
9513 OP *
9514 Perl_ck_eval(pTHX_ OP *o)
9515 {
9516     dVAR;
9517
9518     PERL_ARGS_ASSERT_CK_EVAL;
9519
9520     PL_hints |= HINT_BLOCK_SCOPE;
9521     if (o->op_flags & OPf_KIDS) {
9522         SVOP * const kid = (SVOP*)cUNOPo->op_first;
9523         assert(kid);
9524
9525         if (o->op_type == OP_ENTERTRY) {
9526             LOGOP *enter;
9527
9528             /* cut whole sibling chain free from o */
9529             op_sibling_splice(o, NULL, -1, NULL);
9530             op_free(o);
9531
9532             enter = S_alloc_LOGOP(aTHX_ OP_ENTERTRY, NULL, NULL);
9533
9534             /* establish postfix order */
9535             enter->op_next = (OP*)enter;
9536
9537             o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
9538             OpTYPE_set(o, OP_LEAVETRY);
9539             enter->op_other = o;
9540             return o;
9541         }
9542         else {
9543             scalar((OP*)kid);
9544             S_set_haseval(aTHX);
9545         }
9546     }
9547     else {
9548         const U8 priv = o->op_private;
9549         op_free(o);
9550         /* the newUNOP will recursively call ck_eval(), which will handle
9551          * all the stuff at the end of this function, like adding
9552          * OP_HINTSEVAL
9553          */
9554         return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
9555     }
9556     o->op_targ = (PADOFFSET)PL_hints;
9557     if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
9558     if ((PL_hints & HINT_LOCALIZE_HH) != 0
9559      && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
9560         /* Store a copy of %^H that pp_entereval can pick up. */
9561         OP *hhop = newSVOP(OP_HINTSEVAL, 0,
9562                            MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
9563         /* append hhop to only child  */
9564         op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
9565
9566         o->op_private |= OPpEVAL_HAS_HH;
9567     }
9568     if (!(o->op_private & OPpEVAL_BYTES)
9569          && FEATURE_UNIEVAL_IS_ENABLED)
9570             o->op_private |= OPpEVAL_UNICODE;
9571     return o;
9572 }
9573
9574 OP *
9575 Perl_ck_exec(pTHX_ OP *o)
9576 {
9577     PERL_ARGS_ASSERT_CK_EXEC;
9578
9579     if (o->op_flags & OPf_STACKED) {
9580         OP *kid;
9581         o = ck_fun(o);
9582         kid = OpSIBLING(cUNOPo->op_first);
9583         if (kid->op_type == OP_RV2GV)
9584             op_null(kid);
9585     }
9586     else
9587         o = listkids(o);
9588     return o;
9589 }
9590
9591 OP *
9592 Perl_ck_exists(pTHX_ OP *o)
9593 {
9594     PERL_ARGS_ASSERT_CK_EXISTS;
9595
9596     o = ck_fun(o);
9597     if (o->op_flags & OPf_KIDS) {
9598         OP * const kid = cUNOPo->op_first;
9599         if (kid->op_type == OP_ENTERSUB) {
9600             (void) ref(kid, o->op_type);
9601             if (kid->op_type != OP_RV2CV
9602                         && !(PL_parser && PL_parser->error_count))
9603                 Perl_croak(aTHX_
9604                           "exists argument is not a subroutine name");
9605             o->op_private |= OPpEXISTS_SUB;
9606         }
9607         else if (kid->op_type == OP_AELEM)
9608             o->op_flags |= OPf_SPECIAL;
9609         else if (kid->op_type != OP_HELEM)
9610             Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
9611                              "element or a subroutine");
9612         op_null(kid);
9613     }
9614     return o;
9615 }
9616
9617 OP *
9618 Perl_ck_rvconst(pTHX_ OP *o)
9619 {
9620     dVAR;
9621     SVOP * const kid = (SVOP*)cUNOPo->op_first;
9622
9623     PERL_ARGS_ASSERT_CK_RVCONST;
9624
9625     o->op_private |= (PL_hints & HINT_STRICT_REFS);
9626
9627     if (kid->op_type == OP_CONST) {
9628         int iscv;
9629         GV *gv;
9630         SV * const kidsv = kid->op_sv;
9631
9632         /* Is it a constant from cv_const_sv()? */
9633         if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
9634             return o;
9635         }
9636         if (SvTYPE(kidsv) == SVt_PVAV) return o;
9637         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
9638             const char *badthing;
9639             switch (o->op_type) {
9640             case OP_RV2SV:
9641                 badthing = "a SCALAR";
9642                 break;
9643             case OP_RV2AV:
9644                 badthing = "an ARRAY";
9645                 break;
9646             case OP_RV2HV:
9647                 badthing = "a HASH";
9648                 break;
9649             default:
9650                 badthing = NULL;
9651                 break;
9652             }
9653             if (badthing)
9654                 Perl_croak(aTHX_
9655                            "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
9656                            SVfARG(kidsv), badthing);
9657         }
9658         /*
9659          * This is a little tricky.  We only want to add the symbol if we
9660          * didn't add it in the lexer.  Otherwise we get duplicate strict
9661          * warnings.  But if we didn't add it in the lexer, we must at
9662          * least pretend like we wanted to add it even if it existed before,
9663          * or we get possible typo warnings.  OPpCONST_ENTERED says
9664          * whether the lexer already added THIS instance of this symbol.
9665          */
9666         iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
9667         gv = gv_fetchsv(kidsv,
9668                 o->op_type == OP_RV2CV
9669                         && o->op_private & OPpMAY_RETURN_CONSTANT
9670                     ? GV_NOEXPAND
9671                     : iscv | !(kid->op_private & OPpCONST_ENTERED),
9672                 iscv
9673                     ? SVt_PVCV
9674                     : o->op_type == OP_RV2SV
9675                         ? SVt_PV
9676                         : o->op_type == OP_RV2AV
9677                             ? SVt_PVAV
9678                             : o->op_type == OP_RV2HV
9679                                 ? SVt_PVHV
9680                                 : SVt_PVGV);
9681         if (gv) {
9682             if (!isGV(gv)) {
9683                 assert(iscv);
9684                 assert(SvROK(gv));
9685                 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
9686                   && SvTYPE(SvRV(gv)) != SVt_PVCV)
9687                     gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
9688             }
9689             OpTYPE_set(kid, OP_GV);
9690             SvREFCNT_dec(kid->op_sv);
9691 #ifdef USE_ITHREADS
9692             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
9693             STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
9694             kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
9695             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
9696             PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
9697 #else
9698             kid->op_sv = SvREFCNT_inc_simple_NN(gv);
9699 #endif
9700             kid->op_private = 0;
9701             /* FAKE globs in the symbol table cause weird bugs (#77810) */
9702             SvFAKE_off(gv);
9703         }
9704     }
9705     return o;
9706 }
9707
9708 OP *
9709 Perl_ck_ftst(pTHX_ OP *o)
9710 {
9711     dVAR;
9712     const I32 type = o->op_type;
9713
9714     PERL_ARGS_ASSERT_CK_FTST;
9715
9716     if (o->op_flags & OPf_REF) {
9717         NOOP;
9718     }
9719     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
9720         SVOP * const kid = (SVOP*)cUNOPo->op_first;
9721         const OPCODE kidtype = kid->op_type;
9722
9723         if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
9724          && !kid->op_folded) {
9725             OP * const newop = newGVOP(type, OPf_REF,
9726                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
9727             op_free(o);
9728             return newop;
9729         }
9730         scalar((OP *) kid);
9731         if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
9732             o->op_private |= OPpFT_ACCESS;
9733         if (type != OP_STAT && type != OP_LSTAT
9734             && PL_check[kidtype] == Perl_ck_ftst
9735             && kidtype != OP_STAT && kidtype != OP_LSTAT
9736         ) {
9737             o->op_private |= OPpFT_STACKED;
9738             kid->op_private |= OPpFT_STACKING;
9739             if (kidtype == OP_FTTTY && (
9740                    !(kid->op_private & OPpFT_STACKED)
9741                 || kid->op_private & OPpFT_AFTER_t
9742                ))
9743                 o->op_private |= OPpFT_AFTER_t;
9744         }
9745     }
9746     else {
9747         op_free(o);
9748         if (type == OP_FTTTY)
9749             o = newGVOP(type, OPf_REF, PL_stdingv);
9750         else
9751             o = newUNOP(type, 0, newDEFSVOP());
9752     }
9753     return o;
9754 }
9755
9756 OP *
9757 Perl_ck_fun(pTHX_ OP *o)
9758 {
9759     const int type = o->op_type;
9760     I32 oa = PL_opargs[type] >> OASHIFT;
9761
9762     PERL_ARGS_ASSERT_CK_FUN;
9763
9764     if (o->op_flags & OPf_STACKED) {
9765         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
9766             oa &= ~OA_OPTIONAL;
9767         else
9768             return no_fh_allowed(o);
9769     }
9770
9771     if (o->op_flags & OPf_KIDS) {
9772         OP *prev_kid = NULL;
9773         OP *kid = cLISTOPo->op_first;
9774         I32 numargs = 0;
9775         bool seen_optional = FALSE;
9776
9777         if (kid->op_type == OP_PUSHMARK ||
9778             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
9779         {
9780             prev_kid = kid;
9781             kid = OpSIBLING(kid);
9782         }
9783         if (kid && kid->op_type == OP_COREARGS) {
9784             bool optional = FALSE;
9785             while (oa) {
9786                 numargs++;
9787                 if (oa & OA_OPTIONAL) optional = TRUE;
9788                 oa = oa >> 4;
9789             }
9790             if (optional) o->op_private |= numargs;
9791             return o;
9792         }
9793
9794         while (oa) {
9795             if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
9796                 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
9797                     kid = newDEFSVOP();
9798                     /* append kid to chain */
9799                     op_sibling_splice(o, prev_kid, 0, kid);
9800                 }
9801                 seen_optional = TRUE;
9802             }
9803             if (!kid) break;
9804
9805             numargs++;
9806             switch (oa & 7) {
9807             case OA_SCALAR:
9808                 /* list seen where single (scalar) arg expected? */
9809                 if (numargs == 1 && !(oa >> 4)
9810                     && kid->op_type == OP_LIST && type != OP_SCALAR)
9811                 {
9812                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
9813                 }
9814                 if (type != OP_DELETE) scalar(kid);
9815                 break;
9816             case OA_LIST:
9817                 if (oa < 16) {
9818                     kid = 0;
9819                     continue;
9820                 }
9821                 else
9822                     list(kid);
9823                 break;
9824             case OA_AVREF:
9825                 if ((type == OP_PUSH || type == OP_UNSHIFT)
9826                     && !OpHAS_SIBLING(kid))
9827                     Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
9828                                    "Useless use of %s with no values",
9829                                    PL_op_desc[type]);
9830
9831                 if (kid->op_type == OP_CONST
9832                       && (  !SvROK(cSVOPx_sv(kid))
9833                          || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV  )
9834                         )
9835                     bad_type_pv(numargs, "array", o, kid);
9836                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
9837                     yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
9838                                          PL_op_desc[type]), 0);
9839                 }
9840                 else {
9841                     op_lvalue(kid, type);
9842                 }
9843                 break;
9844             case OA_HVREF:
9845                 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
9846                     bad_type_pv(numargs, "hash", o, kid);
9847                 op_lvalue(kid, type);
9848                 break;
9849             case OA_CVREF:
9850                 {
9851                     /* replace kid with newop in chain */
9852                     OP * const newop =
9853                         S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
9854                     newop->op_next = newop;
9855                     kid = newop;
9856                 }
9857                 break;
9858             case OA_FILEREF:
9859                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
9860                     if (kid->op_type == OP_CONST &&
9861                         (kid->op_private & OPpCONST_BARE))
9862                     {
9863                         OP * const newop = newGVOP(OP_GV, 0,
9864                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
9865                         /* replace kid with newop in chain */
9866                         op_sibling_splice(o, prev_kid, 1, newop);
9867                         op_free(kid);
9868                         kid = newop;
9869                     }
9870                     else if (kid->op_type == OP_READLINE) {
9871                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
9872                         bad_type_pv(numargs, "HANDLE", o, kid);
9873                     }
9874                     else {
9875                         I32 flags = OPf_SPECIAL;
9876                         I32 priv = 0;
9877                         PADOFFSET targ = 0;
9878
9879                         /* is this op a FH constructor? */
9880                         if (is_handle_constructor(o,numargs)) {
9881                             const char *name = NULL;
9882                             STRLEN len = 0;
9883                             U32 name_utf8 = 0;
9884                             bool want_dollar = TRUE;
9885
9886                             flags = 0;
9887                             /* Set a flag to tell rv2gv to vivify
9888                              * need to "prove" flag does not mean something
9889                              * else already - NI-S 1999/05/07
9890                              */
9891                             priv = OPpDEREF;
9892                             if (kid->op_type == OP_PADSV) {
9893                                 PADNAME * const pn
9894                                     = PAD_COMPNAME_SV(kid->op_targ);
9895                                 name = PadnamePV (pn);
9896                                 len  = PadnameLEN(pn);
9897                                 name_utf8 = PadnameUTF8(pn);
9898                             }
9899                             else if (kid->op_type == OP_RV2SV
9900                                      && kUNOP->op_first->op_type == OP_GV)
9901                             {
9902                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
9903                                 name = GvNAME(gv);
9904                                 len = GvNAMELEN(gv);
9905                                 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
9906                             }
9907                             else if (kid->op_type == OP_AELEM
9908                                      || kid->op_type == OP_HELEM)
9909                             {
9910                                  OP *firstop;
9911                                  OP *op = ((BINOP*)kid)->op_first;
9912                                  name = NULL;
9913                                  if (op) {
9914                                       SV *tmpstr = NULL;
9915                                       const char * const a =
9916                                            kid->op_type == OP_AELEM ?
9917                                            "[]" : "{}";
9918                                       if (((op->op_type == OP_RV2AV) ||
9919                                            (op->op_type == OP_RV2HV)) &&
9920                                           (firstop = ((UNOP*)op)->op_first) &&
9921                                           (firstop->op_type == OP_GV)) {
9922                                            /* packagevar $a[] or $h{} */
9923                                            GV * const gv = cGVOPx_gv(firstop);
9924                                            if (gv)
9925                                                 tmpstr =
9926                                                      Perl_newSVpvf(aTHX_
9927                                                                    "%s%c...%c",
9928                                                                    GvNAME(gv),
9929                                                                    a[0], a[1]);
9930                                       }
9931                                       else if (op->op_type == OP_PADAV
9932                                                || op->op_type == OP_PADHV) {
9933                                            /* lexicalvar $a[] or $h{} */
9934                                            const char * const padname =
9935                                                 PAD_COMPNAME_PV(op->op_targ);
9936                                            if (padname)
9937                                                 tmpstr =
9938                                                      Perl_newSVpvf(aTHX_
9939                                                                    "%s%c...%c",
9940                                                                    padname + 1,
9941                                                                    a[0], a[1]);
9942                                       }
9943                                       if (tmpstr) {
9944                                            name = SvPV_const(tmpstr, len);
9945                                            name_utf8 = SvUTF8(tmpstr);
9946                                            sv_2mortal(tmpstr);
9947                                       }
9948                                  }
9949                                  if (!name) {
9950                                       name = "__ANONIO__";
9951                                       len = 10;
9952                                       want_dollar = FALSE;
9953                                  }
9954                                  op_lvalue(kid, type);
9955                             }
9956                             if (name) {
9957                                 SV *namesv;
9958                                 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
9959                                 namesv = PAD_SVl(targ);
9960                                 if (want_dollar && *name != '$')
9961                                     sv_setpvs(namesv, "$");
9962                                 else
9963                                     sv_setpvs(namesv, "");
9964                                 sv_catpvn(namesv, name, len);
9965                                 if ( name_utf8 ) SvUTF8_on(namesv);
9966                             }
9967                         }
9968                         scalar(kid);
9969                         kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
9970                                     OP_RV2GV, flags);
9971                         kid->op_targ = targ;
9972                         kid->op_private |= priv;
9973                     }
9974                 }
9975                 scalar(kid);
9976                 break;
9977             case OA_SCALARREF:
9978                 if ((type == OP_UNDEF || type == OP_POS)
9979                     && numargs == 1 && !(oa >> 4)
9980                     && kid->op_type == OP_LIST)
9981                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
9982                 op_lvalue(scalar(kid), type);
9983                 break;
9984             }
9985             oa >>= 4;
9986             prev_kid = kid;
9987             kid = OpSIBLING(kid);
9988         }
9989         /* FIXME - should the numargs or-ing move after the too many
9990          * arguments check? */
9991         o->op_private |= numargs;
9992         if (kid)
9993             return too_many_arguments_pv(o,OP_DESC(o), 0);
9994         listkids(o);
9995     }
9996     else if (PL_opargs[type] & OA_DEFGV) {
9997         /* Ordering of these two is important to keep f_map.t passing.  */
9998         op_free(o);
9999         return newUNOP(type, 0, newDEFSVOP());
10000     }
10001
10002     if (oa) {
10003         while (oa & OA_OPTIONAL)
10004             oa >>= 4;
10005         if (oa && oa != OA_LIST)
10006             return too_few_arguments_pv(o,OP_DESC(o), 0);
10007     }
10008     return o;
10009 }
10010
10011 OP *
10012 Perl_ck_glob(pTHX_ OP *o)
10013 {
10014     GV *gv;
10015
10016     PERL_ARGS_ASSERT_CK_GLOB;
10017
10018     o = ck_fun(o);
10019     if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
10020         op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
10021
10022     if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
10023     {
10024         /* convert
10025          *     glob
10026          *       \ null - const(wildcard)
10027          * into
10028          *     null
10029          *       \ enter
10030          *            \ list
10031          *                 \ mark - glob - rv2cv
10032          *                             |        \ gv(CORE::GLOBAL::glob)
10033          *                             |
10034          *                              \ null - const(wildcard)
10035          */
10036         o->op_flags |= OPf_SPECIAL;
10037         o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
10038         o = S_new_entersubop(aTHX_ gv, o);
10039         o = newUNOP(OP_NULL, 0, o);
10040         o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
10041         return o;
10042     }
10043     else o->op_flags &= ~OPf_SPECIAL;
10044 #if !defined(PERL_EXTERNAL_GLOB)
10045     if (!PL_globhook) {
10046         ENTER;
10047         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
10048                                newSVpvs("File::Glob"), NULL, NULL, NULL);
10049         LEAVE;
10050     }
10051 #endif /* !PERL_EXTERNAL_GLOB */
10052     gv = (GV *)newSV(0);
10053     gv_init(gv, 0, "", 0, 0);
10054     gv_IOadd(gv);
10055     op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
10056     SvREFCNT_dec_NN(gv); /* newGVOP increased it */
10057     scalarkids(o);
10058     return o;
10059 }
10060
10061 OP *
10062 Perl_ck_grep(pTHX_ OP *o)
10063 {
10064     LOGOP *gwop;
10065     OP *kid;
10066     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
10067
10068     PERL_ARGS_ASSERT_CK_GREP;
10069
10070     /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
10071
10072     if (o->op_flags & OPf_STACKED) {
10073         kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
10074         if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
10075             return no_fh_allowed(o);
10076         o->op_flags &= ~OPf_STACKED;
10077     }
10078     kid = OpSIBLING(cLISTOPo->op_first);
10079     if (type == OP_MAPWHILE)
10080         list(kid);
10081     else
10082         scalar(kid);
10083     o = ck_fun(o);
10084     if (PL_parser && PL_parser->error_count)
10085         return o;
10086     kid = OpSIBLING(cLISTOPo->op_first);
10087     if (kid->op_type != OP_NULL)
10088         Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
10089     kid = kUNOP->op_first;
10090
10091     gwop = S_alloc_LOGOP(aTHX_ type, o, LINKLIST(kid));
10092     kid->op_next = (OP*)gwop;
10093     o->op_private = gwop->op_private = 0;
10094     gwop->op_targ = pad_alloc(type, SVs_PADTMP);
10095
10096     kid = OpSIBLING(cLISTOPo->op_first);
10097     for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
10098         op_lvalue(kid, OP_GREPSTART);
10099
10100     return (OP*)gwop;
10101 }
10102
10103 OP *
10104 Perl_ck_index(pTHX_ OP *o)
10105 {
10106     PERL_ARGS_ASSERT_CK_INDEX;
10107
10108     if (o->op_flags & OPf_KIDS) {
10109         OP *kid = OpSIBLING(cLISTOPo->op_first);        /* get past pushmark */
10110         if (kid)
10111             kid = OpSIBLING(kid);                       /* get past "big" */
10112         if (kid && kid->op_type == OP_CONST) {
10113             const bool save_taint = TAINT_get;
10114             SV *sv = kSVOP->op_sv;
10115             if ((!SvPOK(sv) || SvNIOKp(sv)) && SvOK(sv) && !SvROK(sv)) {
10116                 sv = newSV(0);
10117                 sv_copypv(sv, kSVOP->op_sv);
10118                 SvREFCNT_dec_NN(kSVOP->op_sv);
10119                 kSVOP->op_sv = sv;
10120             }
10121             if (SvOK(sv)) fbm_compile(sv, 0);
10122             TAINT_set(save_taint);
10123 #ifdef NO_TAINT_SUPPORT
10124             PERL_UNUSED_VAR(save_taint);
10125 #endif
10126         }
10127     }
10128     return ck_fun(o);
10129 }
10130
10131 OP *
10132 Perl_ck_lfun(pTHX_ OP *o)
10133 {
10134     const OPCODE type = o->op_type;
10135
10136     PERL_ARGS_ASSERT_CK_LFUN;
10137
10138     return modkids(ck_fun(o), type);
10139 }
10140
10141 OP *
10142 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
10143 {
10144     PERL_ARGS_ASSERT_CK_DEFINED;
10145
10146     if ((o->op_flags & OPf_KIDS)) {
10147         switch (cUNOPo->op_first->op_type) {
10148         case OP_RV2AV:
10149         case OP_PADAV:
10150             Perl_croak(aTHX_ "Can't use 'defined(@array)'"
10151                              " (Maybe you should just omit the defined()?)");
10152         break;
10153         case OP_RV2HV:
10154         case OP_PADHV:
10155             Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
10156                              " (Maybe you should just omit the defined()?)");
10157             break;
10158         default:
10159             /* no warning */
10160             break;
10161         }
10162     }
10163     return ck_rfun(o);
10164 }
10165
10166 OP *
10167 Perl_ck_readline(pTHX_ OP *o)
10168 {
10169     PERL_ARGS_ASSERT_CK_READLINE;
10170
10171     if (o->op_flags & OPf_KIDS) {
10172          OP *kid = cLISTOPo->op_first;
10173          if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
10174     }
10175     else {
10176         OP * const newop
10177             = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
10178         op_free(o);
10179         return newop;
10180     }
10181     return o;
10182 }
10183
10184 OP *
10185 Perl_ck_rfun(pTHX_ OP *o)
10186 {
10187     const OPCODE type = o->op_type;
10188
10189     PERL_ARGS_ASSERT_CK_RFUN;
10190
10191     return refkids(ck_fun(o), type);
10192 }
10193
10194 OP *
10195 Perl_ck_listiob(pTHX_ OP *o)
10196 {
10197     OP *kid;
10198
10199     PERL_ARGS_ASSERT_CK_LISTIOB;
10200
10201     kid = cLISTOPo->op_first;
10202     if (!kid) {
10203         o = force_list(o, 1);
10204         kid = cLISTOPo->op_first;
10205     }
10206     if (kid->op_type == OP_PUSHMARK)
10207         kid = OpSIBLING(kid);
10208     if (kid && o->op_flags & OPf_STACKED)
10209         kid = OpSIBLING(kid);
10210     else if (kid && !OpHAS_SIBLING(kid)) {              /* print HANDLE; */
10211         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
10212          && !kid->op_folded) {
10213             o->op_flags |= OPf_STACKED; /* make it a filehandle */
10214             scalar(kid);
10215             /* replace old const op with new OP_RV2GV parent */
10216             kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
10217                                         OP_RV2GV, OPf_REF);
10218             kid = OpSIBLING(kid);
10219         }
10220     }
10221
10222     if (!kid)
10223         op_append_elem(o->op_type, o, newDEFSVOP());
10224
10225     if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
10226     return listkids(o);
10227 }
10228
10229 OP *
10230 Perl_ck_smartmatch(pTHX_ OP *o)
10231 {
10232     dVAR;
10233     PERL_ARGS_ASSERT_CK_SMARTMATCH;
10234     if (0 == (o->op_flags & OPf_SPECIAL)) {
10235         OP *first  = cBINOPo->op_first;
10236         OP *second = OpSIBLING(first);
10237
10238         /* Implicitly take a reference to an array or hash */
10239
10240         /* remove the original two siblings, then add back the
10241          * (possibly different) first and second sibs.
10242          */
10243         op_sibling_splice(o, NULL, 1, NULL);
10244         op_sibling_splice(o, NULL, 1, NULL);
10245         first  = ref_array_or_hash(first);
10246         second = ref_array_or_hash(second);
10247         op_sibling_splice(o, NULL, 0, second);
10248         op_sibling_splice(o, NULL, 0, first);
10249
10250         /* Implicitly take a reference to a regular expression */
10251         if (first->op_type == OP_MATCH) {
10252             OpTYPE_set(first, OP_QR);
10253         }
10254         if (second->op_type == OP_MATCH) {
10255             OpTYPE_set(second, OP_QR);
10256         }
10257     }
10258
10259     return o;
10260 }
10261
10262
10263 static OP *
10264 S_maybe_targlex(pTHX_ OP *o)
10265 {
10266     OP * const kid = cLISTOPo->op_first;
10267     /* has a disposable target? */
10268     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
10269         && !(kid->op_flags & OPf_STACKED)
10270         /* Cannot steal the second time! */
10271         && !(kid->op_private & OPpTARGET_MY)
10272         )
10273     {
10274         OP * const kkid = OpSIBLING(kid);
10275
10276         /* Can just relocate the target. */
10277         if (kkid && kkid->op_type == OP_PADSV
10278             && (!(kkid->op_private & OPpLVAL_INTRO)
10279                || kkid->op_private & OPpPAD_STATE))
10280         {
10281             kid->op_targ = kkid->op_targ;
10282             kkid->op_targ = 0;
10283             /* Now we do not need PADSV and SASSIGN.
10284              * Detach kid and free the rest. */
10285             op_sibling_splice(o, NULL, 1, NULL);
10286             op_free(o);
10287             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
10288             return kid;
10289         }
10290     }
10291     return o;
10292 }
10293
10294 OP *
10295 Perl_ck_sassign(pTHX_ OP *o)
10296 {
10297     dVAR;
10298     OP * const kid = cLISTOPo->op_first;
10299
10300     PERL_ARGS_ASSERT_CK_SASSIGN;
10301
10302     if (OpHAS_SIBLING(kid)) {
10303         OP *kkid = OpSIBLING(kid);
10304         /* For state variable assignment with attributes, kkid is a list op
10305            whose op_last is a padsv. */
10306         if ((kkid->op_type == OP_PADSV ||
10307              (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
10308               (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
10309              )
10310             )
10311                 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
10312                     == (OPpLVAL_INTRO|OPpPAD_STATE)) {
10313             const PADOFFSET target = kkid->op_targ;
10314             OP *const other = newOP(OP_PADSV,
10315                                     kkid->op_flags
10316                                     | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
10317             OP *const first = newOP(OP_NULL, 0);
10318             OP *const nullop =
10319                 newCONDOP(0, first, o, other);
10320             /* XXX targlex disabled for now; see ticket #124160
10321                 newCONDOP(0, first, S_maybe_targlex(aTHX_ o), other);
10322              */
10323             OP *const condop = first->op_next;
10324
10325             OpTYPE_set(condop, OP_ONCE);
10326             other->op_targ = target;
10327             nullop->op_flags |= OPf_WANT_SCALAR;
10328
10329             /* Store the initializedness of state vars in a separate
10330                pad entry.  */
10331             condop->op_targ =
10332               pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
10333             /* hijacking PADSTALE for uninitialized state variables */
10334             SvPADSTALE_on(PAD_SVl(condop->op_targ));
10335
10336             return nullop;
10337         }
10338     }
10339     return S_maybe_targlex(aTHX_ o);
10340 }
10341
10342 OP *
10343 Perl_ck_match(pTHX_ OP *o)
10344 {
10345     PERL_UNUSED_CONTEXT;
10346     PERL_ARGS_ASSERT_CK_MATCH;
10347
10348     if (o->op_type == OP_MATCH || o->op_type == OP_QR)
10349         o->op_private |= OPpRUNTIME;
10350     return o;
10351 }
10352
10353 OP *
10354 Perl_ck_method(pTHX_ OP *o)
10355 {
10356     SV *sv, *methsv, *rclass;
10357     const char* method;
10358     char* compatptr;
10359     int utf8;
10360     STRLEN len, nsplit = 0, i;
10361     OP* new_op;
10362     OP * const kid = cUNOPo->op_first;
10363
10364     PERL_ARGS_ASSERT_CK_METHOD;
10365     if (kid->op_type != OP_CONST) return o;
10366
10367     sv = kSVOP->op_sv;
10368
10369     /* replace ' with :: */
10370     while ((compatptr = strchr(SvPVX(sv), '\''))) {
10371         *compatptr = ':';
10372         sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
10373     }
10374
10375     method = SvPVX_const(sv);
10376     len = SvCUR(sv);
10377     utf8 = SvUTF8(sv) ? -1 : 1;
10378
10379     for (i = len - 1; i > 0; --i) if (method[i] == ':') {
10380         nsplit = i+1;
10381         break;
10382     }
10383
10384     methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
10385
10386     if (!nsplit) { /* $proto->method() */
10387         op_free(o);
10388         return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
10389     }
10390
10391     if (nsplit == 7 && memEQ(method, "SUPER::", nsplit)) { /* $proto->SUPER::method() */
10392         op_free(o);
10393         return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
10394     }
10395
10396     /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
10397     if (nsplit >= 9 && strnEQ(method+nsplit-9, "::SUPER::", 9)) {
10398         rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
10399         new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
10400     } else {
10401         rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
10402         new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
10403     }
10404 #ifdef USE_ITHREADS
10405     op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
10406 #else
10407     cMETHOPx(new_op)->op_rclass_sv = rclass;
10408 #endif
10409     op_free(o);
10410     return new_op;
10411 }
10412
10413 OP *
10414 Perl_ck_null(pTHX_ OP *o)
10415 {
10416     PERL_ARGS_ASSERT_CK_NULL;
10417     PERL_UNUSED_CONTEXT;
10418     return o;
10419 }
10420
10421 OP *
10422 Perl_ck_open(pTHX_ OP *o)
10423 {
10424     PERL_ARGS_ASSERT_CK_OPEN;
10425
10426     S_io_hints(aTHX_ o);
10427     {
10428          /* In case of three-arg dup open remove strictness
10429           * from the last arg if it is a bareword. */
10430          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
10431          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
10432          OP *oa;
10433          const char *mode;
10434
10435          if ((last->op_type == OP_CONST) &&             /* The bareword. */
10436              (last->op_private & OPpCONST_BARE) &&
10437              (last->op_private & OPpCONST_STRICT) &&
10438              (oa = OpSIBLING(first)) &&         /* The fh. */
10439              (oa = OpSIBLING(oa)) &&                    /* The mode. */
10440              (oa->op_type == OP_CONST) &&
10441              SvPOK(((SVOP*)oa)->op_sv) &&
10442              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
10443              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
10444              (last == OpSIBLING(oa)))                   /* The bareword. */
10445               last->op_private &= ~OPpCONST_STRICT;
10446     }
10447     return ck_fun(o);
10448 }
10449
10450 OP *
10451 Perl_ck_prototype(pTHX_ OP *o)
10452 {
10453     PERL_ARGS_ASSERT_CK_PROTOTYPE;
10454     if (!(o->op_flags & OPf_KIDS)) {
10455         op_free(o);
10456         return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
10457     }
10458     return o;
10459 }
10460
10461 OP *
10462 Perl_ck_refassign(pTHX_ OP *o)
10463 {
10464     OP * const right = cLISTOPo->op_first;
10465     OP * const left = OpSIBLING(right);
10466     OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
10467     bool stacked = 0;
10468
10469     PERL_ARGS_ASSERT_CK_REFASSIGN;
10470     assert (left);
10471     assert (left->op_type == OP_SREFGEN);
10472
10473     o->op_private = 0;
10474     /* we use OPpPAD_STATE in refassign to mean either of those things,
10475      * and the code assumes the two flags occupy the same bit position
10476      * in the various ops below */
10477     assert(OPpPAD_STATE == OPpOUR_INTRO);
10478
10479     switch (varop->op_type) {
10480     case OP_PADAV:
10481         o->op_private |= OPpLVREF_AV;
10482         goto settarg;
10483     case OP_PADHV:
10484         o->op_private |= OPpLVREF_HV;
10485         /* FALLTHROUGH */
10486     case OP_PADSV:
10487       settarg:
10488         o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
10489         o->op_targ = varop->op_targ;
10490         varop->op_targ = 0;
10491         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
10492         break;
10493
10494     case OP_RV2AV:
10495         o->op_private |= OPpLVREF_AV;
10496         goto checkgv;
10497         NOT_REACHED; /* NOTREACHED */
10498     case OP_RV2HV:
10499         o->op_private |= OPpLVREF_HV;
10500         /* FALLTHROUGH */
10501     case OP_RV2SV:
10502       checkgv:
10503         o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
10504         if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
10505       detach_and_stack:
10506         /* Point varop to its GV kid, detached.  */
10507         varop = op_sibling_splice(varop, NULL, -1, NULL);
10508         stacked = TRUE;
10509         break;
10510     case OP_RV2CV: {
10511         OP * const kidparent =
10512             OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
10513         OP * const kid = cUNOPx(kidparent)->op_first;
10514         o->op_private |= OPpLVREF_CV;
10515         if (kid->op_type == OP_GV) {
10516             varop = kidparent;
10517             goto detach_and_stack;
10518         }
10519         if (kid->op_type != OP_PADCV)   goto bad;
10520         o->op_targ = kid->op_targ;
10521         kid->op_targ = 0;
10522         break;
10523     }
10524     case OP_AELEM:
10525     case OP_HELEM:
10526         o->op_private |= (varop->op_private & OPpLVAL_INTRO);
10527         o->op_private |= OPpLVREF_ELEM;
10528         op_null(varop);
10529         stacked = TRUE;
10530         /* Detach varop.  */
10531         op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
10532         break;
10533     default:
10534       bad:
10535         /* diag_listed_as: Can't modify reference to %s in %s assignment */
10536         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
10537                                 "assignment",
10538                                  OP_DESC(varop)));
10539         return o;
10540     }
10541     if (!FEATURE_REFALIASING_IS_ENABLED)
10542         Perl_croak(aTHX_
10543                   "Experimental aliasing via reference not enabled");
10544     Perl_ck_warner_d(aTHX_
10545                      packWARN(WARN_EXPERIMENTAL__REFALIASING),
10546                     "Aliasing via reference is experimental");
10547     if (stacked) {
10548         o->op_flags |= OPf_STACKED;
10549         op_sibling_splice(o, right, 1, varop);
10550     }
10551     else {
10552         o->op_flags &=~ OPf_STACKED;
10553         op_sibling_splice(o, right, 1, NULL);
10554     }
10555     op_free(left);
10556     return o;
10557 }
10558
10559 OP *
10560 Perl_ck_repeat(pTHX_ OP *o)
10561 {
10562     PERL_ARGS_ASSERT_CK_REPEAT;
10563
10564     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
10565         OP* kids;
10566         o->op_private |= OPpREPEAT_DOLIST;
10567         kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
10568         kids = force_list(kids, 1); /* promote it to a list */
10569         op_sibling_splice(o, NULL, 0, kids); /* and add back */
10570     }
10571     else
10572         scalar(o);
10573     return o;
10574 }
10575
10576 OP *
10577 Perl_ck_require(pTHX_ OP *o)
10578 {
10579     GV* gv;
10580
10581     PERL_ARGS_ASSERT_CK_REQUIRE;
10582
10583     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
10584         SVOP * const kid = (SVOP*)cUNOPo->op_first;
10585         HEK *hek;
10586         U32 hash;
10587         char *s;
10588         STRLEN len;
10589         if (kid->op_type == OP_CONST) {
10590           SV * const sv = kid->op_sv;
10591           U32 const was_readonly = SvREADONLY(sv);
10592           if (kid->op_private & OPpCONST_BARE) {
10593             dVAR;
10594             const char *end;
10595
10596             if (was_readonly) {
10597                     SvREADONLY_off(sv);
10598             }
10599             if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
10600
10601             s = SvPVX(sv);
10602             len = SvCUR(sv);
10603             end = s + len;
10604             for (; s < end; s++) {
10605                 if (*s == ':' && s[1] == ':') {
10606                     *s = '/';
10607                     Move(s+2, s+1, end - s - 1, char);
10608                     --end;
10609                 }
10610             }
10611             SvEND_set(sv, end);
10612             sv_catpvs(sv, ".pm");
10613             PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
10614             hek = share_hek(SvPVX(sv),
10615                             (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
10616                             hash);
10617             sv_sethek(sv, hek);
10618             unshare_hek(hek);
10619             SvFLAGS(sv) |= was_readonly;
10620           }
10621           else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
10622                 && !SvVOK(sv)) {
10623             s = SvPV(sv, len);
10624             if (SvREFCNT(sv) > 1) {
10625                 kid->op_sv = newSVpvn_share(
10626                     s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
10627                 SvREFCNT_dec_NN(sv);
10628             }
10629             else {
10630                 dVAR;
10631                 if (was_readonly) SvREADONLY_off(sv);
10632                 PERL_HASH(hash, s, len);
10633                 hek = share_hek(s,
10634                                 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
10635                                 hash);
10636                 sv_sethek(sv, hek);
10637                 unshare_hek(hek);
10638                 SvFLAGS(sv) |= was_readonly;
10639             }
10640           }
10641         }
10642     }
10643
10644     if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
10645         /* handle override, if any */
10646      && (gv = gv_override("require", 7))) {
10647         OP *kid, *newop;
10648         if (o->op_flags & OPf_KIDS) {
10649             kid = cUNOPo->op_first;
10650             op_sibling_splice(o, NULL, -1, NULL);
10651         }
10652         else {
10653             kid = newDEFSVOP();
10654         }
10655         op_free(o);
10656         newop = S_new_entersubop(aTHX_ gv, kid);
10657         return newop;
10658     }
10659
10660     return ck_fun(o);
10661 }
10662
10663 OP *
10664 Perl_ck_return(pTHX_ OP *o)
10665 {
10666     OP *kid;
10667
10668     PERL_ARGS_ASSERT_CK_RETURN;
10669
10670     kid = OpSIBLING(cLISTOPo->op_first);
10671     if (CvLVALUE(PL_compcv)) {
10672         for (; kid; kid = OpSIBLING(kid))
10673             op_lvalue(kid, OP_LEAVESUBLV);
10674     }
10675
10676     return o;
10677 }
10678
10679 OP *
10680 Perl_ck_select(pTHX_ OP *o)
10681 {
10682     dVAR;
10683     OP* kid;
10684
10685     PERL_ARGS_ASSERT_CK_SELECT;
10686
10687     if (o->op_flags & OPf_KIDS) {
10688         kid = OpSIBLING(cLISTOPo->op_first);     /* get past pushmark */
10689         if (kid && OpHAS_SIBLING(kid)) {
10690             OpTYPE_set(o, OP_SSELECT);
10691             o = ck_fun(o);
10692             return fold_constants(op_integerize(op_std_init(o)));
10693         }
10694     }
10695     o = ck_fun(o);
10696     kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
10697     if (kid && kid->op_type == OP_RV2GV)
10698         kid->op_private &= ~HINT_STRICT_REFS;
10699     return o;
10700 }
10701
10702 OP *
10703 Perl_ck_shift(pTHX_ OP *o)
10704 {
10705     const I32 type = o->op_type;
10706
10707     PERL_ARGS_ASSERT_CK_SHIFT;
10708
10709     if (!(o->op_flags & OPf_KIDS)) {
10710         OP *argop;
10711
10712         if (!CvUNIQUE(PL_compcv)) {
10713             o->op_flags |= OPf_SPECIAL;
10714             return o;
10715         }
10716
10717         argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
10718         op_free(o);
10719         return newUNOP(type, 0, scalar(argop));
10720     }
10721     return scalar(ck_fun(o));
10722 }
10723
10724 OP *
10725 Perl_ck_sort(pTHX_ OP *o)
10726 {
10727     OP *firstkid;
10728     OP *kid;
10729     HV * const hinthv =
10730         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
10731     U8 stacked;
10732
10733     PERL_ARGS_ASSERT_CK_SORT;
10734
10735     if (hinthv) {
10736             SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
10737             if (svp) {
10738                 const I32 sorthints = (I32)SvIV(*svp);
10739                 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
10740                     o->op_private |= OPpSORT_QSORT;
10741                 if ((sorthints & HINT_SORT_STABLE) != 0)
10742                     o->op_private |= OPpSORT_STABLE;
10743             }
10744     }
10745
10746     if (o->op_flags & OPf_STACKED)
10747         simplify_sort(o);
10748     firstkid = OpSIBLING(cLISTOPo->op_first);           /* get past pushmark */
10749
10750     if ((stacked = o->op_flags & OPf_STACKED)) {        /* may have been cleared */
10751         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
10752
10753         /* if the first arg is a code block, process it and mark sort as
10754          * OPf_SPECIAL */
10755         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
10756             LINKLIST(kid);
10757             if (kid->op_type == OP_LEAVE)
10758                     op_null(kid);                       /* wipe out leave */
10759             /* Prevent execution from escaping out of the sort block. */
10760             kid->op_next = 0;
10761
10762             /* provide scalar context for comparison function/block */
10763             kid = scalar(firstkid);
10764             kid->op_next = kid;
10765             o->op_flags |= OPf_SPECIAL;
10766         }
10767         else if (kid->op_type == OP_CONST
10768               && kid->op_private & OPpCONST_BARE) {
10769             char tmpbuf[256];
10770             STRLEN len;
10771             PADOFFSET off;
10772             const char * const name = SvPV(kSVOP_sv, len);
10773             *tmpbuf = '&';
10774             assert (len < 256);
10775             Copy(name, tmpbuf+1, len, char);
10776             off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv));
10777             if (off != NOT_IN_PAD) {
10778                 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
10779                     SV * const fq =
10780                         newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
10781                     sv_catpvs(fq, "::");
10782                     sv_catsv(fq, kSVOP_sv);
10783                     SvREFCNT_dec_NN(kSVOP_sv);
10784                     kSVOP->op_sv = fq;
10785                 }
10786                 else {
10787                     OP * const padop = newOP(OP_PADCV, 0);
10788                     padop->op_targ = off;
10789                     /* replace the const op with the pad op */
10790                     op_sibling_splice(firstkid, NULL, 1, padop);
10791                     op_free(kid);
10792                 }
10793             }
10794         }
10795
10796         firstkid = OpSIBLING(firstkid);
10797     }
10798
10799     for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
10800         /* provide list context for arguments */
10801         list(kid);
10802         if (stacked)
10803             op_lvalue(kid, OP_GREPSTART);
10804     }
10805
10806     return o;
10807 }
10808
10809 /* for sort { X } ..., where X is one of
10810  *   $a <=> $b, $b <= $a, $a cmp $b, $b cmp $a
10811  * elide the second child of the sort (the one containing X),
10812  * and set these flags as appropriate
10813         OPpSORT_NUMERIC;
10814         OPpSORT_INTEGER;
10815         OPpSORT_DESCEND;
10816  * Also, check and warn on lexical $a, $b.
10817  */
10818
10819 STATIC void
10820 S_simplify_sort(pTHX_ OP *o)
10821 {
10822     OP *kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
10823     OP *k;
10824     int descending;
10825     GV *gv;
10826     const char *gvname;
10827     bool have_scopeop;
10828
10829     PERL_ARGS_ASSERT_SIMPLIFY_SORT;
10830
10831     kid = kUNOP->op_first;                              /* get past null */
10832     if (!(have_scopeop = kid->op_type == OP_SCOPE)
10833      && kid->op_type != OP_LEAVE)
10834         return;
10835     kid = kLISTOP->op_last;                             /* get past scope */
10836     switch(kid->op_type) {
10837         case OP_NCMP:
10838         case OP_I_NCMP:
10839         case OP_SCMP:
10840             if (!have_scopeop) goto padkids;
10841             break;
10842         default:
10843             return;
10844     }
10845     k = kid;                                            /* remember this node*/
10846     if (kBINOP->op_first->op_type != OP_RV2SV
10847      || kBINOP->op_last ->op_type != OP_RV2SV)
10848     {
10849         /*
10850            Warn about my($a) or my($b) in a sort block, *if* $a or $b is
10851            then used in a comparison.  This catches most, but not
10852            all cases.  For instance, it catches
10853                sort { my($a); $a <=> $b }
10854            but not
10855                sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
10856            (although why you'd do that is anyone's guess).
10857         */
10858
10859        padkids:
10860         if (!ckWARN(WARN_SYNTAX)) return;
10861         kid = kBINOP->op_first;
10862         do {
10863             if (kid->op_type == OP_PADSV) {
10864                 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
10865                 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
10866                  && (  PadnamePV(name)[1] == 'a'
10867                     || PadnamePV(name)[1] == 'b'  ))
10868                     /* diag_listed_as: "my %s" used in sort comparison */
10869                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10870                                      "\"%s %s\" used in sort comparison",
10871                                       PadnameIsSTATE(name)
10872                                         ? "state"
10873                                         : "my",
10874                                       PadnamePV(name));
10875             }
10876         } while ((kid = OpSIBLING(kid)));
10877         return;
10878     }
10879     kid = kBINOP->op_first;                             /* get past cmp */
10880     if (kUNOP->op_first->op_type != OP_GV)
10881         return;
10882     kid = kUNOP->op_first;                              /* get past rv2sv */
10883     gv = kGVOP_gv;
10884     if (GvSTASH(gv) != PL_curstash)
10885         return;
10886     gvname = GvNAME(gv);
10887     if (*gvname == 'a' && gvname[1] == '\0')
10888         descending = 0;
10889     else if (*gvname == 'b' && gvname[1] == '\0')
10890         descending = 1;
10891     else
10892         return;
10893
10894     kid = k;                                            /* back to cmp */
10895     /* already checked above that it is rv2sv */
10896     kid = kBINOP->op_last;                              /* down to 2nd arg */
10897     if (kUNOP->op_first->op_type != OP_GV)
10898         return;
10899     kid = kUNOP->op_first;                              /* get past rv2sv */
10900     gv = kGVOP_gv;
10901     if (GvSTASH(gv) != PL_curstash)
10902         return;
10903     gvname = GvNAME(gv);
10904     if ( descending
10905          ? !(*gvname == 'a' && gvname[1] == '\0')
10906          : !(*gvname == 'b' && gvname[1] == '\0'))
10907         return;
10908     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
10909     if (descending)
10910         o->op_private |= OPpSORT_DESCEND;
10911     if (k->op_type == OP_NCMP)
10912         o->op_private |= OPpSORT_NUMERIC;
10913     if (k->op_type == OP_I_NCMP)
10914         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
10915     kid = OpSIBLING(cLISTOPo->op_first);
10916     /* cut out and delete old block (second sibling) */
10917     op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
10918     op_free(kid);
10919 }
10920
10921 OP *
10922 Perl_ck_split(pTHX_ OP *o)
10923 {
10924     dVAR;
10925     OP *kid;
10926
10927     PERL_ARGS_ASSERT_CK_SPLIT;
10928
10929     if (o->op_flags & OPf_STACKED)
10930         return no_fh_allowed(o);
10931
10932     kid = cLISTOPo->op_first;
10933     if (kid->op_type != OP_NULL)
10934         Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
10935     /* delete leading NULL node, then add a CONST if no other nodes */
10936     op_sibling_splice(o, NULL, 1,
10937         OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
10938     op_free(kid);
10939     kid = cLISTOPo->op_first;
10940
10941     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
10942         /* remove kid, and replace with new optree */
10943         op_sibling_splice(o, NULL, 1, NULL);
10944         /* OPf_SPECIAL is used to trigger split " " behavior */
10945         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, NULL, 0, 0);
10946         op_sibling_splice(o, NULL, 0, kid);
10947     }
10948     OpTYPE_set(kid, OP_PUSHRE);
10949     /* target implies @ary=..., so wipe it */
10950     kid->op_targ = 0;
10951     scalar(kid);
10952     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
10953       Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
10954                      "Use of /g modifier is meaningless in split");
10955     }
10956
10957     if (!OpHAS_SIBLING(kid))
10958         op_append_elem(OP_SPLIT, o, newDEFSVOP());
10959
10960     kid = OpSIBLING(kid);
10961     assert(kid);
10962     scalar(kid);
10963
10964     if (!OpHAS_SIBLING(kid))
10965     {
10966         op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
10967         o->op_private |= OPpSPLIT_IMPLIM;
10968     }
10969     assert(OpHAS_SIBLING(kid));
10970
10971     kid = OpSIBLING(kid);
10972     scalar(kid);
10973
10974     if (OpHAS_SIBLING(kid))
10975         return too_many_arguments_pv(o,OP_DESC(o), 0);
10976
10977     return o;
10978 }
10979
10980 OP *
10981 Perl_ck_stringify(pTHX_ OP *o)
10982 {
10983     OP * const kid = OpSIBLING(cUNOPo->op_first);
10984     PERL_ARGS_ASSERT_CK_STRINGIFY;
10985     if ((   kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
10986          || kid->op_type == OP_LC   || kid->op_type == OP_LCFIRST
10987          || kid->op_type == OP_UC   || kid->op_type == OP_UCFIRST)
10988         && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
10989     {
10990         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
10991         op_free(o);
10992         return kid;
10993     }
10994     return ck_fun(o);
10995 }
10996
10997 OP *
10998 Perl_ck_join(pTHX_ OP *o)
10999 {
11000     OP * const kid = OpSIBLING(cLISTOPo->op_first);
11001
11002     PERL_ARGS_ASSERT_CK_JOIN;
11003
11004     if (kid && kid->op_type == OP_MATCH) {
11005         if (ckWARN(WARN_SYNTAX)) {
11006             const REGEXP *re = PM_GETRE(kPMOP);
11007             const SV *msg = re
11008                     ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
11009                                             SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
11010                     : newSVpvs_flags( "STRING", SVs_TEMP );
11011             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11012                         "/%"SVf"/ should probably be written as \"%"SVf"\"",
11013                         SVfARG(msg), SVfARG(msg));
11014         }
11015     }
11016     if (kid
11017      && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
11018         || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
11019         || (  kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
11020            && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
11021     {
11022         const OP * const bairn = OpSIBLING(kid); /* the list */
11023         if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
11024          && OP_GIMME(bairn,0) == G_SCALAR)
11025         {
11026             OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
11027                                      op_sibling_splice(o, kid, 1, NULL));
11028             op_free(o);
11029             return ret;
11030         }
11031     }
11032
11033     return ck_fun(o);
11034 }
11035
11036 /*
11037 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
11038
11039 Examines an op, which is expected to identify a subroutine at runtime,
11040 and attempts to determine at compile time which subroutine it identifies.
11041 This is normally used during Perl compilation to determine whether
11042 a prototype can be applied to a function call.  C<cvop> is the op
11043 being considered, normally an C<rv2cv> op.  A pointer to the identified
11044 subroutine is returned, if it could be determined statically, and a null
11045 pointer is returned if it was not possible to determine statically.
11046
11047 Currently, the subroutine can be identified statically if the RV that the
11048 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
11049 A C<gv> op is suitable if the GV's CV slot is populated.  A C<const> op is
11050 suitable if the constant value must be an RV pointing to a CV.  Details of
11051 this process may change in future versions of Perl.  If the C<rv2cv> op
11052 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
11053 the subroutine statically: this flag is used to suppress compile-time
11054 magic on a subroutine call, forcing it to use default runtime behaviour.
11055
11056 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
11057 of a GV reference is modified.  If a GV was examined and its CV slot was
11058 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
11059 If the op is not optimised away, and the CV slot is later populated with
11060 a subroutine having a prototype, that flag eventually triggers the warning
11061 "called too early to check prototype".
11062
11063 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
11064 of returning a pointer to the subroutine it returns a pointer to the
11065 GV giving the most appropriate name for the subroutine in this context.
11066 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
11067 (C<CvANON>) subroutine that is referenced through a GV it will be the
11068 referencing GV.  The resulting C<GV*> is cast to C<CV*> to be returned.
11069 A null pointer is returned as usual if there is no statically-determinable
11070 subroutine.
11071
11072 =cut
11073 */
11074
11075 /* shared by toke.c:yylex */
11076 CV *
11077 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
11078 {
11079     PADNAME *name = PAD_COMPNAME(off);
11080     CV *compcv = PL_compcv;
11081     while (PadnameOUTER(name)) {
11082         assert(PARENT_PAD_INDEX(name));
11083         compcv = CvOUTSIDE(compcv);
11084         name = PadlistNAMESARRAY(CvPADLIST(compcv))
11085                 [off = PARENT_PAD_INDEX(name)];
11086     }
11087     assert(!PadnameIsOUR(name));
11088     if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
11089         return PadnamePROTOCV(name);
11090     }
11091     return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
11092 }
11093
11094 CV *
11095 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
11096 {
11097     OP *rvop;
11098     CV *cv;
11099     GV *gv;
11100     PERL_ARGS_ASSERT_RV2CV_OP_CV;
11101     if (flags & ~RV2CVOPCV_FLAG_MASK)
11102         Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
11103     if (cvop->op_type != OP_RV2CV)
11104         return NULL;
11105     if (cvop->op_private & OPpENTERSUB_AMPER)
11106         return NULL;
11107     if (!(cvop->op_flags & OPf_KIDS))
11108         return NULL;
11109     rvop = cUNOPx(cvop)->op_first;
11110     switch (rvop->op_type) {
11111         case OP_GV: {
11112             gv = cGVOPx_gv(rvop);
11113             if (!isGV(gv)) {
11114                 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
11115                     cv = MUTABLE_CV(SvRV(gv));
11116                     gv = NULL;
11117                     break;
11118                 }
11119                 if (flags & RV2CVOPCV_RETURN_STUB)
11120                     return (CV *)gv;
11121                 else return NULL;
11122             }
11123             cv = GvCVu(gv);
11124             if (!cv) {
11125                 if (flags & RV2CVOPCV_MARK_EARLY)
11126                     rvop->op_private |= OPpEARLY_CV;
11127                 return NULL;
11128             }
11129         } break;
11130         case OP_CONST: {
11131             SV *rv = cSVOPx_sv(rvop);
11132             if (!SvROK(rv))
11133                 return NULL;
11134             cv = (CV*)SvRV(rv);
11135             gv = NULL;
11136         } break;
11137         case OP_PADCV: {
11138             cv = find_lexical_cv(rvop->op_targ);
11139             gv = NULL;
11140         } break;
11141         default: {
11142             return NULL;
11143         } NOT_REACHED; /* NOTREACHED */
11144     }
11145     if (SvTYPE((SV*)cv) != SVt_PVCV)
11146         return NULL;
11147     if (flags & (RV2CVOPCV_RETURN_NAME_GV|RV2CVOPCV_MAYBE_NAME_GV)) {
11148         if ((!CvANON(cv) || !gv) && !CvLEXICAL(cv)
11149          && ((flags & RV2CVOPCV_RETURN_NAME_GV) || !CvNAMED(cv)))
11150             gv = CvGV(cv);
11151         return (CV*)gv;
11152     } else {
11153         return cv;
11154     }
11155 }
11156
11157 /*
11158 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
11159
11160 Performs the default fixup of the arguments part of an C<entersub>
11161 op tree.  This consists of applying list context to each of the
11162 argument ops.  This is the standard treatment used on a call marked
11163 with C<&>, or a method call, or a call through a subroutine reference,
11164 or any other call where the callee can't be identified at compile time,
11165 or a call where the callee has no prototype.
11166
11167 =cut
11168 */
11169
11170 OP *
11171 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
11172 {
11173     OP *aop;
11174
11175     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
11176
11177     aop = cUNOPx(entersubop)->op_first;
11178     if (!OpHAS_SIBLING(aop))
11179         aop = cUNOPx(aop)->op_first;
11180     for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
11181         /* skip the extra attributes->import() call implicitly added in
11182          * something like foo(my $x : bar)
11183          */
11184         if (   aop->op_type == OP_ENTERSUB
11185             && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
11186         )
11187             continue;
11188         list(aop);
11189         op_lvalue(aop, OP_ENTERSUB);
11190     }
11191     return entersubop;
11192 }
11193
11194 /*
11195 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
11196
11197 Performs the fixup of the arguments part of an C<entersub> op tree
11198 based on a subroutine prototype.  This makes various modifications to
11199 the argument ops, from applying context up to inserting C<refgen> ops,
11200 and checking the number and syntactic types of arguments, as directed by
11201 the prototype.  This is the standard treatment used on a subroutine call,
11202 not marked with C<&>, where the callee can be identified at compile time
11203 and has a prototype.
11204
11205 C<protosv> supplies the subroutine prototype to be applied to the call.
11206 It may be a normal defined scalar, of which the string value will be used.
11207 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11208 that has been cast to C<SV*>) which has a prototype.  The prototype
11209 supplied, in whichever form, does not need to match the actual callee
11210 referenced by the op tree.
11211
11212 If the argument ops disagree with the prototype, for example by having
11213 an unacceptable number of arguments, a valid op tree is returned anyway.
11214 The error is reflected in the parser state, normally resulting in a single
11215 exception at the top level of parsing which covers all the compilation
11216 errors that occurred.  In the error message, the callee is referred to
11217 by the name defined by the C<namegv> parameter.
11218
11219 =cut
11220 */
11221
11222 OP *
11223 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11224 {
11225     STRLEN proto_len;
11226     const char *proto, *proto_end;
11227     OP *aop, *prev, *cvop, *parent;
11228     int optional = 0;
11229     I32 arg = 0;
11230     I32 contextclass = 0;
11231     const char *e = NULL;
11232     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
11233     if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
11234         Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
11235                    "flags=%lx", (unsigned long) SvFLAGS(protosv));
11236     if (SvTYPE(protosv) == SVt_PVCV)
11237          proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
11238     else proto = SvPV(protosv, proto_len);
11239     proto = S_strip_spaces(aTHX_ proto, &proto_len);
11240     proto_end = proto + proto_len;
11241     parent = entersubop;
11242     aop = cUNOPx(entersubop)->op_first;
11243     if (!OpHAS_SIBLING(aop)) {
11244         parent = aop;
11245         aop = cUNOPx(aop)->op_first;
11246     }
11247     prev = aop;
11248     aop = OpSIBLING(aop);
11249     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11250     while (aop != cvop) {
11251         OP* o3 = aop;
11252
11253         if (proto >= proto_end)
11254         {
11255             SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11256             yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf,
11257                                         SVfARG(namesv)), SvUTF8(namesv));
11258             return entersubop;
11259         }
11260
11261         switch (*proto) {
11262             case ';':
11263                 optional = 1;
11264                 proto++;
11265                 continue;
11266             case '_':
11267                 /* _ must be at the end */
11268                 if (proto[1] && !strchr(";@%", proto[1]))
11269                     goto oops;
11270                 /* FALLTHROUGH */
11271             case '$':
11272                 proto++;
11273                 arg++;
11274                 scalar(aop);
11275                 break;
11276             case '%':
11277             case '@':
11278                 list(aop);
11279                 arg++;
11280                 break;
11281             case '&':
11282                 proto++;
11283                 arg++;
11284                 if (    o3->op_type != OP_UNDEF
11285                     && (o3->op_type != OP_SREFGEN
11286                         || (  cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
11287                                 != OP_ANONCODE
11288                             && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
11289                                 != OP_RV2CV)))
11290                     bad_type_gv(arg, namegv, o3,
11291                             arg == 1 ? "block or sub {}" : "sub {}");
11292                 break;
11293             case '*':
11294                 /* '*' allows any scalar type, including bareword */
11295                 proto++;
11296                 arg++;
11297                 if (o3->op_type == OP_RV2GV)
11298                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
11299                 else if (o3->op_type == OP_CONST)
11300                     o3->op_private &= ~OPpCONST_STRICT;
11301                 scalar(aop);
11302                 break;
11303             case '+':
11304                 proto++;
11305                 arg++;
11306                 if (o3->op_type == OP_RV2AV ||
11307                     o3->op_type == OP_PADAV ||
11308                     o3->op_type == OP_RV2HV ||
11309                     o3->op_type == OP_PADHV
11310                 ) {
11311                     goto wrapref;
11312                 }
11313                 scalar(aop);
11314                 break;
11315             case '[': case ']':
11316                 goto oops;
11317
11318             case '\\':
11319                 proto++;
11320                 arg++;
11321             again:
11322                 switch (*proto++) {
11323                     case '[':
11324                         if (contextclass++ == 0) {
11325                             e = strchr(proto, ']');
11326                             if (!e || e == proto)
11327                                 goto oops;
11328                         }
11329                         else
11330                             goto oops;
11331                         goto again;
11332
11333                     case ']':
11334                         if (contextclass) {
11335                             const char *p = proto;
11336                             const char *const end = proto;
11337                             contextclass = 0;
11338                             while (*--p != '[')
11339                                 /* \[$] accepts any scalar lvalue */
11340                                 if (*p == '$'
11341                                  && Perl_op_lvalue_flags(aTHX_
11342                                      scalar(o3),
11343                                      OP_READ, /* not entersub */
11344                                      OP_LVALUE_NO_CROAK
11345                                     )) goto wrapref;
11346                             bad_type_gv(arg, namegv, o3,
11347                                     Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
11348                         } else
11349                             goto oops;
11350                         break;
11351                     case '*':
11352                         if (o3->op_type == OP_RV2GV)
11353                             goto wrapref;
11354                         if (!contextclass)
11355                             bad_type_gv(arg, namegv, o3, "symbol");
11356                         break;
11357                     case '&':
11358                         if (o3->op_type == OP_ENTERSUB
11359                          && !(o3->op_flags & OPf_STACKED))
11360                             goto wrapref;
11361                         if (!contextclass)
11362                             bad_type_gv(arg, namegv, o3, "subroutine");
11363                         break;
11364                     case '$':
11365                         if (o3->op_type == OP_RV2SV ||
11366                                 o3->op_type == OP_PADSV ||
11367                                 o3->op_type == OP_HELEM ||
11368                                 o3->op_type == OP_AELEM)
11369                             goto wrapref;
11370                         if (!contextclass) {
11371                             /* \$ accepts any scalar lvalue */
11372                             if (Perl_op_lvalue_flags(aTHX_
11373                                     scalar(o3),
11374                                     OP_READ,  /* not entersub */
11375                                     OP_LVALUE_NO_CROAK
11376                                )) goto wrapref;
11377                             bad_type_gv(arg, namegv, o3, "scalar");
11378                         }
11379                         break;
11380                     case '@':
11381                         if (o3->op_type == OP_RV2AV ||
11382                                 o3->op_type == OP_PADAV)
11383                         {
11384                             o3->op_flags &=~ OPf_PARENS;
11385                             goto wrapref;
11386                         }
11387                         if (!contextclass)
11388                             bad_type_gv(arg, namegv, o3, "array");
11389                         break;
11390                     case '%':
11391                         if (o3->op_type == OP_RV2HV ||
11392                                 o3->op_type == OP_PADHV)
11393                         {
11394                             o3->op_flags &=~ OPf_PARENS;
11395                             goto wrapref;
11396                         }
11397                         if (!contextclass)
11398                             bad_type_gv(arg, namegv, o3, "hash");
11399                         break;
11400                     wrapref:
11401                             aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
11402                                                 OP_REFGEN, 0);
11403                         if (contextclass && e) {
11404                             proto = e + 1;
11405                             contextclass = 0;
11406                         }
11407                         break;
11408                     default: goto oops;
11409                 }
11410                 if (contextclass)
11411                     goto again;
11412                 break;
11413             case ' ':
11414                 proto++;
11415                 continue;
11416             default:
11417             oops: {
11418                 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
11419                                   SVfARG(cv_name((CV *)namegv, NULL, 0)),
11420                                   SVfARG(protosv));
11421             }
11422         }
11423
11424         op_lvalue(aop, OP_ENTERSUB);
11425         prev = aop;
11426         aop = OpSIBLING(aop);
11427     }
11428     if (aop == cvop && *proto == '_') {
11429         /* generate an access to $_ */
11430         op_sibling_splice(parent, prev, 0, newDEFSVOP());
11431     }
11432     if (!optional && proto_end > proto &&
11433         (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
11434     {
11435         SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11436         yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf,
11437                                     SVfARG(namesv)), SvUTF8(namesv));
11438     }
11439     return entersubop;
11440 }
11441
11442 /*
11443 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
11444
11445 Performs the fixup of the arguments part of an C<entersub> op tree either
11446 based on a subroutine prototype or using default list-context processing.
11447 This is the standard treatment used on a subroutine call, not marked
11448 with C<&>, where the callee can be identified at compile time.
11449
11450 C<protosv> supplies the subroutine prototype to be applied to the call,
11451 or indicates that there is no prototype.  It may be a normal scalar,
11452 in which case if it is defined then the string value will be used
11453 as a prototype, and if it is undefined then there is no prototype.
11454 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11455 that has been cast to C<SV*>), of which the prototype will be used if it
11456 has one.  The prototype (or lack thereof) supplied, in whichever form,
11457 does not need to match the actual callee referenced by the op tree.
11458
11459 If the argument ops disagree with the prototype, for example by having
11460 an unacceptable number of arguments, a valid op tree is returned anyway.
11461 The error is reflected in the parser state, normally resulting in a single
11462 exception at the top level of parsing which covers all the compilation
11463 errors that occurred.  In the error message, the callee is referred to
11464 by the name defined by the C<namegv> parameter.
11465
11466 =cut
11467 */
11468
11469 OP *
11470 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
11471         GV *namegv, SV *protosv)
11472 {
11473     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
11474     if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
11475         return ck_entersub_args_proto(entersubop, namegv, protosv);
11476     else
11477         return ck_entersub_args_list(entersubop);
11478 }
11479
11480 OP *
11481 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11482 {
11483     int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
11484     OP *aop = cUNOPx(entersubop)->op_first;
11485
11486     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
11487
11488     if (!opnum) {
11489         OP *cvop;
11490         if (!OpHAS_SIBLING(aop))
11491             aop = cUNOPx(aop)->op_first;
11492         aop = OpSIBLING(aop);
11493         for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11494         if (aop != cvop)
11495             (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
11496
11497         op_free(entersubop);
11498         switch(GvNAME(namegv)[2]) {
11499         case 'F': return newSVOP(OP_CONST, 0,
11500                                         newSVpv(CopFILE(PL_curcop),0));
11501         case 'L': return newSVOP(
11502                            OP_CONST, 0,
11503                            Perl_newSVpvf(aTHX_
11504                              "%"IVdf, (IV)CopLINE(PL_curcop)
11505                            )
11506                          );
11507         case 'P': return newSVOP(OP_CONST, 0,
11508                                    (PL_curstash
11509                                      ? newSVhek(HvNAME_HEK(PL_curstash))
11510                                      : &PL_sv_undef
11511                                    )
11512                                 );
11513         }
11514         NOT_REACHED; /* NOTREACHED */
11515     }
11516     else {
11517         OP *prev, *cvop, *first, *parent;
11518         U32 flags = 0;
11519
11520         parent = entersubop;
11521         if (!OpHAS_SIBLING(aop)) {
11522             parent = aop;
11523             aop = cUNOPx(aop)->op_first;
11524         }
11525
11526         first = prev = aop;
11527         aop = OpSIBLING(aop);
11528         /* find last sibling */
11529         for (cvop = aop;
11530              OpHAS_SIBLING(cvop);
11531              prev = cvop, cvop = OpSIBLING(cvop))
11532             ;
11533         if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
11534             /* Usually, OPf_SPECIAL on an op with no args means that it had
11535              * parens, but these have their own meaning for that flag: */
11536             && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
11537             && opnum != OP_DELETE && opnum != OP_EXISTS)
11538                 flags |= OPf_SPECIAL;
11539         /* excise cvop from end of sibling chain */
11540         op_sibling_splice(parent, prev, 1, NULL);
11541         op_free(cvop);
11542         if (aop == cvop) aop = NULL;
11543
11544         /* detach remaining siblings from the first sibling, then
11545          * dispose of original optree */
11546
11547         if (aop)
11548             op_sibling_splice(parent, first, -1, NULL);
11549         op_free(entersubop);
11550
11551         if (opnum == OP_ENTEREVAL
11552          && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
11553             flags |= OPpEVAL_BYTES <<8;
11554
11555         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
11556         case OA_UNOP:
11557         case OA_BASEOP_OR_UNOP:
11558         case OA_FILESTATOP:
11559             return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
11560         case OA_BASEOP:
11561             if (aop) {
11562                     (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
11563                 op_free(aop);
11564             }
11565             return opnum == OP_RUNCV
11566                 ? newPVOP(OP_RUNCV,0,NULL)
11567                 : newOP(opnum,0);
11568         default:
11569             return op_convert_list(opnum,0,aop);
11570         }
11571     }
11572     NOT_REACHED; /* NOTREACHED */
11573     return entersubop;
11574 }
11575
11576 /*
11577 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
11578
11579 Retrieves the function that will be used to fix up a call to C<cv>.
11580 Specifically, the function is applied to an C<entersub> op tree for a
11581 subroutine call, not marked with C<&>, where the callee can be identified
11582 at compile time as C<cv>.
11583
11584 The C-level function pointer is returned in C<*ckfun_p>, and an SV
11585 argument for it is returned in C<*ckobj_p>.  The function is intended
11586 to be called in this manner:
11587
11588  entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
11589
11590 In this call, C<entersubop> is a pointer to the C<entersub> op,
11591 which may be replaced by the check function, and C<namegv> is a GV
11592 supplying the name that should be used by the check function to refer
11593 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11594 It is permitted to apply the check function in non-standard situations,
11595 such as to a call to a different subroutine or to a method call.
11596
11597 By default, the function is
11598 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
11599 and the SV parameter is C<cv> itself.  This implements standard
11600 prototype processing.  It can be changed, for a particular subroutine,
11601 by L</cv_set_call_checker>.
11602
11603 =cut
11604 */
11605
11606 static void
11607 S_cv_get_call_checker(CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p,
11608                       U8 *flagsp)
11609 {
11610     MAGIC *callmg;
11611     callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
11612     if (callmg) {
11613         *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
11614         *ckobj_p = callmg->mg_obj;
11615         if (flagsp) *flagsp = callmg->mg_flags;
11616     } else {
11617         *ckfun_p = Perl_ck_entersub_args_proto_or_list;
11618         *ckobj_p = (SV*)cv;
11619         if (flagsp) *flagsp = 0;
11620     }
11621 }
11622
11623 void
11624 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
11625 {
11626     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
11627     PERL_UNUSED_CONTEXT;
11628     S_cv_get_call_checker(cv, ckfun_p, ckobj_p, NULL);
11629 }
11630
11631 /*
11632 =for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 flags
11633
11634 Sets the function that will be used to fix up a call to C<cv>.
11635 Specifically, the function is applied to an C<entersub> op tree for a
11636 subroutine call, not marked with C<&>, where the callee can be identified
11637 at compile time as C<cv>.
11638
11639 The C-level function pointer is supplied in C<ckfun>, and an SV argument
11640 for it is supplied in C<ckobj>.  The function should be defined like this:
11641
11642     STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
11643
11644 It is intended to be called in this manner:
11645
11646     entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
11647
11648 In this call, C<entersubop> is a pointer to the C<entersub> op,
11649 which may be replaced by the check function, and C<namegv> supplies
11650 the name that should be used by the check function to refer
11651 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11652 It is permitted to apply the check function in non-standard situations,
11653 such as to a call to a different subroutine or to a method call.
11654
11655 C<namegv> may not actually be a GV.  For efficiency, perl may pass a
11656 CV or other SV instead.  Whatever is passed can be used as the first
11657 argument to L</cv_name>.  You can force perl to pass a GV by including
11658 C<CALL_CHECKER_REQUIRE_GV> in the C<flags>.
11659
11660 The current setting for a particular CV can be retrieved by
11661 L</cv_get_call_checker>.
11662
11663 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
11664
11665 The original form of L</cv_set_call_checker_flags>, which passes it the
11666 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.
11667
11668 =cut
11669 */
11670
11671 void
11672 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
11673 {
11674     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
11675     cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
11676 }
11677
11678 void
11679 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
11680                                      SV *ckobj, U32 flags)
11681 {
11682     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
11683     if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
11684         if (SvMAGICAL((SV*)cv))
11685             mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
11686     } else {
11687         MAGIC *callmg;
11688         sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
11689         callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
11690         assert(callmg);
11691         if (callmg->mg_flags & MGf_REFCOUNTED) {
11692             SvREFCNT_dec(callmg->mg_obj);
11693             callmg->mg_flags &= ~MGf_REFCOUNTED;
11694         }
11695         callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
11696         callmg->mg_obj = ckobj;
11697         if (ckobj != (SV*)cv) {
11698             SvREFCNT_inc_simple_void_NN(ckobj);
11699             callmg->mg_flags |= MGf_REFCOUNTED;
11700         }
11701         callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
11702                          | (U8)(flags & MGf_REQUIRE_GV) | MGf_COPY;
11703     }
11704 }
11705
11706 static void
11707 S_entersub_alloc_targ(pTHX_ OP * const o)
11708 {
11709     o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
11710     o->op_private |= OPpENTERSUB_HASTARG;
11711 }
11712
11713 OP *
11714 Perl_ck_subr(pTHX_ OP *o)
11715 {
11716     OP *aop, *cvop;
11717     CV *cv;
11718     GV *namegv;
11719     SV **const_class = NULL;
11720
11721     PERL_ARGS_ASSERT_CK_SUBR;
11722
11723     aop = cUNOPx(o)->op_first;
11724     if (!OpHAS_SIBLING(aop))
11725         aop = cUNOPx(aop)->op_first;
11726     aop = OpSIBLING(aop);
11727     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11728     cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
11729     namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
11730
11731     o->op_private &= ~1;
11732     o->op_private |= (PL_hints & HINT_STRICT_REFS);
11733     if (PERLDB_SUB && PL_curstash != PL_debstash)
11734         o->op_private |= OPpENTERSUB_DB;
11735     switch (cvop->op_type) {
11736         case OP_RV2CV:
11737             o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
11738             op_null(cvop);
11739             break;
11740         case OP_METHOD:
11741         case OP_METHOD_NAMED:
11742         case OP_METHOD_SUPER:
11743         case OP_METHOD_REDIR:
11744         case OP_METHOD_REDIR_SUPER:
11745             if (aop->op_type == OP_CONST) {
11746                 aop->op_private &= ~OPpCONST_STRICT;
11747                 const_class = &cSVOPx(aop)->op_sv;
11748             }
11749             else if (aop->op_type == OP_LIST) {
11750                 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
11751                 if (sib && sib->op_type == OP_CONST) {
11752                     sib->op_private &= ~OPpCONST_STRICT;
11753                     const_class = &cSVOPx(sib)->op_sv;
11754                 }
11755             }
11756             /* make class name a shared cow string to speedup method calls */
11757             /* constant string might be replaced with object, f.e. bigint */
11758             if (const_class && SvPOK(*const_class)) {
11759                 STRLEN len;
11760                 const char* str = SvPV(*const_class, len);
11761                 if (len) {
11762                     SV* const shared = newSVpvn_share(
11763                         str, SvUTF8(*const_class)
11764                                     ? -(SSize_t)len : (SSize_t)len,
11765                         0
11766                     );
11767                     if (SvREADONLY(*const_class))
11768                         SvREADONLY_on(shared);
11769                     SvREFCNT_dec(*const_class);
11770                     *const_class = shared;
11771                 }
11772             }
11773             break;
11774     }
11775
11776     if (!cv) {
11777         S_entersub_alloc_targ(aTHX_ o);
11778         return ck_entersub_args_list(o);
11779     } else {
11780         Perl_call_checker ckfun;
11781         SV *ckobj;
11782         U8 flags;
11783         S_cv_get_call_checker(cv, &ckfun, &ckobj, &flags);
11784         if (CvISXSUB(cv) || !CvROOT(cv))
11785             S_entersub_alloc_targ(aTHX_ o);
11786         if (!namegv) {
11787             /* The original call checker API guarantees that a GV will be
11788                be provided with the right name.  So, if the old API was
11789                used (or the REQUIRE_GV flag was passed), we have to reify
11790                the CV’s GV, unless this is an anonymous sub.  This is not
11791                ideal for lexical subs, as its stringification will include
11792                the package.  But it is the best we can do.  */
11793             if (flags & MGf_REQUIRE_GV) {
11794                 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
11795                     namegv = CvGV(cv);
11796             }
11797             else namegv = MUTABLE_GV(cv);
11798             /* After a syntax error in a lexical sub, the cv that
11799                rv2cv_op_cv returns may be a nameless stub. */
11800             if (!namegv) return ck_entersub_args_list(o);
11801
11802         }
11803         return ckfun(aTHX_ o, namegv, ckobj);
11804     }
11805 }
11806
11807 OP *
11808 Perl_ck_svconst(pTHX_ OP *o)
11809 {
11810     SV * const sv = cSVOPo->op_sv;
11811     PERL_ARGS_ASSERT_CK_SVCONST;
11812     PERL_UNUSED_CONTEXT;
11813 #ifdef PERL_COPY_ON_WRITE
11814     /* Since the read-only flag may be used to protect a string buffer, we
11815        cannot do copy-on-write with existing read-only scalars that are not
11816        already copy-on-write scalars.  To allow $_ = "hello" to do COW with
11817        that constant, mark the constant as COWable here, if it is not
11818        already read-only. */
11819     if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
11820         SvIsCOW_on(sv);
11821         CowREFCNT(sv) = 0;
11822 # ifdef PERL_DEBUG_READONLY_COW
11823         sv_buf_to_ro(sv);
11824 # endif
11825     }
11826 #endif
11827     SvREADONLY_on(sv);
11828     return o;
11829 }
11830
11831 OP *
11832 Perl_ck_trunc(pTHX_ OP *o)
11833 {
11834     PERL_ARGS_ASSERT_CK_TRUNC;
11835
11836     if (o->op_flags & OPf_KIDS) {
11837         SVOP *kid = (SVOP*)cUNOPo->op_first;
11838
11839         if (kid->op_type == OP_NULL)
11840             kid = (SVOP*)OpSIBLING(kid);
11841         if (kid && kid->op_type == OP_CONST &&
11842             (kid->op_private & OPpCONST_BARE) &&
11843             !kid->op_folded)
11844         {
11845             o->op_flags |= OPf_SPECIAL;
11846             kid->op_private &= ~OPpCONST_STRICT;
11847         }
11848     }
11849     return ck_fun(o);
11850 }
11851
11852 OP *
11853 Perl_ck_substr(pTHX_ OP *o)
11854 {
11855     PERL_ARGS_ASSERT_CK_SUBSTR;
11856
11857     o = ck_fun(o);
11858     if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
11859         OP *kid = cLISTOPo->op_first;
11860
11861         if (kid->op_type == OP_NULL)
11862             kid = OpSIBLING(kid);
11863         if (kid)
11864             kid->op_flags |= OPf_MOD;
11865
11866     }
11867     return o;
11868 }
11869
11870 OP *
11871 Perl_ck_tell(pTHX_ OP *o)
11872 {
11873     PERL_ARGS_ASSERT_CK_TELL;
11874     o = ck_fun(o);
11875     if (o->op_flags & OPf_KIDS) {
11876      OP *kid = cLISTOPo->op_first;
11877      if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
11878      if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
11879     }
11880     return o;
11881 }
11882
11883 OP *
11884 Perl_ck_each(pTHX_ OP *o)
11885 {
11886     dVAR;
11887     OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
11888     const unsigned orig_type  = o->op_type;
11889
11890     PERL_ARGS_ASSERT_CK_EACH;
11891
11892     if (kid) {
11893         switch (kid->op_type) {
11894             case OP_PADHV:
11895             case OP_RV2HV:
11896                 break;
11897             case OP_PADAV:
11898             case OP_RV2AV:
11899                 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
11900                             : orig_type == OP_KEYS ? OP_AKEYS
11901                             :                        OP_AVALUES);
11902                 break;
11903             case OP_CONST:
11904                 if (kid->op_private == OPpCONST_BARE
11905                  || !SvROK(cSVOPx_sv(kid))
11906                  || (  SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
11907                     && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV  )
11908                    )
11909                     /* we let ck_fun handle it */
11910                     break;
11911             default:
11912                 Perl_croak_nocontext(
11913                     "Experimental %s on scalar is now forbidden",
11914                     PL_op_desc[orig_type]);
11915                 break;
11916         }
11917     }
11918     return ck_fun(o);
11919 }
11920
11921 OP *
11922 Perl_ck_length(pTHX_ OP *o)
11923 {
11924     PERL_ARGS_ASSERT_CK_LENGTH;
11925
11926     o = ck_fun(o);
11927
11928     if (ckWARN(WARN_SYNTAX)) {
11929         const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
11930
11931         if (kid) {
11932             SV *name = NULL;
11933             const bool hash = kid->op_type == OP_PADHV
11934                            || kid->op_type == OP_RV2HV;
11935             switch (kid->op_type) {
11936                 case OP_PADHV:
11937                 case OP_PADAV:
11938                 case OP_RV2HV:
11939                 case OP_RV2AV:
11940                     name = S_op_varname(aTHX_ kid);
11941                     break;
11942                 default:
11943                     return o;
11944             }
11945             if (name)
11946                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11947                     "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
11948                     ")\"?)",
11949                     SVfARG(name), hash ? "keys " : "", SVfARG(name)
11950                 );
11951             else if (hash)
11952      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
11953                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11954                     "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
11955             else
11956      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
11957                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11958                     "length() used on @array (did you mean \"scalar(@array)\"?)");
11959         }
11960     }
11961
11962     return o;
11963 }
11964
11965
11966
11967 /*
11968    ---------------------------------------------------------
11969
11970    Common vars in list assignment
11971
11972    There now follows some enums and static functions for detecting
11973    common variables in list assignments. Here is a little essay I wrote
11974    for myself when trying to get my head around this. DAPM.
11975
11976    ----
11977
11978    First some random observations:
11979
11980    * If a lexical var is an alias of something else, e.g.
11981        for my $x ($lex, $pkg, $a[0]) {...}
11982      then the act of aliasing will increase the reference count of the SV
11983
11984    * If a package var is an alias of something else, it may still have a
11985      reference count of 1, depending on how the alias was created, e.g.
11986      in *a = *b, $a may have a refcount of 1 since the GP is shared
11987      with a single GvSV pointer to the SV. So If it's an alias of another
11988      package var, then RC may be 1; if it's an alias of another scalar, e.g.
11989      a lexical var or an array element, then it will have RC > 1.
11990
11991    * There are many ways to create a package alias; ultimately, XS code
11992      may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
11993      run-time tracing mechanisms are unlikely to be able to catch all cases.
11994
11995    * When the LHS is all my declarations, the same vars can't appear directly
11996      on the RHS, but they can indirectly via closures, aliasing and lvalue
11997      subs. But those techniques all involve an increase in the lexical
11998      scalar's ref count.
11999
12000    * When the LHS is all lexical vars (but not necessarily my declarations),
12001      it is possible for the same lexicals to appear directly on the RHS, and
12002      without an increased ref count, since the stack isn't refcounted.
12003      This case can be detected at compile time by scanning for common lex
12004      vars with PL_generation.
12005
12006    * lvalue subs defeat common var detection, but they do at least
12007      return vars with a temporary ref count increment. Also, you can't
12008      tell at compile time whether a sub call is lvalue.
12009
12010
12011    So...
12012
12013    A: There are a few circumstances where there definitely can't be any
12014      commonality:
12015
12016        LHS empty:  () = (...);
12017        RHS empty:  (....) = ();
12018        RHS contains only constants or other 'can't possibly be shared'
12019            elements (e.g. ops that return PADTMPs):  (...) = (1,2, length)
12020            i.e. they only contain ops not marked as dangerous, whose children
12021            are also not dangerous;
12022        LHS ditto;
12023        LHS contains a single scalar element: e.g. ($x) = (....); because
12024            after $x has been modified, it won't be used again on the RHS;
12025        RHS contains a single element with no aggregate on LHS: e.g.
12026            ($a,$b,$c)  = ($x); again, once $a has been modified, its value
12027            won't be used again.
12028
12029    B: If LHS are all 'my' lexical var declarations (or safe ops, which
12030      we can ignore):
12031
12032        my ($a, $b, @c) = ...;
12033
12034        Due to closure and goto tricks, these vars may already have content.
12035        For the same reason, an element on the RHS may be a lexical or package
12036        alias of one of the vars on the left, or share common elements, for
12037        example:
12038
12039            my ($x,$y) = f(); # $x and $y on both sides
12040            sub f : lvalue { ($x,$y) = (1,2); $y, $x }
12041
12042        and
12043
12044            my $ra = f();
12045            my @a = @$ra;  # elements of @a on both sides
12046            sub f { @a = 1..4; \@a }
12047
12048
12049        First, just consider scalar vars on LHS:
12050
12051            RHS is safe only if (A), or in addition,
12052                * contains only lexical *scalar* vars, where neither side's
12053                  lexicals have been flagged as aliases
12054
12055            If RHS is not safe, then it's always legal to check LHS vars for
12056            RC==1, since the only RHS aliases will always be associated
12057            with an RC bump.
12058
12059            Note that in particular, RHS is not safe if:
12060
12061                * it contains package scalar vars; e.g.:
12062
12063                    f();
12064                    my ($x, $y) = (2, $x_alias);
12065                    sub f { $x = 1; *x_alias = \$x; }
12066
12067                * It contains other general elements, such as flattened or
12068                * spliced or single array or hash elements, e.g.
12069
12070                    f();
12071                    my ($x,$y) = @a; # or $a[0] or @a{@b} etc
12072
12073                    sub f {
12074                        ($x, $y) = (1,2);
12075                        use feature 'refaliasing';
12076                        \($a[0], $a[1]) = \($y,$x);
12077                    }
12078
12079                  It doesn't matter if the array/hash is lexical or package.
12080
12081                * it contains a function call that happens to be an lvalue
12082                  sub which returns one or more of the above, e.g.
12083
12084                    f();
12085                    my ($x,$y) = f();
12086
12087                    sub f : lvalue {
12088                        ($x, $y) = (1,2);
12089                        *x1 = \$x;
12090                        $y, $x1;
12091                    }
12092
12093                    (so a sub call on the RHS should be treated the same
12094                    as having a package var on the RHS).
12095
12096                * any other "dangerous" thing, such an op or built-in that
12097                  returns one of the above, e.g. pp_preinc
12098
12099
12100            If RHS is not safe, what we can do however is at compile time flag
12101            that the LHS are all my declarations, and at run time check whether
12102            all the LHS have RC == 1, and if so skip the full scan.
12103
12104        Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
12105
12106            Here the issue is whether there can be elements of @a on the RHS
12107            which will get prematurely freed when @a is cleared prior to
12108            assignment. This is only a problem if the aliasing mechanism
12109            is one which doesn't increase the refcount - only if RC == 1
12110            will the RHS element be prematurely freed.
12111
12112            Because the array/hash is being INTROed, it or its elements
12113            can't directly appear on the RHS:
12114
12115                my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
12116
12117            but can indirectly, e.g.:
12118
12119                my $r = f();
12120                my (@a) = @$r;
12121                sub f { @a = 1..3; \@a }
12122
12123            So if the RHS isn't safe as defined by (A), we must always
12124            mortalise and bump the ref count of any remaining RHS elements
12125            when assigning to a non-empty LHS aggregate.
12126
12127            Lexical scalars on the RHS aren't safe if they've been involved in
12128            aliasing, e.g.
12129
12130                use feature 'refaliasing';
12131
12132                f();
12133                \(my $lex) = \$pkg;
12134                my @a = ($lex,3); # equivalent to ($a[0],3)
12135
12136                sub f {
12137                    @a = (1,2);
12138                    \$pkg = \$a[0];
12139                }
12140
12141            Similarly with lexical arrays and hashes on the RHS:
12142
12143                f();
12144                my @b;
12145                my @a = (@b);
12146
12147                sub f {
12148                    @a = (1,2);
12149                    \$b[0] = \$a[1];
12150                    \$b[1] = \$a[0];
12151                }
12152
12153
12154
12155    C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
12156        my $a; ($a, my $b) = (....);
12157
12158        The difference between (B) and (C) is that it is now physically
12159        possible for the LHS vars to appear on the RHS too, where they
12160        are not reference counted; but in this case, the compile-time
12161        PL_generation sweep will detect such common vars.
12162
12163        So the rules for (C) differ from (B) in that if common vars are
12164        detected, the runtime "test RC==1" optimisation can no longer be used,
12165        and a full mark and sweep is required
12166
12167    D: As (C), but in addition the LHS may contain package vars.
12168
12169        Since package vars can be aliased without a corresponding refcount
12170        increase, all bets are off. It's only safe if (A). E.g.
12171
12172            my ($x, $y) = (1,2);
12173
12174            for $x_alias ($x) {
12175                ($x_alias, $y) = (3, $x); # whoops
12176            }
12177
12178        Ditto for LHS aggregate package vars.
12179
12180    E: Any other dangerous ops on LHS, e.g.
12181            (f(), $a[0], @$r) = (...);
12182
12183        this is similar to (E) in that all bets are off. In addition, it's
12184        impossible to determine at compile time whether the LHS
12185        contains a scalar or an aggregate, e.g.
12186
12187            sub f : lvalue { @a }
12188            (f()) = 1..3;
12189
12190 * ---------------------------------------------------------
12191 */
12192
12193
12194 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates
12195  * that at least one of the things flagged was seen.
12196  */
12197
12198 enum {
12199     AAS_MY_SCALAR       = 0x001, /* my $scalar */
12200     AAS_MY_AGG          = 0x002, /* aggregate: my @array or my %hash */
12201     AAS_LEX_SCALAR      = 0x004, /* $lexical */
12202     AAS_LEX_AGG         = 0x008, /* @lexical or %lexical aggregate */
12203     AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
12204     AAS_PKG_SCALAR      = 0x020, /* $scalar (where $scalar is pkg var) */
12205     AAS_PKG_AGG         = 0x040, /* package @array or %hash aggregate */
12206     AAS_DANGEROUS       = 0x080, /* an op (other than the above)
12207                                          that's flagged OA_DANGEROUS */
12208     AAS_SAFE_SCALAR     = 0x100, /* produces at least one scalar SV that's
12209                                         not in any of the categories above */
12210     AAS_DEFAV           = 0x200  /* contains just a single '@_' on RHS */
12211 };
12212
12213
12214
12215 /* helper function for S_aassign_scan().
12216  * check a PAD-related op for commonality and/or set its generation number.
12217  * Returns a boolean indicating whether its shared */
12218
12219 static bool
12220 S_aassign_padcheck(pTHX_ OP* o, bool rhs)
12221 {
12222     if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
12223         /* lexical used in aliasing */
12224         return TRUE;
12225
12226     if (rhs)
12227         return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
12228     else
12229         PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
12230
12231     return FALSE;
12232 }
12233
12234
12235 /*
12236   Helper function for OPpASSIGN_COMMON* detection in rpeep().
12237   It scans the left or right hand subtree of the aassign op, and returns a
12238   set of flags indicating what sorts of things it found there.
12239   'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
12240   set PL_generation on lexical vars; if the latter, we see if
12241   PL_generation matches.
12242   'top' indicates whether we're recursing or at the top level.
12243   'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
12244   This fn will increment it by the number seen. It's not intended to
12245   be an accurate count (especially as many ops can push a variable
12246   number of SVs onto the stack); rather it's used as to test whether there
12247   can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
12248 */
12249
12250 static int
12251 S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *scalars_p)
12252 {
12253     int flags = 0;
12254     bool kid_top = FALSE;
12255
12256     /* first, look for a solitary @_ on the RHS */
12257     if (   rhs
12258         && top
12259         && (o->op_flags & OPf_KIDS)
12260         && OP_TYPE_IS_OR_WAS(o, OP_LIST)
12261     ) {
12262         OP *kid = cUNOPo->op_first;
12263         if (   (   kid->op_type == OP_PUSHMARK
12264                 || kid->op_type == OP_PADRANGE) /* ex-pushmark */
12265             && ((kid = OpSIBLING(kid)))
12266             && !OpHAS_SIBLING(kid)
12267             && kid->op_type == OP_RV2AV
12268             && !(kid->op_flags & OPf_REF)
12269             && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
12270             && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
12271             && ((kid = cUNOPx(kid)->op_first))
12272             && kid->op_type == OP_GV
12273             && cGVOPx_gv(kid) == PL_defgv
12274         )
12275             flags |= AAS_DEFAV;
12276     }
12277
12278     switch (o->op_type) {
12279     case OP_GVSV:
12280         (*scalars_p)++;
12281         return AAS_PKG_SCALAR;
12282
12283     case OP_PADAV:
12284     case OP_PADHV:
12285         (*scalars_p) += 2;
12286         if (top && (o->op_flags & OPf_REF))
12287             return (o->op_private & OPpLVAL_INTRO)
12288                 ? AAS_MY_AGG : AAS_LEX_AGG;
12289         return AAS_DANGEROUS;
12290
12291     case OP_PADSV:
12292         {
12293             int comm = S_aassign_padcheck(aTHX_ o, rhs)
12294                         ?  AAS_LEX_SCALAR_COMM : 0;
12295             (*scalars_p)++;
12296             return (o->op_private & OPpLVAL_INTRO)
12297                 ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
12298         }
12299
12300     case OP_RV2AV:
12301     case OP_RV2HV:
12302         (*scalars_p) += 2;
12303         if (cUNOPx(o)->op_first->op_type != OP_GV)
12304             return AAS_DANGEROUS; /* @{expr}, %{expr} */
12305         /* @pkg, %pkg */
12306         if (top && (o->op_flags & OPf_REF))
12307             return AAS_PKG_AGG;
12308         return AAS_DANGEROUS;
12309
12310     case OP_RV2SV:
12311         (*scalars_p)++;
12312         if (cUNOPx(o)->op_first->op_type != OP_GV) {
12313             (*scalars_p) += 2;
12314             return AAS_DANGEROUS; /* ${expr} */
12315         }
12316         return AAS_PKG_SCALAR; /* $pkg */
12317
12318     case OP_SPLIT:
12319         if (cLISTOPo->op_first->op_type == OP_PUSHRE) {
12320             /* "@foo = split... " optimises away the aassign and stores its
12321              * destination array in the OP_PUSHRE that precedes it.
12322              * A flattened array is always dangerous.
12323              */
12324             (*scalars_p) += 2;
12325             return AAS_DANGEROUS;
12326         }
12327         break;
12328
12329     case OP_UNDEF:
12330         /* undef counts as a scalar on the RHS:
12331          *   (undef, $x) = ...;         # only 1 scalar on LHS: always safe
12332          *   ($x, $y)    = (undef, $x); # 2 scalars on RHS: unsafe
12333          */
12334         if (rhs)
12335             (*scalars_p)++;
12336         flags = AAS_SAFE_SCALAR;
12337         break;
12338
12339     case OP_PUSHMARK:
12340     case OP_STUB:
12341         /* these are all no-ops; they don't push a potentially common SV
12342          * onto the stack, so they are neither AAS_DANGEROUS nor
12343          * AAS_SAFE_SCALAR */
12344         return 0;
12345
12346     case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
12347         break;
12348
12349     case OP_NULL:
12350     case OP_LIST:
12351         /* these do nothing but may have children; but their children
12352          * should also be treated as top-level */
12353         kid_top = top;
12354         break;
12355
12356     default:
12357         if (PL_opargs[o->op_type] & OA_DANGEROUS) {
12358             (*scalars_p) += 2;
12359             flags = AAS_DANGEROUS;
12360             break;
12361         }
12362
12363         if (   (PL_opargs[o->op_type] & OA_TARGLEX)
12364             && (o->op_private & OPpTARGET_MY))
12365         {
12366             (*scalars_p)++;
12367             return S_aassign_padcheck(aTHX_ o, rhs)
12368                 ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
12369         }
12370
12371         /* if its an unrecognised, non-dangerous op, assume that it
12372          * it the cause of at least one safe scalar */
12373         (*scalars_p)++;
12374         flags = AAS_SAFE_SCALAR;
12375         break;
12376     }
12377
12378     if (o->op_flags & OPf_KIDS) {
12379         OP *kid;
12380         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
12381             flags |= S_aassign_scan(aTHX_ kid, rhs, kid_top, scalars_p);
12382     }
12383     return flags;
12384 }
12385
12386
12387 /* Check for in place reverse and sort assignments like "@a = reverse @a"
12388    and modify the optree to make them work inplace */
12389
12390 STATIC void
12391 S_inplace_aassign(pTHX_ OP *o) {
12392
12393     OP *modop, *modop_pushmark;
12394     OP *oright;
12395     OP *oleft, *oleft_pushmark;
12396
12397     PERL_ARGS_ASSERT_INPLACE_AASSIGN;
12398
12399     assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
12400
12401     assert(cUNOPo->op_first->op_type == OP_NULL);
12402     modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
12403     assert(modop_pushmark->op_type == OP_PUSHMARK);
12404     modop = OpSIBLING(modop_pushmark);
12405
12406     if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
12407         return;
12408
12409     /* no other operation except sort/reverse */
12410     if (OpHAS_SIBLING(modop))
12411         return;
12412
12413     assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
12414     if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
12415
12416     if (modop->op_flags & OPf_STACKED) {
12417         /* skip sort subroutine/block */
12418         assert(oright->op_type == OP_NULL);
12419         oright = OpSIBLING(oright);
12420     }
12421
12422     assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
12423     oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
12424     assert(oleft_pushmark->op_type == OP_PUSHMARK);
12425     oleft = OpSIBLING(oleft_pushmark);
12426
12427     /* Check the lhs is an array */
12428     if (!oleft ||
12429         (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
12430         || OpHAS_SIBLING(oleft)
12431         || (oleft->op_private & OPpLVAL_INTRO)
12432     )
12433         return;
12434
12435     /* Only one thing on the rhs */
12436     if (OpHAS_SIBLING(oright))
12437         return;
12438
12439     /* check the array is the same on both sides */
12440     if (oleft->op_type == OP_RV2AV) {
12441         if (oright->op_type != OP_RV2AV
12442             || !cUNOPx(oright)->op_first
12443             || cUNOPx(oright)->op_first->op_type != OP_GV
12444             || cUNOPx(oleft )->op_first->op_type != OP_GV
12445             || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
12446                cGVOPx_gv(cUNOPx(oright)->op_first)
12447         )
12448             return;
12449     }
12450     else if (oright->op_type != OP_PADAV
12451         || oright->op_targ != oleft->op_targ
12452     )
12453         return;
12454
12455     /* This actually is an inplace assignment */
12456
12457     modop->op_private |= OPpSORT_INPLACE;
12458
12459     /* transfer MODishness etc from LHS arg to RHS arg */
12460     oright->op_flags = oleft->op_flags;
12461
12462     /* remove the aassign op and the lhs */
12463     op_null(o);
12464     op_null(oleft_pushmark);
12465     if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
12466         op_null(cUNOPx(oleft)->op_first);
12467     op_null(oleft);
12468 }
12469
12470
12471
12472 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
12473  * that potentially represent a series of one or more aggregate derefs
12474  * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
12475  * the whole chain to a single OP_MULTIDEREF op (maybe with a few
12476  * additional ops left in too).
12477  *
12478  * The caller will have already verified that the first few ops in the
12479  * chain following 'start' indicate a multideref candidate, and will have
12480  * set 'orig_o' to the point further on in the chain where the first index
12481  * expression (if any) begins.  'orig_action' specifies what type of
12482  * beginning has already been determined by the ops between start..orig_o
12483  * (e.g.  $lex_ary[], $pkg_ary->{}, expr->[], etc).
12484  *
12485  * 'hints' contains any hints flags that need adding (currently just
12486  * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
12487  */
12488
12489 STATIC void
12490 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
12491 {
12492     dVAR;
12493     int pass;
12494     UNOP_AUX_item *arg_buf = NULL;
12495     bool reset_start_targ  = FALSE; /* start->op_targ needs zeroing */
12496     int index_skip         = -1;    /* don't output index arg on this action */
12497
12498     /* similar to regex compiling, do two passes; the first pass
12499      * determines whether the op chain is convertible and calculates the
12500      * buffer size; the second pass populates the buffer and makes any
12501      * changes necessary to ops (such as moving consts to the pad on
12502      * threaded builds).
12503      *
12504      * NB: for things like Coverity, note that both passes take the same
12505      * path through the logic tree (except for 'if (pass)' bits), since
12506      * both passes are following the same op_next chain; and in
12507      * particular, if it would return early on the second pass, it would
12508      * already have returned early on the first pass.
12509      */
12510     for (pass = 0; pass < 2; pass++) {
12511         OP *o                = orig_o;
12512         UV action            = orig_action;
12513         OP *first_elem_op    = NULL;  /* first seen aelem/helem */
12514         OP *top_op           = NULL;  /* highest [ah]elem/exists/del/rv2[ah]v */
12515         int action_count     = 0;     /* number of actions seen so far */
12516         int action_ix        = 0;     /* action_count % (actions per IV) */
12517         bool next_is_hash    = FALSE; /* is the next lookup to be a hash? */
12518         bool is_last         = FALSE; /* no more derefs to follow */
12519         bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
12520         UNOP_AUX_item *arg     = arg_buf;
12521         UNOP_AUX_item *action_ptr = arg_buf;
12522
12523         if (pass)
12524             action_ptr->uv = 0;
12525         arg++;
12526
12527         switch (action) {
12528         case MDEREF_HV_gvsv_vivify_rv2hv_helem:
12529         case MDEREF_HV_gvhv_helem:
12530             next_is_hash = TRUE;
12531             /* FALLTHROUGH */
12532         case MDEREF_AV_gvsv_vivify_rv2av_aelem:
12533         case MDEREF_AV_gvav_aelem:
12534             if (pass) {
12535 #ifdef USE_ITHREADS
12536                 arg->pad_offset = cPADOPx(start)->op_padix;
12537                 /* stop it being swiped when nulled */
12538                 cPADOPx(start)->op_padix = 0;
12539 #else
12540                 arg->sv = cSVOPx(start)->op_sv;
12541                 cSVOPx(start)->op_sv = NULL;
12542 #endif
12543             }
12544             arg++;
12545             break;
12546
12547         case MDEREF_HV_padhv_helem:
12548         case MDEREF_HV_padsv_vivify_rv2hv_helem:
12549             next_is_hash = TRUE;
12550             /* FALLTHROUGH */
12551         case MDEREF_AV_padav_aelem:
12552         case MDEREF_AV_padsv_vivify_rv2av_aelem:
12553             if (pass) {
12554                 arg->pad_offset = start->op_targ;
12555                 /* we skip setting op_targ = 0 for now, since the intact
12556                  * OP_PADXV is needed by S_check_hash_fields_and_hekify */
12557                 reset_start_targ = TRUE;
12558             }
12559             arg++;
12560             break;
12561
12562         case MDEREF_HV_pop_rv2hv_helem:
12563             next_is_hash = TRUE;
12564             /* FALLTHROUGH */
12565         case MDEREF_AV_pop_rv2av_aelem:
12566             break;
12567
12568         default:
12569             NOT_REACHED; /* NOTREACHED */
12570             return;
12571         }
12572
12573         while (!is_last) {
12574             /* look for another (rv2av/hv; get index;
12575              * aelem/helem/exists/delele) sequence */
12576
12577             OP *kid;
12578             bool is_deref;
12579             bool ok;
12580             UV index_type = MDEREF_INDEX_none;
12581
12582             if (action_count) {
12583                 /* if this is not the first lookup, consume the rv2av/hv  */
12584
12585                 /* for N levels of aggregate lookup, we normally expect
12586                  * that the first N-1 [ah]elem ops will be flagged as
12587                  * /DEREF (so they autovivifiy if necessary), and the last
12588                  * lookup op not to be.
12589                  * For other things (like @{$h{k1}{k2}}) extra scope or
12590                  * leave ops can appear, so abandon the effort in that
12591                  * case */
12592                 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
12593                     return;
12594
12595                 /* rv2av or rv2hv sKR/1 */
12596
12597                 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12598                                             |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12599                 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
12600                     return;
12601
12602                 /* at this point, we wouldn't expect any of these
12603                  * possible private flags:
12604                  * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
12605                  * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
12606                  */
12607                 ASSUME(!(o->op_private &
12608                     ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
12609
12610                 hints = (o->op_private & OPpHINT_STRICT_REFS);
12611
12612                 /* make sure the type of the previous /DEREF matches the
12613                  * type of the next lookup */
12614                 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
12615                 top_op = o;
12616
12617                 action = next_is_hash
12618                             ? MDEREF_HV_vivify_rv2hv_helem
12619                             : MDEREF_AV_vivify_rv2av_aelem;
12620                 o = o->op_next;
12621             }
12622
12623             /* if this is the second pass, and we're at the depth where
12624              * previously we encountered a non-simple index expression,
12625              * stop processing the index at this point */
12626             if (action_count != index_skip) {
12627
12628                 /* look for one or more simple ops that return an array
12629                  * index or hash key */
12630
12631                 switch (o->op_type) {
12632                 case OP_PADSV:
12633                     /* it may be a lexical var index */
12634                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
12635                                             |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12636                     ASSUME(!(o->op_private &
12637                             ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
12638
12639                     if (   OP_GIMME(o,0) == G_SCALAR
12640                         && !(o->op_flags & (OPf_REF|OPf_MOD))
12641                         && o->op_private == 0)
12642                     {
12643                         if (pass)
12644                             arg->pad_offset = o->op_targ;
12645                         arg++;
12646                         index_type = MDEREF_INDEX_padsv;
12647                         o = o->op_next;
12648                     }
12649                     break;
12650
12651                 case OP_CONST:
12652                     if (next_is_hash) {
12653                         /* it's a constant hash index */
12654                         if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
12655                             /* "use constant foo => FOO; $h{+foo}" for
12656                              * some weird FOO, can leave you with constants
12657                              * that aren't simple strings. It's not worth
12658                              * the extra hassle for those edge cases */
12659                             break;
12660
12661                         if (pass) {
12662                             UNOP *rop = NULL;
12663                             OP * helem_op = o->op_next;
12664
12665                             ASSUME(   helem_op->op_type == OP_HELEM
12666                                    || helem_op->op_type == OP_NULL);
12667                             if (helem_op->op_type == OP_HELEM) {
12668                                 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
12669                                 if (   helem_op->op_private & OPpLVAL_INTRO
12670                                     || rop->op_type != OP_RV2HV
12671                                 )
12672                                     rop = NULL;
12673                             }
12674                             S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo);
12675
12676 #ifdef USE_ITHREADS
12677                             /* Relocate sv to the pad for thread safety */
12678                             op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
12679                             arg->pad_offset = o->op_targ;
12680                             o->op_targ = 0;
12681 #else
12682                             arg->sv = cSVOPx_sv(o);
12683 #endif
12684                         }
12685                     }
12686                     else {
12687                         /* it's a constant array index */
12688                         IV iv;
12689                         SV *ix_sv = cSVOPo->op_sv;
12690                         if (!SvIOK(ix_sv))
12691                             break;
12692                         iv = SvIV(ix_sv);
12693
12694                         if (   action_count == 0
12695                             && iv >= -128
12696                             && iv <= 127
12697                             && (   action == MDEREF_AV_padav_aelem
12698                                 || action == MDEREF_AV_gvav_aelem)
12699                         )
12700                             maybe_aelemfast = TRUE;
12701
12702                         if (pass) {
12703                             arg->iv = iv;
12704                             SvREFCNT_dec_NN(cSVOPo->op_sv);
12705                         }
12706                     }
12707                     if (pass)
12708                         /* we've taken ownership of the SV */
12709                         cSVOPo->op_sv = NULL;
12710                     arg++;
12711                     index_type = MDEREF_INDEX_const;
12712                     o = o->op_next;
12713                     break;
12714
12715                 case OP_GV:
12716                     /* it may be a package var index */
12717
12718                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_SPECIAL)));
12719                     ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
12720                     if (  (o->op_flags &~ OPf_SPECIAL) != OPf_WANT_SCALAR
12721                         || o->op_private != 0
12722                     )
12723                         break;
12724
12725                     kid = o->op_next;
12726                     if (kid->op_type != OP_RV2SV)
12727                         break;
12728
12729                     ASSUME(!(kid->op_flags &
12730                             ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
12731                              |OPf_SPECIAL|OPf_PARENS)));
12732                     ASSUME(!(kid->op_private &
12733                                     ~(OPpARG1_MASK
12734                                      |OPpHINT_STRICT_REFS|OPpOUR_INTRO
12735                                      |OPpDEREF|OPpLVAL_INTRO)));
12736                     if(   (kid->op_flags &~ OPf_PARENS)
12737                             != (OPf_WANT_SCALAR|OPf_KIDS)
12738                        || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
12739                     )
12740                         break;
12741
12742                     if (pass) {
12743 #ifdef USE_ITHREADS
12744                         arg->pad_offset = cPADOPx(o)->op_padix;
12745                         /* stop it being swiped when nulled */
12746                         cPADOPx(o)->op_padix = 0;
12747 #else
12748                         arg->sv = cSVOPx(o)->op_sv;
12749                         cSVOPo->op_sv = NULL;
12750 #endif
12751                     }
12752                     arg++;
12753                     index_type = MDEREF_INDEX_gvsv;
12754                     o = kid->op_next;
12755                     break;
12756
12757                 } /* switch */
12758             } /* action_count != index_skip */
12759
12760             action |= index_type;
12761
12762
12763             /* at this point we have either:
12764              *   * detected what looks like a simple index expression,
12765              *     and expect the next op to be an [ah]elem, or
12766              *     an nulled  [ah]elem followed by a delete or exists;
12767              *  * found a more complex expression, so something other
12768              *    than the above follows.
12769              */
12770
12771             /* possibly an optimised away [ah]elem (where op_next is
12772              * exists or delete) */
12773             if (o->op_type == OP_NULL)
12774                 o = o->op_next;
12775
12776             /* at this point we're looking for an OP_AELEM, OP_HELEM,
12777              * OP_EXISTS or OP_DELETE */
12778
12779             /* if something like arybase (a.k.a $[ ) is in scope,
12780              * abandon optimisation attempt */
12781             if (  (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
12782                && PL_check[o->op_type] != Perl_ck_null)
12783                 return;
12784
12785             if (   o->op_type != OP_AELEM
12786                 || (o->op_private &
12787                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
12788                 )
12789                 maybe_aelemfast = FALSE;
12790
12791             /* look for aelem/helem/exists/delete. If it's not the last elem
12792              * lookup, it *must* have OPpDEREF_AV/HV, but not many other
12793              * flags; if it's the last, then it mustn't have
12794              * OPpDEREF_AV/HV, but may have lots of other flags, like
12795              * OPpLVAL_INTRO etc
12796              */
12797
12798             if (   index_type == MDEREF_INDEX_none
12799                 || (   o->op_type != OP_AELEM  && o->op_type != OP_HELEM
12800                     && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
12801             )
12802                 ok = FALSE;
12803             else {
12804                 /* we have aelem/helem/exists/delete with valid simple index */
12805
12806                 is_deref =    (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
12807                            && (   (o->op_private & OPpDEREF) == OPpDEREF_AV
12808                                || (o->op_private & OPpDEREF) == OPpDEREF_HV);
12809
12810                 if (is_deref) {
12811                     ASSUME(!(o->op_flags &
12812                                  ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
12813                     ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
12814
12815                     ok =    (o->op_flags &~ OPf_PARENS)
12816                                == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
12817                          && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
12818                 }
12819                 else if (o->op_type == OP_EXISTS) {
12820                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12821                                 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12822                     ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
12823                     ok =  !(o->op_private & ~OPpARG1_MASK);
12824                 }
12825                 else if (o->op_type == OP_DELETE) {
12826                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12827                                 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12828                     ASSUME(!(o->op_private &
12829                                     ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
12830                     /* don't handle slices or 'local delete'; the latter
12831                      * is fairly rare, and has a complex runtime */
12832                     ok =  !(o->op_private & ~OPpARG1_MASK);
12833                     if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
12834                         /* skip handling run-tome error */
12835                         ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
12836                 }
12837                 else {
12838                     ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
12839                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
12840                                             |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
12841                     ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
12842                                     |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
12843                     ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
12844                 }
12845             }
12846
12847             if (ok) {
12848                 if (!first_elem_op)
12849                     first_elem_op = o;
12850                 top_op = o;
12851                 if (is_deref) {
12852                     next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
12853                     o = o->op_next;
12854                 }
12855                 else {
12856                     is_last = TRUE;
12857                     action |= MDEREF_FLAG_last;
12858                 }
12859             }
12860             else {
12861                 /* at this point we have something that started
12862                  * promisingly enough (with rv2av or whatever), but failed
12863                  * to find a simple index followed by an
12864                  * aelem/helem/exists/delete. If this is the first action,
12865                  * give up; but if we've already seen at least one
12866                  * aelem/helem, then keep them and add a new action with
12867                  * MDEREF_INDEX_none, which causes it to do the vivify
12868                  * from the end of the previous lookup, and do the deref,
12869                  * but stop at that point. So $a[0][expr] will do one
12870                  * av_fetch, vivify and deref, then continue executing at
12871                  * expr */
12872                 if (!action_count)
12873                     return;
12874                 is_last = TRUE;
12875                 index_skip = action_count;
12876                 action |= MDEREF_FLAG_last;
12877             }
12878
12879             if (pass)
12880                 action_ptr->uv |= (action << (action_ix * MDEREF_SHIFT));
12881             action_ix++;
12882             action_count++;
12883             /* if there's no space for the next action, create a new slot
12884              * for it *before* we start adding args for that action */
12885             if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
12886                 action_ptr = arg;
12887                 if (pass)
12888                     arg->uv = 0;
12889                 arg++;
12890                 action_ix = 0;
12891             }
12892         } /* while !is_last */
12893
12894         /* success! */
12895
12896         if (pass) {
12897             OP *mderef;
12898             OP *p, *q;
12899
12900             mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
12901             if (index_skip == -1) {
12902                 mderef->op_flags = o->op_flags
12903                         & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
12904                 if (o->op_type == OP_EXISTS)
12905                     mderef->op_private = OPpMULTIDEREF_EXISTS;
12906                 else if (o->op_type == OP_DELETE)
12907                     mderef->op_private = OPpMULTIDEREF_DELETE;
12908                 else
12909                     mderef->op_private = o->op_private
12910                         & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
12911             }
12912             /* accumulate strictness from every level (although I don't think
12913              * they can actually vary) */
12914             mderef->op_private |= hints;
12915
12916             /* integrate the new multideref op into the optree and the
12917              * op_next chain.
12918              *
12919              * In general an op like aelem or helem has two child
12920              * sub-trees: the aggregate expression (a_expr) and the
12921              * index expression (i_expr):
12922              *
12923              *     aelem
12924              *       |
12925              *     a_expr - i_expr
12926              *
12927              * The a_expr returns an AV or HV, while the i-expr returns an
12928              * index. In general a multideref replaces most or all of a
12929              * multi-level tree, e.g.
12930              *
12931              *     exists
12932              *       |
12933              *     ex-aelem
12934              *       |
12935              *     rv2av  - i_expr1
12936              *       |
12937              *     helem
12938              *       |
12939              *     rv2hv  - i_expr2
12940              *       |
12941              *     aelem
12942              *       |
12943              *     a_expr - i_expr3
12944              *
12945              * With multideref, all the i_exprs will be simple vars or
12946              * constants, except that i_expr1 may be arbitrary in the case
12947              * of MDEREF_INDEX_none.
12948              *
12949              * The bottom-most a_expr will be either:
12950              *   1) a simple var (so padXv or gv+rv2Xv);
12951              *   2) a simple scalar var dereferenced (e.g. $r->[0]):
12952              *      so a simple var with an extra rv2Xv;
12953              *   3) or an arbitrary expression.
12954              *
12955              * 'start', the first op in the execution chain, will point to
12956              *   1),2): the padXv or gv op;
12957              *   3):    the rv2Xv which forms the last op in the a_expr
12958              *          execution chain, and the top-most op in the a_expr
12959              *          subtree.
12960              *
12961              * For all cases, the 'start' node is no longer required,
12962              * but we can't free it since one or more external nodes
12963              * may point to it. E.g. consider
12964              *     $h{foo} = $a ? $b : $c
12965              * Here, both the op_next and op_other branches of the
12966              * cond_expr point to the gv[*h] of the hash expression, so
12967              * we can't free the 'start' op.
12968              *
12969              * For expr->[...], we need to save the subtree containing the
12970              * expression; for the other cases, we just need to save the
12971              * start node.
12972              * So in all cases, we null the start op and keep it around by
12973              * making it the child of the multideref op; for the expr->
12974              * case, the expr will be a subtree of the start node.
12975              *
12976              * So in the simple 1,2 case the  optree above changes to
12977              *
12978              *     ex-exists
12979              *       |
12980              *     multideref
12981              *       |
12982              *     ex-gv (or ex-padxv)
12983              *
12984              *  with the op_next chain being
12985              *
12986              *  -> ex-gv -> multideref -> op-following-ex-exists ->
12987              *
12988              *  In the 3 case, we have
12989              *
12990              *     ex-exists
12991              *       |
12992              *     multideref
12993              *       |
12994              *     ex-rv2xv
12995              *       |
12996              *    rest-of-a_expr
12997              *      subtree
12998              *
12999              *  and
13000              *
13001              *  -> rest-of-a_expr subtree ->
13002              *    ex-rv2xv -> multideref -> op-following-ex-exists ->
13003              *
13004              *
13005              * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
13006              * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
13007              * multideref attached as the child, e.g.
13008              *
13009              *     exists
13010              *       |
13011              *     ex-aelem
13012              *       |
13013              *     ex-rv2av  - i_expr1
13014              *       |
13015              *     multideref
13016              *       |
13017              *     ex-whatever
13018              *
13019              */
13020
13021             /* if we free this op, don't free the pad entry */
13022             if (reset_start_targ)
13023                 start->op_targ = 0;
13024
13025
13026             /* Cut the bit we need to save out of the tree and attach to
13027              * the multideref op, then free the rest of the tree */
13028
13029             /* find parent of node to be detached (for use by splice) */
13030             p = first_elem_op;
13031             if (   orig_action == MDEREF_AV_pop_rv2av_aelem
13032                 || orig_action == MDEREF_HV_pop_rv2hv_helem)
13033             {
13034                 /* there is an arbitrary expression preceding us, e.g.
13035                  * expr->[..]? so we need to save the 'expr' subtree */
13036                 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
13037                     p = cUNOPx(p)->op_first;
13038                 ASSUME(   start->op_type == OP_RV2AV
13039                        || start->op_type == OP_RV2HV);
13040             }
13041             else {
13042                 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
13043                  * above for exists/delete. */
13044                 while (   (p->op_flags & OPf_KIDS)
13045                        && cUNOPx(p)->op_first != start
13046                 )
13047                     p = cUNOPx(p)->op_first;
13048             }
13049             ASSUME(cUNOPx(p)->op_first == start);
13050
13051             /* detach from main tree, and re-attach under the multideref */
13052             op_sibling_splice(mderef, NULL, 0,
13053                     op_sibling_splice(p, NULL, 1, NULL));
13054             op_null(start);
13055
13056             start->op_next = mderef;
13057
13058             mderef->op_next = index_skip == -1 ? o->op_next : o;
13059
13060             /* excise and free the original tree, and replace with
13061              * the multideref op */
13062             p = op_sibling_splice(top_op, NULL, -1, mderef);
13063             while (p) {
13064                 q = OpSIBLING(p);
13065                 op_free(p);
13066                 p = q;
13067             }
13068             op_null(top_op);
13069         }
13070         else {
13071             Size_t size = arg - arg_buf;
13072
13073             if (maybe_aelemfast && action_count == 1)
13074                 return;
13075
13076             arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
13077                                 sizeof(UNOP_AUX_item) * (size + 1));
13078             /* for dumping etc: store the length in a hidden first slot;
13079              * we set the op_aux pointer to the second slot */
13080             arg_buf->uv = size;
13081             arg_buf++;
13082         }
13083     } /* for (pass = ...) */
13084 }
13085
13086
13087
13088 /* mechanism for deferring recursion in rpeep() */
13089
13090 #define MAX_DEFERRED 4
13091
13092 #define DEFER(o) \
13093   STMT_START { \
13094     if (defer_ix == (MAX_DEFERRED-1)) { \
13095         OP **defer = defer_queue[defer_base]; \
13096         CALL_RPEEP(*defer); \
13097         S_prune_chain_head(defer); \
13098         defer_base = (defer_base + 1) % MAX_DEFERRED; \
13099         defer_ix--; \
13100     } \
13101     defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
13102   } STMT_END
13103
13104 #define IS_AND_OP(o)   (o->op_type == OP_AND)
13105 #define IS_OR_OP(o)    (o->op_type == OP_OR)
13106
13107
13108 /* A peephole optimizer.  We visit the ops in the order they're to execute.
13109  * See the comments at the top of this file for more details about when
13110  * peep() is called */
13111
13112 void
13113 Perl_rpeep(pTHX_ OP *o)
13114 {
13115     dVAR;
13116     OP* oldop = NULL;
13117     OP* oldoldop = NULL;
13118     OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
13119     int defer_base = 0;
13120     int defer_ix = -1;
13121     OP *fop;
13122     OP *sop;
13123
13124     if (!o || o->op_opt)
13125         return;
13126     ENTER;
13127     SAVEOP();
13128     SAVEVPTR(PL_curcop);
13129     for (;; o = o->op_next) {
13130         if (o && o->op_opt)
13131             o = NULL;
13132         if (!o) {
13133             while (defer_ix >= 0) {
13134                 OP **defer =
13135                         defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
13136                 CALL_RPEEP(*defer);
13137                 S_prune_chain_head(defer);
13138             }
13139             break;
13140         }
13141
13142       redo:
13143
13144         /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */
13145         assert(!oldoldop || oldoldop->op_next == oldop);
13146         assert(!oldop    || oldop->op_next    == o);
13147
13148         /* By default, this op has now been optimised. A couple of cases below
13149            clear this again.  */
13150         o->op_opt = 1;
13151         PL_op = o;
13152
13153         /* look for a series of 1 or more aggregate derefs, e.g.
13154          *   $a[1]{foo}[$i]{$k}
13155          * and replace with a single OP_MULTIDEREF op.
13156          * Each index must be either a const, or a simple variable,
13157          *
13158          * First, look for likely combinations of starting ops,
13159          * corresponding to (global and lexical variants of)
13160          *     $a[...]   $h{...}
13161          *     $r->[...] $r->{...}
13162          *     (preceding expression)->[...]
13163          *     (preceding expression)->{...}
13164          * and if so, call maybe_multideref() to do a full inspection
13165          * of the op chain and if appropriate, replace with an
13166          * OP_MULTIDEREF
13167          */
13168         {
13169             UV action;
13170             OP *o2 = o;
13171             U8 hints = 0;
13172
13173             switch (o2->op_type) {
13174             case OP_GV:
13175                 /* $pkg[..]   :   gv[*pkg]
13176                  * $pkg->[...]:   gv[*pkg]; rv2sv sKM/DREFAV */
13177
13178                 /* Fail if there are new op flag combinations that we're
13179                  * not aware of, rather than:
13180                  *  * silently failing to optimise, or
13181                  *  * silently optimising the flag away.
13182                  * If this ASSUME starts failing, examine what new flag
13183                  * has been added to the op, and decide whether the
13184                  * optimisation should still occur with that flag, then
13185                  * update the code accordingly. This applies to all the
13186                  * other ASSUMEs in the block of code too.
13187                  */
13188                 ASSUME(!(o2->op_flags &
13189                             ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
13190                 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
13191
13192                 o2 = o2->op_next;
13193
13194                 if (o2->op_type == OP_RV2AV) {
13195                     action = MDEREF_AV_gvav_aelem;
13196                     goto do_deref;
13197                 }
13198
13199                 if (o2->op_type == OP_RV2HV) {
13200                     action = MDEREF_HV_gvhv_helem;
13201                     goto do_deref;
13202                 }
13203
13204                 if (o2->op_type != OP_RV2SV)
13205                     break;
13206
13207                 /* at this point we've seen gv,rv2sv, so the only valid
13208                  * construct left is $pkg->[] or $pkg->{} */
13209
13210                 ASSUME(!(o2->op_flags & OPf_STACKED));
13211                 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13212                             != (OPf_WANT_SCALAR|OPf_MOD))
13213                     break;
13214
13215                 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
13216                                     |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
13217                 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
13218                     break;
13219                 if (   (o2->op_private & OPpDEREF) != OPpDEREF_AV
13220                     && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
13221                     break;
13222
13223                 o2 = o2->op_next;
13224                 if (o2->op_type == OP_RV2AV) {
13225                     action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
13226                     goto do_deref;
13227                 }
13228                 if (o2->op_type == OP_RV2HV) {
13229                     action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
13230                     goto do_deref;
13231                 }
13232                 break;
13233
13234             case OP_PADSV:
13235                 /* $lex->[...]: padsv[$lex] sM/DREFAV */
13236
13237                 ASSUME(!(o2->op_flags &
13238                     ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
13239                 if ((o2->op_flags &
13240                         (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13241                      != (OPf_WANT_SCALAR|OPf_MOD))
13242                     break;
13243
13244                 ASSUME(!(o2->op_private &
13245                                 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
13246                 /* skip if state or intro, or not a deref */
13247                 if (      o2->op_private != OPpDEREF_AV
13248                        && o2->op_private != OPpDEREF_HV)
13249                     break;
13250
13251                 o2 = o2->op_next;
13252                 if (o2->op_type == OP_RV2AV) {
13253                     action = MDEREF_AV_padsv_vivify_rv2av_aelem;
13254                     goto do_deref;
13255                 }
13256                 if (o2->op_type == OP_RV2HV) {
13257                     action = MDEREF_HV_padsv_vivify_rv2hv_helem;
13258                     goto do_deref;
13259                 }
13260                 break;
13261
13262             case OP_PADAV:
13263             case OP_PADHV:
13264                 /*    $lex[..]:  padav[@lex:1,2] sR *
13265                  * or $lex{..}:  padhv[%lex:1,2] sR */
13266                 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
13267                                             OPf_REF|OPf_SPECIAL)));
13268                 if ((o2->op_flags &
13269                         (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13270                      != (OPf_WANT_SCALAR|OPf_REF))
13271                     break;
13272                 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
13273                     break;
13274                 /* OPf_PARENS isn't currently used in this case;
13275                  * if that changes, let us know! */
13276                 ASSUME(!(o2->op_flags & OPf_PARENS));
13277
13278                 /* at this point, we wouldn't expect any of the remaining
13279                  * possible private flags:
13280                  * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
13281                  * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
13282                  *
13283                  * OPpSLICEWARNING shouldn't affect runtime
13284                  */
13285                 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
13286
13287                 action = o2->op_type == OP_PADAV
13288                             ? MDEREF_AV_padav_aelem
13289                             : MDEREF_HV_padhv_helem;
13290                 o2 = o2->op_next;
13291                 S_maybe_multideref(aTHX_ o, o2, action, 0);
13292                 break;
13293
13294
13295             case OP_RV2AV:
13296             case OP_RV2HV:
13297                 action = o2->op_type == OP_RV2AV
13298                             ? MDEREF_AV_pop_rv2av_aelem
13299                             : MDEREF_HV_pop_rv2hv_helem;
13300                 /* FALLTHROUGH */
13301             do_deref:
13302                 /* (expr)->[...]:  rv2av sKR/1;
13303                  * (expr)->{...}:  rv2hv sKR/1; */
13304
13305                 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
13306
13307                 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
13308                                 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
13309                 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
13310                     break;
13311
13312                 /* at this point, we wouldn't expect any of these
13313                  * possible private flags:
13314                  * OPpMAYBE_LVSUB, OPpLVAL_INTRO
13315                  * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
13316                  */
13317                 ASSUME(!(o2->op_private &
13318                     ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
13319                      |OPpOUR_INTRO)));
13320                 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
13321
13322                 o2 = o2->op_next;
13323
13324                 S_maybe_multideref(aTHX_ o, o2, action, hints);
13325                 break;
13326
13327             default:
13328                 break;
13329             }
13330         }
13331
13332
13333         switch (o->op_type) {
13334         case OP_DBSTATE:
13335             PL_curcop = ((COP*)o);              /* for warnings */
13336             break;
13337         case OP_NEXTSTATE:
13338             PL_curcop = ((COP*)o);              /* for warnings */
13339
13340             /* Optimise a "return ..." at the end of a sub to just be "...".
13341              * This saves 2 ops. Before:
13342              * 1  <;> nextstate(main 1 -e:1) v ->2
13343              * 4  <@> return K ->5
13344              * 2    <0> pushmark s ->3
13345              * -    <1> ex-rv2sv sK/1 ->4
13346              * 3      <#> gvsv[*cat] s ->4
13347              *
13348              * After:
13349              * -  <@> return K ->-
13350              * -    <0> pushmark s ->2
13351              * -    <1> ex-rv2sv sK/1 ->-
13352              * 2      <$> gvsv(*cat) s ->3
13353              */
13354             {
13355                 OP *next = o->op_next;
13356                 OP *sibling = OpSIBLING(o);
13357                 if (   OP_TYPE_IS(next, OP_PUSHMARK)
13358                     && OP_TYPE_IS(sibling, OP_RETURN)
13359                     && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
13360                     && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
13361                        ||OP_TYPE_IS(sibling->op_next->op_next,
13362                                     OP_LEAVESUBLV))
13363                     && cUNOPx(sibling)->op_first == next
13364                     && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
13365                     && next->op_next
13366                 ) {
13367                     /* Look through the PUSHMARK's siblings for one that
13368                      * points to the RETURN */
13369                     OP *top = OpSIBLING(next);
13370                     while (top && top->op_next) {
13371                         if (top->op_next == sibling) {
13372                             top->op_next = sibling->op_next;
13373                             o->op_next = next->op_next;
13374                             break;
13375                         }
13376                         top = OpSIBLING(top);
13377                     }
13378                 }
13379             }
13380
13381             /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
13382              *
13383              * This latter form is then suitable for conversion into padrange
13384              * later on. Convert:
13385              *
13386              *   nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
13387              *
13388              * into:
13389              *
13390              *   nextstate1 ->     listop     -> nextstate3
13391              *                 /            \
13392              *         pushmark -> padop1 -> padop2
13393              */
13394             if (o->op_next && (
13395                     o->op_next->op_type == OP_PADSV
13396                  || o->op_next->op_type == OP_PADAV
13397                  || o->op_next->op_type == OP_PADHV
13398                 )
13399                 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
13400                 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
13401                 && o->op_next->op_next->op_next && (
13402                     o->op_next->op_next->op_next->op_type == OP_PADSV
13403                  || o->op_next->op_next->op_next->op_type == OP_PADAV
13404                  || o->op_next->op_next->op_next->op_type == OP_PADHV
13405                 )
13406                 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
13407                 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
13408                 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
13409                 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
13410             ) {
13411                 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
13412
13413                 pad1 =    o->op_next;
13414                 ns2  = pad1->op_next;
13415                 pad2 =  ns2->op_next;
13416                 ns3  = pad2->op_next;
13417
13418                 /* we assume here that the op_next chain is the same as
13419                  * the op_sibling chain */
13420                 assert(OpSIBLING(o)    == pad1);
13421                 assert(OpSIBLING(pad1) == ns2);
13422                 assert(OpSIBLING(ns2)  == pad2);
13423                 assert(OpSIBLING(pad2) == ns3);
13424
13425                 /* excise and delete ns2 */
13426                 op_sibling_splice(NULL, pad1, 1, NULL);
13427                 op_free(ns2);
13428
13429                 /* excise pad1 and pad2 */
13430                 op_sibling_splice(NULL, o, 2, NULL);
13431
13432                 /* create new listop, with children consisting of:
13433                  * a new pushmark, pad1, pad2. */
13434                 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
13435                 newop->op_flags |= OPf_PARENS;
13436                 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
13437
13438                 /* insert newop between o and ns3 */
13439                 op_sibling_splice(NULL, o, 0, newop);
13440
13441                 /*fixup op_next chain */
13442                 newpm = cUNOPx(newop)->op_first; /* pushmark */
13443                 o    ->op_next = newpm;
13444                 newpm->op_next = pad1;
13445                 pad1 ->op_next = pad2;
13446                 pad2 ->op_next = newop; /* listop */
13447                 newop->op_next = ns3;
13448
13449                 /* Ensure pushmark has this flag if padops do */
13450                 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
13451                     newpm->op_flags |= OPf_MOD;
13452                 }
13453
13454                 break;
13455             }
13456
13457             /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
13458                to carry two labels. For now, take the easier option, and skip
13459                this optimisation if the first NEXTSTATE has a label.  */
13460             if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
13461                 OP *nextop = o->op_next;
13462                 while (nextop && nextop->op_type == OP_NULL)
13463                     nextop = nextop->op_next;
13464
13465                 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
13466                     op_null(o);
13467                     if (oldop)
13468                         oldop->op_next = nextop;
13469                     o = nextop;
13470                     /* Skip (old)oldop assignment since the current oldop's
13471                        op_next already points to the next op.  */
13472                     goto redo;
13473                 }
13474             }
13475             break;
13476
13477         case OP_CONCAT:
13478             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
13479                 if (o->op_next->op_private & OPpTARGET_MY) {
13480                     if (o->op_flags & OPf_STACKED) /* chained concats */
13481                         break; /* ignore_optimization */
13482                     else {
13483                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
13484                         o->op_targ = o->op_next->op_targ;
13485                         o->op_next->op_targ = 0;
13486                         o->op_private |= OPpTARGET_MY;
13487                     }
13488                 }
13489                 op_null(o->op_next);
13490             }
13491             break;
13492         case OP_STUB:
13493             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
13494                 break; /* Scalar stub must produce undef.  List stub is noop */
13495             }
13496             goto nothin;
13497         case OP_NULL:
13498             if (o->op_targ == OP_NEXTSTATE
13499                 || o->op_targ == OP_DBSTATE)
13500             {
13501                 PL_curcop = ((COP*)o);
13502             }
13503             /* XXX: We avoid setting op_seq here to prevent later calls
13504                to rpeep() from mistakenly concluding that optimisation
13505                has already occurred. This doesn't fix the real problem,
13506                though (See 20010220.007). AMS 20010719 */
13507             /* op_seq functionality is now replaced by op_opt */
13508             o->op_opt = 0;
13509             /* FALLTHROUGH */
13510         case OP_SCALAR:
13511         case OP_LINESEQ:
13512         case OP_SCOPE:
13513         nothin:
13514             if (oldop) {
13515                 oldop->op_next = o->op_next;
13516                 o->op_opt = 0;
13517                 continue;
13518             }
13519             break;
13520
13521         case OP_PUSHMARK:
13522
13523             /* Given
13524                  5 repeat/DOLIST
13525                  3   ex-list
13526                  1     pushmark
13527                  2     scalar or const
13528                  4   const[0]
13529                convert repeat into a stub with no kids.
13530              */
13531             if (o->op_next->op_type == OP_CONST
13532              || (  o->op_next->op_type == OP_PADSV
13533                 && !(o->op_next->op_private & OPpLVAL_INTRO))
13534              || (  o->op_next->op_type == OP_GV
13535                 && o->op_next->op_next->op_type == OP_RV2SV
13536                 && !(o->op_next->op_next->op_private
13537                         & (OPpLVAL_INTRO|OPpOUR_INTRO))))
13538             {
13539                 const OP *kid = o->op_next->op_next;
13540                 if (o->op_next->op_type == OP_GV)
13541                    kid = kid->op_next;
13542                 /* kid is now the ex-list.  */
13543                 if (kid->op_type == OP_NULL
13544                  && (kid = kid->op_next)->op_type == OP_CONST
13545                     /* kid is now the repeat count.  */
13546                  && kid->op_next->op_type == OP_REPEAT
13547                  && kid->op_next->op_private & OPpREPEAT_DOLIST
13548                  && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
13549                  && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0)
13550                 {
13551                     o = kid->op_next; /* repeat */
13552                     assert(oldop);
13553                     oldop->op_next = o;
13554                     op_free(cBINOPo->op_first);
13555                     op_free(cBINOPo->op_last );
13556                     o->op_flags &=~ OPf_KIDS;
13557                     /* stub is a baseop; repeat is a binop */
13558                     STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
13559                     OpTYPE_set(o, OP_STUB);
13560                     o->op_private = 0;
13561                     break;
13562                 }
13563             }
13564
13565             /* Convert a series of PAD ops for my vars plus support into a
13566              * single padrange op. Basically
13567              *
13568              *    pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
13569              *
13570              * becomes, depending on circumstances, one of
13571              *
13572              *    padrange  ----------------------------------> (list) -> rest
13573              *    padrange  --------------------------------------------> rest
13574              *
13575              * where all the pad indexes are sequential and of the same type
13576              * (INTRO or not).
13577              * We convert the pushmark into a padrange op, then skip
13578              * any other pad ops, and possibly some trailing ops.
13579              * Note that we don't null() the skipped ops, to make it
13580              * easier for Deparse to undo this optimisation (and none of
13581              * the skipped ops are holding any resourses). It also makes
13582              * it easier for find_uninit_var(), as it can just ignore
13583              * padrange, and examine the original pad ops.
13584              */
13585         {
13586             OP *p;
13587             OP *followop = NULL; /* the op that will follow the padrange op */
13588             U8 count = 0;
13589             U8 intro = 0;
13590             PADOFFSET base = 0; /* init only to stop compiler whining */
13591             bool gvoid = 0;     /* init only to stop compiler whining */
13592             bool defav = 0;  /* seen (...) = @_ */
13593             bool reuse = 0;  /* reuse an existing padrange op */
13594
13595             /* look for a pushmark -> gv[_] -> rv2av */
13596
13597             {
13598                 OP *rv2av, *q;
13599                 p = o->op_next;
13600                 if (   p->op_type == OP_GV
13601                     && cGVOPx_gv(p) == PL_defgv
13602                     && (rv2av = p->op_next)
13603                     && rv2av->op_type == OP_RV2AV
13604                     && !(rv2av->op_flags & OPf_REF)
13605                     && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
13606                     && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
13607                 ) {
13608                     q = rv2av->op_next;
13609                     if (q->op_type == OP_NULL)
13610                         q = q->op_next;
13611                     if (q->op_type == OP_PUSHMARK) {
13612                         defav = 1;
13613                         p = q;
13614                     }
13615                 }
13616             }
13617             if (!defav) {
13618                 p = o;
13619             }
13620
13621             /* scan for PAD ops */
13622
13623             for (p = p->op_next; p; p = p->op_next) {
13624                 if (p->op_type == OP_NULL)
13625                     continue;
13626
13627                 if ((     p->op_type != OP_PADSV
13628                        && p->op_type != OP_PADAV
13629                        && p->op_type != OP_PADHV
13630                     )
13631                       /* any private flag other than INTRO? e.g. STATE */
13632                    || (p->op_private & ~OPpLVAL_INTRO)
13633                 )
13634                     break;
13635
13636                 /* let $a[N] potentially be optimised into AELEMFAST_LEX
13637                  * instead */
13638                 if (   p->op_type == OP_PADAV
13639                     && p->op_next
13640                     && p->op_next->op_type == OP_CONST
13641                     && p->op_next->op_next
13642                     && p->op_next->op_next->op_type == OP_AELEM
13643                 )
13644                     break;
13645
13646                 /* for 1st padop, note what type it is and the range
13647                  * start; for the others, check that it's the same type
13648                  * and that the targs are contiguous */
13649                 if (count == 0) {
13650                     intro = (p->op_private & OPpLVAL_INTRO);
13651                     base = p->op_targ;
13652                     gvoid = OP_GIMME(p,0) == G_VOID;
13653                 }
13654                 else {
13655                     if ((p->op_private & OPpLVAL_INTRO) != intro)
13656                         break;
13657                     /* Note that you'd normally  expect targs to be
13658                      * contiguous in my($a,$b,$c), but that's not the case
13659                      * when external modules start doing things, e.g.
13660                      i* Function::Parameters */
13661                     if (p->op_targ != base + count)
13662                         break;
13663                     assert(p->op_targ == base + count);
13664                     /* Either all the padops or none of the padops should
13665                        be in void context.  Since we only do the optimisa-
13666                        tion for av/hv when the aggregate itself is pushed
13667                        on to the stack (one item), there is no need to dis-
13668                        tinguish list from scalar context.  */
13669                     if (gvoid != (OP_GIMME(p,0) == G_VOID))
13670                         break;
13671                 }
13672
13673                 /* for AV, HV, only when we're not flattening */
13674                 if (   p->op_type != OP_PADSV
13675                     && !gvoid
13676                     && !(p->op_flags & OPf_REF)
13677                 )
13678                     break;
13679
13680                 if (count >= OPpPADRANGE_COUNTMASK)
13681                     break;
13682
13683                 /* there's a biggest base we can fit into a
13684                  * SAVEt_CLEARPADRANGE in pp_padrange.
13685                  * (The sizeof() stuff will be constant-folded, and is
13686                  * intended to avoid getting "comparison is always false"
13687                  * compiler warnings)
13688                  */
13689                 if (   intro
13690                     && (8*sizeof(base) >
13691                         8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
13692                         ? base : 0) >
13693                         (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
13694                 )
13695                     break;
13696
13697                 /* Success! We've got another valid pad op to optimise away */
13698                 count++;
13699                 followop = p->op_next;
13700             }
13701
13702             if (count < 1 || (count == 1 && !defav))
13703                 break;
13704
13705             /* pp_padrange in specifically compile-time void context
13706              * skips pushing a mark and lexicals; in all other contexts
13707              * (including unknown till runtime) it pushes a mark and the
13708              * lexicals. We must be very careful then, that the ops we
13709              * optimise away would have exactly the same effect as the
13710              * padrange.
13711              * In particular in void context, we can only optimise to
13712              * a padrange if see see the complete sequence
13713              *     pushmark, pad*v, ...., list
13714              * which has the net effect of of leaving the markstack as it
13715              * was.  Not pushing on to the stack (whereas padsv does touch
13716              * the stack) makes no difference in void context.
13717              */
13718             assert(followop);
13719             if (gvoid) {
13720                 if (followop->op_type == OP_LIST
13721                         && OP_GIMME(followop,0) == G_VOID
13722                    )
13723                 {
13724                     followop = followop->op_next; /* skip OP_LIST */
13725
13726                     /* consolidate two successive my(...);'s */
13727
13728                     if (   oldoldop
13729                         && oldoldop->op_type == OP_PADRANGE
13730                         && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
13731                         && (oldoldop->op_private & OPpLVAL_INTRO) == intro
13732                         && !(oldoldop->op_flags & OPf_SPECIAL)
13733                     ) {
13734                         U8 old_count;
13735                         assert(oldoldop->op_next == oldop);
13736                         assert(   oldop->op_type == OP_NEXTSTATE
13737                                || oldop->op_type == OP_DBSTATE);
13738                         assert(oldop->op_next == o);
13739
13740                         old_count
13741                             = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
13742
13743                        /* Do not assume pad offsets for $c and $d are con-
13744                           tiguous in
13745                             my ($a,$b,$c);
13746                             my ($d,$e,$f);
13747                         */
13748                         if (  oldoldop->op_targ + old_count == base
13749                            && old_count < OPpPADRANGE_COUNTMASK - count) {
13750                             base = oldoldop->op_targ;
13751                             count += old_count;
13752                             reuse = 1;
13753                         }
13754                     }
13755
13756                     /* if there's any immediately following singleton
13757                      * my var's; then swallow them and the associated
13758                      * nextstates; i.e.
13759                      *    my ($a,$b); my $c; my $d;
13760                      * is treated as
13761                      *    my ($a,$b,$c,$d);
13762                      */
13763
13764                     while (    ((p = followop->op_next))
13765                             && (  p->op_type == OP_PADSV
13766                                || p->op_type == OP_PADAV
13767                                || p->op_type == OP_PADHV)
13768                             && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
13769                             && (p->op_private & OPpLVAL_INTRO) == intro
13770                             && !(p->op_private & ~OPpLVAL_INTRO)
13771                             && p->op_next
13772                             && (   p->op_next->op_type == OP_NEXTSTATE
13773                                 || p->op_next->op_type == OP_DBSTATE)
13774                             && count < OPpPADRANGE_COUNTMASK
13775                             && base + count == p->op_targ
13776                     ) {
13777                         count++;
13778                         followop = p->op_next;
13779                     }
13780                 }
13781                 else
13782                     break;
13783             }
13784
13785             if (reuse) {
13786                 assert(oldoldop->op_type == OP_PADRANGE);
13787                 oldoldop->op_next = followop;
13788                 oldoldop->op_private = (intro | count);
13789                 o = oldoldop;
13790                 oldop = NULL;
13791                 oldoldop = NULL;
13792             }
13793             else {
13794                 /* Convert the pushmark into a padrange.
13795                  * To make Deparse easier, we guarantee that a padrange was
13796                  * *always* formerly a pushmark */
13797                 assert(o->op_type == OP_PUSHMARK);
13798                 o->op_next = followop;
13799                 OpTYPE_set(o, OP_PADRANGE);
13800                 o->op_targ = base;
13801                 /* bit 7: INTRO; bit 6..0: count */
13802                 o->op_private = (intro | count);
13803                 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
13804                               | gvoid * OPf_WANT_VOID
13805                               | (defav ? OPf_SPECIAL : 0));
13806             }
13807             break;
13808         }
13809
13810         case OP_PADAV:
13811         case OP_PADSV:
13812         case OP_PADHV:
13813         /* Skip over state($x) in void context.  */
13814         if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
13815          && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
13816         {
13817             oldop->op_next = o->op_next;
13818             goto redo_nextstate;
13819         }
13820         if (o->op_type != OP_PADAV)
13821             break;
13822         /* FALLTHROUGH */
13823         case OP_GV:
13824             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
13825                 OP* const pop = (o->op_type == OP_PADAV) ?
13826                             o->op_next : o->op_next->op_next;
13827                 IV i;
13828                 if (pop && pop->op_type == OP_CONST &&
13829                     ((PL_op = pop->op_next)) &&
13830                     pop->op_next->op_type == OP_AELEM &&
13831                     !(pop->op_next->op_private &
13832                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
13833                     (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
13834                 {
13835                     GV *gv;
13836                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
13837                         no_bareword_allowed(pop);
13838                     if (o->op_type == OP_GV)
13839                         op_null(o->op_next);
13840                     op_null(pop->op_next);
13841                     op_null(pop);
13842                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
13843                     o->op_next = pop->op_next->op_next;
13844                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
13845                     o->op_private = (U8)i;
13846                     if (o->op_type == OP_GV) {
13847                         gv = cGVOPo_gv;
13848                         GvAVn(gv);
13849                         o->op_type = OP_AELEMFAST;
13850                     }
13851                     else
13852                         o->op_type = OP_AELEMFAST_LEX;
13853                 }
13854                 if (o->op_type != OP_GV)
13855                     break;
13856             }
13857
13858             /* Remove $foo from the op_next chain in void context.  */
13859             if (oldop
13860              && (  o->op_next->op_type == OP_RV2SV
13861                 || o->op_next->op_type == OP_RV2AV
13862                 || o->op_next->op_type == OP_RV2HV  )
13863              && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
13864              && !(o->op_next->op_private & OPpLVAL_INTRO))
13865             {
13866                 oldop->op_next = o->op_next->op_next;
13867                 /* Reprocess the previous op if it is a nextstate, to
13868                    allow double-nextstate optimisation.  */
13869               redo_nextstate:
13870                 if (oldop->op_type == OP_NEXTSTATE) {
13871                     oldop->op_opt = 0;
13872                     o = oldop;
13873                     oldop = oldoldop;
13874                     oldoldop = NULL;
13875                     goto redo;
13876                 }
13877                 o = oldop->op_next;
13878                 goto redo;
13879             }
13880             else if (o->op_next->op_type == OP_RV2SV) {
13881                 if (!(o->op_next->op_private & OPpDEREF)) {
13882                     op_null(o->op_next);
13883                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
13884                                                                | OPpOUR_INTRO);
13885                     o->op_next = o->op_next->op_next;
13886                     OpTYPE_set(o, OP_GVSV);
13887                 }
13888             }
13889             else if (o->op_next->op_type == OP_READLINE
13890                     && o->op_next->op_next->op_type == OP_CONCAT
13891                     && (o->op_next->op_next->op_flags & OPf_STACKED))
13892             {
13893                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
13894                 OpTYPE_set(o, OP_RCATLINE);
13895                 o->op_flags |= OPf_STACKED;
13896                 op_null(o->op_next->op_next);
13897                 op_null(o->op_next);
13898             }
13899
13900             break;
13901
13902 #define HV_OR_SCALARHV(op)                                   \
13903     (  (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \
13904        ? (op)                                                  \
13905        : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \
13906        && (  cUNOPx(op)->op_first->op_type == OP_PADHV          \
13907           || cUNOPx(op)->op_first->op_type == OP_RV2HV)          \
13908          ? cUNOPx(op)->op_first                                   \
13909          : NULL)
13910
13911         case OP_NOT:
13912             if ((fop = HV_OR_SCALARHV(cUNOP->op_first)))
13913                 fop->op_private |= OPpTRUEBOOL;
13914             break;
13915
13916         case OP_AND:
13917         case OP_OR:
13918         case OP_DOR:
13919             fop = cLOGOP->op_first;
13920             sop = OpSIBLING(fop);
13921             while (cLOGOP->op_other->op_type == OP_NULL)
13922                 cLOGOP->op_other = cLOGOP->op_other->op_next;
13923             while (o->op_next && (   o->op_type == o->op_next->op_type
13924                                   || o->op_next->op_type == OP_NULL))
13925                 o->op_next = o->op_next->op_next;
13926
13927             /* if we're an OR and our next is a AND in void context, we'll
13928                follow it's op_other on short circuit, same for reverse.
13929                We can't do this with OP_DOR since if it's true, its return
13930                value is the underlying value which must be evaluated
13931                by the next op */
13932             if (o->op_next &&
13933                 (
13934                     (IS_AND_OP(o) && IS_OR_OP(o->op_next))
13935                  || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
13936                 )
13937                 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
13938             ) {
13939                 o->op_next = ((LOGOP*)o->op_next)->op_other;
13940             }
13941             DEFER(cLOGOP->op_other);
13942
13943             o->op_opt = 1;
13944             fop = HV_OR_SCALARHV(fop);
13945             if (sop) sop = HV_OR_SCALARHV(sop);
13946             if (fop || sop
13947             ){
13948                 OP * nop = o;
13949                 OP * lop = o;
13950                 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
13951                     while (nop && nop->op_next) {
13952                         switch (nop->op_next->op_type) {
13953                             case OP_NOT:
13954                             case OP_AND:
13955                             case OP_OR:
13956                             case OP_DOR:
13957                                 lop = nop = nop->op_next;
13958                                 break;
13959                             case OP_NULL:
13960                                 nop = nop->op_next;
13961                                 break;
13962                             default:
13963                                 nop = NULL;
13964                                 break;
13965                         }
13966                     }
13967                 }
13968                 if (fop) {
13969                     if (  (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
13970                       || o->op_type == OP_AND  )
13971                         fop->op_private |= OPpTRUEBOOL;
13972                     else if (!(lop->op_flags & OPf_WANT))
13973                         fop->op_private |= OPpMAYBE_TRUEBOOL;
13974                 }
13975                 if (  (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
13976                    && sop)
13977                     sop->op_private |= OPpTRUEBOOL;
13978             }
13979
13980
13981             break;
13982
13983         case OP_COND_EXPR:
13984             if ((fop = HV_OR_SCALARHV(cLOGOP->op_first)))
13985                 fop->op_private |= OPpTRUEBOOL;
13986 #undef HV_OR_SCALARHV
13987             /* GERONIMO! */ /* FALLTHROUGH */
13988
13989         case OP_MAPWHILE:
13990         case OP_GREPWHILE:
13991         case OP_ANDASSIGN:
13992         case OP_ORASSIGN:
13993         case OP_DORASSIGN:
13994         case OP_RANGE:
13995         case OP_ONCE:
13996             while (cLOGOP->op_other->op_type == OP_NULL)
13997                 cLOGOP->op_other = cLOGOP->op_other->op_next;
13998             DEFER(cLOGOP->op_other);
13999             break;
14000
14001         case OP_ENTERLOOP:
14002         case OP_ENTERITER:
14003             while (cLOOP->op_redoop->op_type == OP_NULL)
14004                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
14005             while (cLOOP->op_nextop->op_type == OP_NULL)
14006                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
14007             while (cLOOP->op_lastop->op_type == OP_NULL)
14008                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
14009             /* a while(1) loop doesn't have an op_next that escapes the
14010              * loop, so we have to explicitly follow the op_lastop to
14011              * process the rest of the code */
14012             DEFER(cLOOP->op_lastop);
14013             break;
14014
14015         case OP_ENTERTRY:
14016             assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
14017             DEFER(cLOGOPo->op_other);
14018             break;
14019
14020         case OP_SUBST:
14021             assert(!(cPMOP->op_pmflags & PMf_ONCE));
14022             while (cPMOP->op_pmstashstartu.op_pmreplstart &&
14023                    cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
14024                 cPMOP->op_pmstashstartu.op_pmreplstart
14025                     = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
14026             DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
14027             break;
14028
14029         case OP_SORT: {
14030             OP *oright;
14031
14032             if (o->op_flags & OPf_SPECIAL) {
14033                 /* first arg is a code block */
14034                 OP * const nullop = OpSIBLING(cLISTOP->op_first);
14035                 OP * kid          = cUNOPx(nullop)->op_first;
14036
14037                 assert(nullop->op_type == OP_NULL);
14038                 assert(kid->op_type == OP_SCOPE
14039                  || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
14040                 /* since OP_SORT doesn't have a handy op_other-style
14041                  * field that can point directly to the start of the code
14042                  * block, store it in the otherwise-unused op_next field
14043                  * of the top-level OP_NULL. This will be quicker at
14044                  * run-time, and it will also allow us to remove leading
14045                  * OP_NULLs by just messing with op_nexts without
14046                  * altering the basic op_first/op_sibling layout. */
14047                 kid = kLISTOP->op_first;
14048                 assert(
14049                       (kid->op_type == OP_NULL
14050                       && (  kid->op_targ == OP_NEXTSTATE
14051                          || kid->op_targ == OP_DBSTATE  ))
14052                     || kid->op_type == OP_STUB
14053                     || kid->op_type == OP_ENTER);
14054                 nullop->op_next = kLISTOP->op_next;
14055                 DEFER(nullop->op_next);
14056             }
14057
14058             /* check that RHS of sort is a single plain array */
14059             oright = cUNOPo->op_first;
14060             if (!oright || oright->op_type != OP_PUSHMARK)
14061                 break;
14062
14063             if (o->op_private & OPpSORT_INPLACE)
14064                 break;
14065
14066             /* reverse sort ... can be optimised.  */
14067             if (!OpHAS_SIBLING(cUNOPo)) {
14068                 /* Nothing follows us on the list. */
14069                 OP * const reverse = o->op_next;
14070
14071                 if (reverse->op_type == OP_REVERSE &&
14072                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
14073                     OP * const pushmark = cUNOPx(reverse)->op_first;
14074                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
14075                         && (OpSIBLING(cUNOPx(pushmark)) == o)) {
14076                         /* reverse -> pushmark -> sort */
14077                         o->op_private |= OPpSORT_REVERSE;
14078                         op_null(reverse);
14079                         pushmark->op_next = oright->op_next;
14080                         op_null(oright);
14081                     }
14082                 }
14083             }
14084
14085             break;
14086         }
14087
14088         case OP_REVERSE: {
14089             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
14090             OP *gvop = NULL;
14091             LISTOP *enter, *exlist;
14092
14093             if (o->op_private & OPpSORT_INPLACE)
14094                 break;
14095
14096             enter = (LISTOP *) o->op_next;
14097             if (!enter)
14098                 break;
14099             if (enter->op_type == OP_NULL) {
14100                 enter = (LISTOP *) enter->op_next;
14101                 if (!enter)
14102                     break;
14103             }
14104             /* for $a (...) will have OP_GV then OP_RV2GV here.
14105                for (...) just has an OP_GV.  */
14106             if (enter->op_type == OP_GV) {
14107                 gvop = (OP *) enter;
14108                 enter = (LISTOP *) enter->op_next;
14109                 if (!enter)
14110                     break;
14111                 if (enter->op_type == OP_RV2GV) {
14112                   enter = (LISTOP *) enter->op_next;
14113                   if (!enter)
14114                     break;
14115                 }
14116             }
14117
14118             if (enter->op_type != OP_ENTERITER)
14119                 break;
14120
14121             iter = enter->op_next;
14122             if (!iter || iter->op_type != OP_ITER)
14123                 break;
14124
14125             expushmark = enter->op_first;
14126             if (!expushmark || expushmark->op_type != OP_NULL
14127                 || expushmark->op_targ != OP_PUSHMARK)
14128                 break;
14129
14130             exlist = (LISTOP *) OpSIBLING(expushmark);
14131             if (!exlist || exlist->op_type != OP_NULL
14132                 || exlist->op_targ != OP_LIST)
14133                 break;
14134
14135             if (exlist->op_last != o) {
14136                 /* Mmm. Was expecting to point back to this op.  */
14137                 break;
14138             }
14139             theirmark = exlist->op_first;
14140             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
14141                 break;
14142
14143             if (OpSIBLING(theirmark) != o) {
14144                 /* There's something between the mark and the reverse, eg
14145                    for (1, reverse (...))
14146                    so no go.  */
14147                 break;
14148             }
14149
14150             ourmark = ((LISTOP *)o)->op_first;
14151             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
14152                 break;
14153
14154             ourlast = ((LISTOP *)o)->op_last;
14155             if (!ourlast || ourlast->op_next != o)
14156                 break;
14157
14158             rv2av = OpSIBLING(ourmark);
14159             if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
14160                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
14161                 /* We're just reversing a single array.  */
14162                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
14163                 enter->op_flags |= OPf_STACKED;
14164             }
14165
14166             /* We don't have control over who points to theirmark, so sacrifice
14167                ours.  */
14168             theirmark->op_next = ourmark->op_next;
14169             theirmark->op_flags = ourmark->op_flags;
14170             ourlast->op_next = gvop ? gvop : (OP *) enter;
14171             op_null(ourmark);
14172             op_null(o);
14173             enter->op_private |= OPpITER_REVERSED;
14174             iter->op_private |= OPpITER_REVERSED;
14175
14176             oldoldop = NULL;
14177             oldop    = ourlast;
14178             o        = oldop->op_next;
14179             goto redo;
14180
14181             break;
14182         }
14183
14184         case OP_QR:
14185         case OP_MATCH:
14186             if (!(cPMOP->op_pmflags & PMf_ONCE)) {
14187                 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
14188             }
14189             break;
14190
14191         case OP_RUNCV:
14192             if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
14193              && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
14194             {
14195                 SV *sv;
14196                 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
14197                 else {
14198                     sv = newRV((SV *)PL_compcv);
14199                     sv_rvweaken(sv);
14200                     SvREADONLY_on(sv);
14201                 }
14202                 OpTYPE_set(o, OP_CONST);
14203                 o->op_flags |= OPf_SPECIAL;
14204                 cSVOPo->op_sv = sv;
14205             }
14206             break;
14207
14208         case OP_SASSIGN:
14209             if (OP_GIMME(o,0) == G_VOID
14210              || (  o->op_next->op_type == OP_LINESEQ
14211                 && (  o->op_next->op_next->op_type == OP_LEAVESUB
14212                    || (  o->op_next->op_next->op_type == OP_RETURN
14213                       && !CvLVALUE(PL_compcv)))))
14214             {
14215                 OP *right = cBINOP->op_first;
14216                 if (right) {
14217                     /*   sassign
14218                     *      RIGHT
14219                     *      substr
14220                     *         pushmark
14221                     *         arg1
14222                     *         arg2
14223                     *         ...
14224                     * becomes
14225                     *
14226                     *  ex-sassign
14227                     *     substr
14228                     *        pushmark
14229                     *        RIGHT
14230                     *        arg1
14231                     *        arg2
14232                     *        ...
14233                     */
14234                     OP *left = OpSIBLING(right);
14235                     if (left->op_type == OP_SUBSTR
14236                          && (left->op_private & 7) < 4) {
14237                         op_null(o);
14238                         /* cut out right */
14239                         op_sibling_splice(o, NULL, 1, NULL);
14240                         /* and insert it as second child of OP_SUBSTR */
14241                         op_sibling_splice(left, cBINOPx(left)->op_first, 0,
14242                                     right);
14243                         left->op_private |= OPpSUBSTR_REPL_FIRST;
14244                         left->op_flags =
14245                             (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
14246                     }
14247                 }
14248             }
14249             break;
14250
14251         case OP_AASSIGN: {
14252             int l, r, lr, lscalars, rscalars;
14253
14254             /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
14255                Note that we do this now rather than in newASSIGNOP(),
14256                since only by now are aliased lexicals flagged as such
14257
14258                See the essay "Common vars in list assignment" above for
14259                the full details of the rationale behind all the conditions
14260                below.
14261
14262                PL_generation sorcery:
14263                To detect whether there are common vars, the global var
14264                PL_generation is incremented for each assign op we scan.
14265                Then we run through all the lexical variables on the LHS,
14266                of the assignment, setting a spare slot in each of them to
14267                PL_generation.  Then we scan the RHS, and if any lexicals
14268                already have that value, we know we've got commonality.
14269                Also, if the generation number is already set to
14270                PERL_INT_MAX, then the variable is involved in aliasing, so
14271                we also have potential commonality in that case.
14272              */
14273
14274             PL_generation++;
14275             /* scan LHS */
14276             lscalars = 0;
14277             l = S_aassign_scan(aTHX_ cLISTOPo->op_last,  FALSE, 1, &lscalars);
14278             /* scan RHS */
14279             rscalars = 0;
14280             r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, 1, &rscalars);
14281             lr = (l|r);
14282
14283
14284             /* After looking for things which are *always* safe, this main
14285              * if/else chain selects primarily based on the type of the
14286              * LHS, gradually working its way down from the more dangerous
14287              * to the more restrictive and thus safer cases */
14288
14289             if (   !l                      /* () = ....; */
14290                 || !r                      /* .... = (); */
14291                 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
14292                 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
14293                 || (lscalars < 2)          /* ($x, undef) = ... */
14294             ) {
14295                 NOOP; /* always safe */
14296             }
14297             else if (l & AAS_DANGEROUS) {
14298                 /* always dangerous */
14299                 o->op_private |= OPpASSIGN_COMMON_SCALAR;
14300                 o->op_private |= OPpASSIGN_COMMON_AGG;
14301             }
14302             else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
14303                 /* package vars are always dangerous - too many
14304                  * aliasing possibilities */
14305                 if (l & AAS_PKG_SCALAR)
14306                     o->op_private |= OPpASSIGN_COMMON_SCALAR;
14307                 if (l & AAS_PKG_AGG)
14308                     o->op_private |= OPpASSIGN_COMMON_AGG;
14309             }
14310             else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
14311                           |AAS_LEX_SCALAR|AAS_LEX_AGG))
14312             {
14313                 /* LHS contains only lexicals and safe ops */
14314
14315                 if (l & (AAS_MY_AGG|AAS_LEX_AGG))
14316                     o->op_private |= OPpASSIGN_COMMON_AGG;
14317
14318                 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
14319                     if (lr & AAS_LEX_SCALAR_COMM)
14320                         o->op_private |= OPpASSIGN_COMMON_SCALAR;
14321                     else if (   !(l & AAS_LEX_SCALAR)
14322                              && (r & AAS_DEFAV))
14323                     {
14324                         /* falsely mark
14325                          *    my (...) = @_
14326                          * as scalar-safe for performance reasons.
14327                          * (it will still have been marked _AGG if necessary */
14328                         NOOP;
14329                     }
14330                     else if (r  & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
14331                         o->op_private |= OPpASSIGN_COMMON_RC1;
14332                 }
14333             }
14334
14335             /* ... = ($x)
14336              * may have to handle aggregate on LHS, but we can't
14337              * have common scalars. */
14338             if (rscalars < 2)
14339                 o->op_private &=
14340                         ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
14341
14342             break;
14343         }
14344
14345         case OP_CUSTOM: {
14346             Perl_cpeep_t cpeep =
14347                 XopENTRYCUSTOM(o, xop_peep);
14348             if (cpeep)
14349                 cpeep(aTHX_ o, oldop);
14350             break;
14351         }
14352
14353         }
14354         /* did we just null the current op? If so, re-process it to handle
14355          * eliding "empty" ops from the chain */
14356         if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
14357             o->op_opt = 0;
14358             o = oldop;
14359         }
14360         else {
14361             oldoldop = oldop;
14362             oldop = o;
14363         }
14364     }
14365     LEAVE;
14366 }
14367
14368 void
14369 Perl_peep(pTHX_ OP *o)
14370 {
14371     CALL_RPEEP(o);
14372 }
14373
14374 /*
14375 =head1 Custom Operators
14376
14377 =for apidoc Ao||custom_op_xop
14378 Return the XOP structure for a given custom op.  This macro should be
14379 considered internal to C<OP_NAME> and the other access macros: use them instead.
14380 This macro does call a function.  Prior
14381 to 5.19.6, this was implemented as a
14382 function.
14383
14384 =cut
14385 */
14386
14387 XOPRETANY
14388 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
14389 {
14390     SV *keysv;
14391     HE *he = NULL;
14392     XOP *xop;
14393
14394     static const XOP xop_null = { 0, 0, 0, 0, 0 };
14395
14396     PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
14397     assert(o->op_type == OP_CUSTOM);
14398
14399     /* This is wrong. It assumes a function pointer can be cast to IV,
14400      * which isn't guaranteed, but this is what the old custom OP code
14401      * did. In principle it should be safer to Copy the bytes of the
14402      * pointer into a PV: since the new interface is hidden behind
14403      * functions, this can be changed later if necessary.  */
14404     /* Change custom_op_xop if this ever happens */
14405     keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
14406
14407     if (PL_custom_ops)
14408         he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
14409
14410     /* assume noone will have just registered a desc */
14411     if (!he && PL_custom_op_names &&
14412         (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
14413     ) {
14414         const char *pv;
14415         STRLEN l;
14416
14417         /* XXX does all this need to be shared mem? */
14418         Newxz(xop, 1, XOP);
14419         pv = SvPV(HeVAL(he), l);
14420         XopENTRY_set(xop, xop_name, savepvn(pv, l));
14421         if (PL_custom_op_descs &&
14422             (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
14423         ) {
14424             pv = SvPV(HeVAL(he), l);
14425             XopENTRY_set(xop, xop_desc, savepvn(pv, l));
14426         }
14427         Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
14428     }
14429     else {
14430         if (!he)
14431             xop = (XOP *)&xop_null;
14432         else
14433             xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
14434     }
14435     {
14436         XOPRETANY any;
14437         if(field == XOPe_xop_ptr) {
14438             any.xop_ptr = xop;
14439         } else {
14440             const U32 flags = XopFLAGS(xop);
14441             if(flags & field) {
14442                 switch(field) {
14443                 case XOPe_xop_name:
14444                     any.xop_name = xop->xop_name;
14445                     break;
14446                 case XOPe_xop_desc:
14447                     any.xop_desc = xop->xop_desc;
14448                     break;
14449                 case XOPe_xop_class:
14450                     any.xop_class = xop->xop_class;
14451                     break;
14452                 case XOPe_xop_peep:
14453                     any.xop_peep = xop->xop_peep;
14454                     break;
14455                 default:
14456                     NOT_REACHED; /* NOTREACHED */
14457                     break;
14458                 }
14459             } else {
14460                 switch(field) {
14461                 case XOPe_xop_name:
14462                     any.xop_name = XOPd_xop_name;
14463                     break;
14464                 case XOPe_xop_desc:
14465                     any.xop_desc = XOPd_xop_desc;
14466                     break;
14467                 case XOPe_xop_class:
14468                     any.xop_class = XOPd_xop_class;
14469                     break;
14470                 case XOPe_xop_peep:
14471                     any.xop_peep = XOPd_xop_peep;
14472                     break;
14473                 default:
14474                     NOT_REACHED; /* NOTREACHED */
14475                     break;
14476                 }
14477             }
14478         }
14479         /* On some platforms (HP-UX, IA64) gcc emits a warning for this function:
14480          * op.c: In function 'Perl_custom_op_get_field':
14481          * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
14482          * This is because on those platforms (with -DEBUGGING) NOT_REACHED
14483          * expands to assert(0), which expands to ((0) ? (void)0 :
14484          * __assert(...)), and gcc doesn't know that __assert can never return. */
14485         return any;
14486     }
14487 }
14488
14489 /*
14490 =for apidoc Ao||custom_op_register
14491 Register a custom op.  See L<perlguts/"Custom Operators">.
14492
14493 =cut
14494 */
14495
14496 void
14497 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
14498 {
14499     SV *keysv;
14500
14501     PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
14502
14503     /* see the comment in custom_op_xop */
14504     keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
14505
14506     if (!PL_custom_ops)
14507         PL_custom_ops = newHV();
14508
14509     if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
14510         Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
14511 }
14512
14513 /*
14514
14515 =for apidoc core_prototype
14516
14517 This function assigns the prototype of the named core function to C<sv>, or
14518 to a new mortal SV if C<sv> is C<NULL>.  It returns the modified C<sv>, or
14519 C<NULL> if the core function has no prototype.  C<code> is a code as returned
14520 by C<keyword()>.  It must not be equal to 0.
14521
14522 =cut
14523 */
14524
14525 SV *
14526 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
14527                           int * const opnum)
14528 {
14529     int i = 0, n = 0, seen_question = 0, defgv = 0;
14530     I32 oa;
14531 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
14532     char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
14533     bool nullret = FALSE;
14534
14535     PERL_ARGS_ASSERT_CORE_PROTOTYPE;
14536
14537     assert (code);
14538
14539     if (!sv) sv = sv_newmortal();
14540
14541 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
14542
14543     switch (code < 0 ? -code : code) {
14544     case KEY_and   : case KEY_chop: case KEY_chomp:
14545     case KEY_cmp   : case KEY_defined: case KEY_delete: case KEY_exec  :
14546     case KEY_exists: case KEY_eq     : case KEY_ge    : case KEY_goto  :
14547     case KEY_grep  : case KEY_gt     : case KEY_last  : case KEY_le    :
14548     case KEY_lt    : case KEY_map    : case KEY_ne    : case KEY_next  :
14549     case KEY_or    : case KEY_print  : case KEY_printf: case KEY_qr    :
14550     case KEY_redo  : case KEY_require: case KEY_return: case KEY_say   :
14551     case KEY_select: case KEY_sort   : case KEY_split : case KEY_system:
14552     case KEY_x     : case KEY_xor    :
14553         if (!opnum) return NULL; nullret = TRUE; goto findopnum;
14554     case KEY_glob:    retsetpvs("_;", OP_GLOB);
14555     case KEY_keys:    retsetpvs("\\[%@]", OP_KEYS);
14556     case KEY_values:  retsetpvs("\\[%@]", OP_VALUES);
14557     case KEY_each:    retsetpvs("\\[%@]", OP_EACH);
14558     case KEY_push:    retsetpvs("\\@@", OP_PUSH);
14559     case KEY_unshift: retsetpvs("\\@@", OP_UNSHIFT);
14560     case KEY_pop:     retsetpvs(";\\@", OP_POP);
14561     case KEY_shift:   retsetpvs(";\\@", OP_SHIFT);
14562     case KEY_pos:     retsetpvs(";\\[$*]", OP_POS);
14563     case KEY_splice:
14564         retsetpvs("\\@;$$@", OP_SPLICE);
14565     case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
14566         retsetpvs("", 0);
14567     case KEY_evalbytes:
14568         name = "entereval"; break;
14569     case KEY_readpipe:
14570         name = "backtick";
14571     }
14572
14573 #undef retsetpvs
14574
14575   findopnum:
14576     while (i < MAXO) {  /* The slow way. */
14577         if (strEQ(name, PL_op_name[i])
14578             || strEQ(name, PL_op_desc[i]))
14579         {
14580             if (nullret) { assert(opnum); *opnum = i; return NULL; }
14581             goto found;
14582         }
14583         i++;
14584     }
14585     return NULL;
14586   found:
14587     defgv = PL_opargs[i] & OA_DEFGV;
14588     oa = PL_opargs[i] >> OASHIFT;
14589     while (oa) {
14590         if (oa & OA_OPTIONAL && !seen_question && (
14591               !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
14592         )) {
14593             seen_question = 1;
14594             str[n++] = ';';
14595         }
14596         if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
14597             && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
14598             /* But globs are already references (kinda) */
14599             && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
14600         ) {
14601             str[n++] = '\\';
14602         }
14603         if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
14604          && !scalar_mod_type(NULL, i)) {
14605             str[n++] = '[';
14606             str[n++] = '$';
14607             str[n++] = '@';
14608             str[n++] = '%';
14609             if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
14610             str[n++] = '*';
14611             str[n++] = ']';
14612         }
14613         else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
14614         if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
14615             str[n-1] = '_'; defgv = 0;
14616         }
14617         oa = oa >> 4;
14618     }
14619     if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
14620     str[n++] = '\0';
14621     sv_setpvn(sv, str, n - 1);
14622     if (opnum) *opnum = i;
14623     return sv;
14624 }
14625
14626 OP *
14627 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
14628                       const int opnum)
14629 {
14630     OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
14631     OP *o;
14632
14633     PERL_ARGS_ASSERT_CORESUB_OP;
14634
14635     switch(opnum) {
14636     case 0:
14637         return op_append_elem(OP_LINESEQ,
14638                        argop,
14639                        newSLICEOP(0,
14640                                   newSVOP(OP_CONST, 0, newSViv(-code % 3)),
14641                                   newOP(OP_CALLER,0)
14642                        )
14643                );
14644     case OP_SELECT: /* which represents OP_SSELECT as well */
14645         if (code)
14646             return newCONDOP(
14647                          0,
14648                          newBINOP(OP_GT, 0,
14649                                   newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
14650                                   newSVOP(OP_CONST, 0, newSVuv(1))
14651                                  ),
14652                          coresub_op(newSVuv((UV)OP_SSELECT), 0,
14653                                     OP_SSELECT),
14654                          coresub_op(coreargssv, 0, OP_SELECT)
14655                    );
14656         /* FALLTHROUGH */
14657     default:
14658         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
14659         case OA_BASEOP:
14660             return op_append_elem(
14661                         OP_LINESEQ, argop,
14662                         newOP(opnum,
14663                               opnum == OP_WANTARRAY || opnum == OP_RUNCV
14664                                 ? OPpOFFBYONE << 8 : 0)
14665                    );
14666         case OA_BASEOP_OR_UNOP:
14667             if (opnum == OP_ENTEREVAL) {
14668                 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
14669                 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
14670             }
14671             else o = newUNOP(opnum,0,argop);
14672             if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
14673             else {
14674           onearg:
14675               if (is_handle_constructor(o, 1))
14676                 argop->op_private |= OPpCOREARGS_DEREF1;
14677               if (scalar_mod_type(NULL, opnum))
14678                 argop->op_private |= OPpCOREARGS_SCALARMOD;
14679             }
14680             return o;
14681         default:
14682             o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
14683             if (is_handle_constructor(o, 2))
14684                 argop->op_private |= OPpCOREARGS_DEREF2;
14685             if (opnum == OP_SUBSTR) {
14686                 o->op_private |= OPpMAYBE_LVSUB;
14687                 return o;
14688             }
14689             else goto onearg;
14690         }
14691     }
14692 }
14693
14694 void
14695 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
14696                                SV * const *new_const_svp)
14697 {
14698     const char *hvname;
14699     bool is_const = !!CvCONST(old_cv);
14700     SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
14701
14702     PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
14703
14704     if (is_const && new_const_svp && old_const_sv == *new_const_svp)
14705         return;
14706         /* They are 2 constant subroutines generated from
14707            the same constant. This probably means that
14708            they are really the "same" proxy subroutine
14709            instantiated in 2 places. Most likely this is
14710            when a constant is exported twice.  Don't warn.
14711         */
14712     if (
14713         (ckWARN(WARN_REDEFINE)
14714          && !(
14715                 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
14716              && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
14717              && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
14718                  strEQ(hvname, "autouse"))
14719              )
14720         )
14721      || (is_const
14722          && ckWARN_d(WARN_REDEFINE)
14723          && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
14724         )
14725     )
14726         Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
14727                           is_const
14728                             ? "Constant subroutine %"SVf" redefined"
14729                             : "Subroutine %"SVf" redefined",
14730                           SVfARG(name));
14731 }
14732
14733 /*
14734 =head1 Hook manipulation
14735
14736 These functions provide convenient and thread-safe means of manipulating
14737 hook variables.
14738
14739 =cut
14740 */
14741
14742 /*
14743 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
14744
14745 Puts a C function into the chain of check functions for a specified op
14746 type.  This is the preferred way to manipulate the L</PL_check> array.
14747 C<opcode> specifies which type of op is to be affected.  C<new_checker>
14748 is a pointer to the C function that is to be added to that opcode's
14749 check chain, and C<old_checker_p> points to the storage location where a
14750 pointer to the next function in the chain will be stored.  The value of
14751 C<new_pointer> is written into the L</PL_check> array, while the value
14752 previously stored there is written to C<*old_checker_p>.
14753
14754 The function should be defined like this:
14755
14756     static OP *new_checker(pTHX_ OP *op) { ... }
14757
14758 It is intended to be called in this manner:
14759
14760     new_checker(aTHX_ op)
14761
14762 C<old_checker_p> should be defined like this:
14763
14764     static Perl_check_t old_checker_p;
14765
14766 L</PL_check> is global to an entire process, and a module wishing to
14767 hook op checking may find itself invoked more than once per process,
14768 typically in different threads.  To handle that situation, this function
14769 is idempotent.  The location C<*old_checker_p> must initially (once
14770 per process) contain a null pointer.  A C variable of static duration
14771 (declared at file scope, typically also marked C<static> to give
14772 it internal linkage) will be implicitly initialised appropriately,
14773 if it does not have an explicit initialiser.  This function will only
14774 actually modify the check chain if it finds C<*old_checker_p> to be null.
14775 This function is also thread safe on the small scale.  It uses appropriate
14776 locking to avoid race conditions in accessing L</PL_check>.
14777
14778 When this function is called, the function referenced by C<new_checker>
14779 must be ready to be called, except for C<*old_checker_p> being unfilled.
14780 In a threading situation, C<new_checker> may be called immediately,
14781 even before this function has returned.  C<*old_checker_p> will always
14782 be appropriately set before C<new_checker> is called.  If C<new_checker>
14783 decides not to do anything special with an op that it is given (which
14784 is the usual case for most uses of op check hooking), it must chain the
14785 check function referenced by C<*old_checker_p>.
14786
14787 If you want to influence compilation of calls to a specific subroutine,
14788 then use L</cv_set_call_checker> rather than hooking checking of all
14789 C<entersub> ops.
14790
14791 =cut
14792 */
14793
14794 void
14795 Perl_wrap_op_checker(pTHX_ Optype opcode,
14796     Perl_check_t new_checker, Perl_check_t *old_checker_p)
14797 {
14798     dVAR;
14799
14800     PERL_UNUSED_CONTEXT;
14801     PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
14802     if (*old_checker_p) return;
14803     OP_CHECK_MUTEX_LOCK;
14804     if (!*old_checker_p) {
14805         *old_checker_p = PL_check[opcode];
14806         PL_check[opcode] = new_checker;
14807     }
14808     OP_CHECK_MUTEX_UNLOCK;
14809 }
14810
14811 #include "XSUB.h"
14812
14813 /* Efficient sub that returns a constant scalar value. */
14814 static void
14815 const_sv_xsub(pTHX_ CV* cv)
14816 {
14817     dXSARGS;
14818     SV *const sv = MUTABLE_SV(XSANY.any_ptr);
14819     PERL_UNUSED_ARG(items);
14820     if (!sv) {
14821         XSRETURN(0);
14822     }
14823     EXTEND(sp, 1);
14824     ST(0) = sv;
14825     XSRETURN(1);
14826 }
14827
14828 static void
14829 const_av_xsub(pTHX_ CV* cv)
14830 {
14831     dXSARGS;
14832     AV * const av = MUTABLE_AV(XSANY.any_ptr);
14833     SP -= items;
14834     assert(av);
14835 #ifndef DEBUGGING
14836     if (!av) {
14837         XSRETURN(0);
14838     }
14839 #endif
14840     if (SvRMAGICAL(av))
14841         Perl_croak(aTHX_ "Magical list constants are not supported");
14842     if (GIMME_V != G_ARRAY) {
14843         EXTEND(SP, 1);
14844         ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
14845         XSRETURN(1);
14846     }
14847     EXTEND(SP, AvFILLp(av)+1);
14848     Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
14849     XSRETURN(AvFILLp(av)+1);
14850 }
14851
14852 /*
14853  * ex: set ts=8 sts=4 sw=4 et:
14854  */