op.c

   1 #line 2 "op.c"
   2 /*    op.c
   3  *
   4  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
   5  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
   6  *
   7  *    You may distribute under the terms of either the GNU General Public
   8  *    License or the Artistic License, as specified in the README file.
   9  *
  10  */
  11
  12 /*
  13  * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck.  She was
  14  *  our Mr. Bilbo's first cousin on the mother's side (her mother being the
  15  *  youngest of the Old Took's daughters); and Mr. Drogo was his second
  16  *  cousin.  So Mr. Frodo is his first *and* second cousin, once removed
  17  *  either way, as the saying is, if you follow me.'       --the Gaffer
  18  *
  19  *     [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
  20  */
  21
  22 /* This file contains the functions that create, manipulate and optimize
  23  * the OP structures that hold a compiled perl program.
  24  *
  25  * A Perl program is compiled into a tree of OPs. Each op contains
  26  * structural pointers (eg to its siblings and the next op in the
  27  * execution sequence), a pointer to the function that would execute the
  28  * op, plus any data specific to that op. For example, an OP_CONST op
  29  * points to the pp_const() function and to an SV containing the constant
  30  * value. When pp_const() is executed, its job is to push that SV onto the
  31  * stack.
  32  *
  33  * OPs are mainly created by the newFOO() functions, which are mainly
  34  * called from the parser (in perly.y) as the code is parsed. For example
  35  * the Perl code $a + $b * $c would cause the equivalent of the following
  36  * to be called (oversimplifying a bit):
  37  *
  38  *  newBINOP(OP_ADD, flags,
  39  *      newSVREF($a),
  40  *      newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
  41  *  )
  42  *
  43  * Note that during the build of miniperl, a temporary copy of this file
  44  * is made, called opmini.c.
  45  */
  46
  47 /*
  48 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
  49
  50     A bottom-up pass
  51     A top-down pass
  52     An execution-order pass
  53
  54 The bottom-up pass is represented by all the "newOP" routines and
  55 the ck_ routines.  The bottom-upness is actually driven by yacc.
  56 So at the point that a ck_ routine fires, we have no idea what the
  57 context is, either upward in the syntax tree, or either forward or
  58 backward in the execution order.  (The bottom-up parser builds that
  59 part of the execution order it knows about, but if you follow the "next"
  60 links around, you'll find it's actually a closed loop through the
  61 top level node.)
  62
  63 Whenever the bottom-up parser gets to a node that supplies context to
  64 its components, it invokes that portion of the top-down pass that applies
  65 to that part of the subtree (and marks the top node as processed, so
  66 if a node further up supplies context, it doesn't have to take the
  67 plunge again).  As a particular subcase of this, as the new node is
  68 built, it takes all the closed execution loops of its subcomponents
  69 and links them into a new closed loop for the higher level node.  But
  70 it's still not the real execution order.
  71
  72 The actual execution order is not known till we get a grammar reduction
  73 to a top-level unit like a subroutine or file that will be called by
  74 "name" rather than via a "next" pointer.  At that point, we can call
  75 into peep() to do that code's portion of the 3rd pass.  It has to be
  76 recursive, but it's recursive on basic blocks, not on tree nodes.
  77 */
  78
  79 /* To implement user lexical pragmas, there needs to be a way at run time to
  80    get the compile time state of %^H for that block.  Storing %^H in every
  81    block (or even COP) would be very expensive, so a different approach is
  82    taken.  The (running) state of %^H is serialised into a tree of HE-like
  83    structs.  Stores into %^H are chained onto the current leaf as a struct
  84    refcounted_he * with the key and the value.  Deletes from %^H are saved
  85    with a value of PL_sv_placeholder.  The state of %^H at any point can be
  86    turned back into a regular HV by walking back up the tree from that point's
  87    leaf, ignoring any key you've already seen (placeholder or not), storing
  88    the rest into the HV structure, then removing the placeholders. Hence
  89    memory is only used to store the %^H deltas from the enclosing COP, rather
  90    than the entire %^H on each COP.
  91
  92    To cause actions on %^H to write out the serialisation records, it has
  93    magic type 'H'. This magic (itself) does nothing, but its presence causes
  94    the values to gain magic type 'h', which has entries for set and clear.
  95    C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
  96    record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
  97    saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
  98    it will be correctly restored when any inner compiling scope is exited.
  99 */
 100
 101 #include "EXTERN.h"
 102 #define PERL_IN_OP_C
 103 #include "perl.h"
 104 #include "keywords.h"
 105 #include "feature.h"
 106 #include "regcomp.h"
 107
 108 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
 109 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
 110 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
 111
 112 /* Used to avoid recursion through the op tree in scalarvoid() and
 113    op_free()
 114 */
 115
 116 #define DEFERRED_OP_STEP 100
 117 #define DEFER_OP(o) \
 118   STMT_START { \
 119     if (UNLIKELY(defer_ix == (defer_stack_alloc-1))) {    \
 120         defer_stack_alloc += DEFERRED_OP_STEP; \
 121         assert(defer_stack_alloc > 0); \
 122         Renew(defer_stack, defer_stack_alloc, OP *); \
 123     } \
 124     defer_stack[++defer_ix] = o; \
 125   } STMT_END
 126
 127 #define POP_DEFERRED_OP() (defer_ix >= 0 ? defer_stack[defer_ix--] : (OP *)NULL)
 128
 129 /* remove any leading "empty" ops from the op_next chain whose first
 130  * node's address is stored in op_p. Store the updated address of the
 131  * first node in op_p.
 132  */
 133
 134 STATIC void
 135 S_prune_chain_head(OP** op_p)
 136 {
 137     while (*op_p
 138         && (   (*op_p)->op_type == OP_NULL
 139             || (*op_p)->op_type == OP_SCOPE
 140             || (*op_p)->op_type == OP_SCALAR
 141             || (*op_p)->op_type == OP_LINESEQ)
 142     )
 143         *op_p = (*op_p)->op_next;
 144 }
 145
 146
 147 /* See the explanatory comments above struct opslab in op.h. */
 148
 149 #ifdef PERL_DEBUG_READONLY_OPS
 150 #  define PERL_SLAB_SIZE 128
 151 #  define PERL_MAX_SLAB_SIZE 4096
 152 #  include <sys/mman.h>
 153 #endif
 154
 155 #ifndef PERL_SLAB_SIZE
 156 #  define PERL_SLAB_SIZE 64
 157 #endif
 158 #ifndef PERL_MAX_SLAB_SIZE
 159 #  define PERL_MAX_SLAB_SIZE 2048
 160 #endif
 161
 162 /* rounds up to nearest pointer */
 163 #define SIZE_TO_PSIZE(x)        (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
 164 #define DIFF(o,p)               ((size_t)((I32 **)(p) - (I32**)(o)))
 165
 166 static OPSLAB *
 167 S_new_slab(pTHX_ size_t sz)
 168 {
 169 #ifdef PERL_DEBUG_READONLY_OPS
 170     OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
 171                                    PROT_READ|PROT_WRITE,
 172                                    MAP_ANON|MAP_PRIVATE, -1, 0);
 173     DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
 174                           (unsigned long) sz, slab));
 175     if (slab == MAP_FAILED) {
 176         perror("mmap failed");
 177         abort();
 178     }
 179     slab->opslab_size = (U16)sz;
 180 #else
 181     OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
 182 #endif
 183 #ifndef WIN32
 184     /* The context is unused in non-Windows */
 185     PERL_UNUSED_CONTEXT;
 186 #endif
 187     slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
 188     return slab;
 189 }
 190
 191 /* requires double parens and aTHX_ */
 192 #define DEBUG_S_warn(args)                                             \
 193     DEBUG_S(                                                            \
 194         PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
 195     )
 196
 197 void *
 198 Perl_Slab_Alloc(pTHX_ size_t sz)
 199 {
 200     OPSLAB *slab;
 201     OPSLAB *slab2;
 202     OPSLOT *slot;
 203     OP *o;
 204     size_t opsz, space;
 205
 206     /* We only allocate ops from the slab during subroutine compilation.
 207        We find the slab via PL_compcv, hence that must be non-NULL. It could
 208        also be pointing to a subroutine which is now fully set up (CvROOT()
 209        pointing to the top of the optree for that sub), or a subroutine
 210        which isn't using the slab allocator. If our sanity checks aren't met,
 211        don't use a slab, but allocate the OP directly from the heap.  */
 212     if (!PL_compcv || CvROOT(PL_compcv)
 213      || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
 214     {
 215         o = (OP*)PerlMemShared_calloc(1, sz);
 216         goto gotit;
 217     }
 218
 219     /* While the subroutine is under construction, the slabs are accessed via
 220        CvSTART(), to avoid needing to expand PVCV by one pointer for something
 221        unneeded at runtime. Once a subroutine is constructed, the slabs are
 222        accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
 223        allocated yet.  See the commit message for 8be227ab5eaa23f2 for more
 224        details.  */
 225     if (!CvSTART(PL_compcv)) {
 226         CvSTART(PL_compcv) =
 227             (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
 228         CvSLABBED_on(PL_compcv);
 229         slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
 230     }
 231     else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
 232
 233     opsz = SIZE_TO_PSIZE(sz);
 234     sz = opsz + OPSLOT_HEADER_P;
 235
 236     /* The slabs maintain a free list of OPs. In particular, constant folding
 237        will free up OPs, so it makes sense to re-use them where possible. A
 238        freed up slot is used in preference to a new allocation.  */
 239     if (slab->opslab_freed) {
 240         OP **too = &slab->opslab_freed;
 241         o = *too;
 242         DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", (void*)o, (void*)slab));
 243         while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
 244             DEBUG_S_warn((aTHX_ "Alas! too small"));
 245             o = *(too = &o->op_next);
 246             if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", (void*)o)); }
 247         }
 248         if (o) {
 249             *too = o->op_next;
 250             Zero(o, opsz, I32 *);
 251             o->op_slabbed = 1;
 252             goto gotit;
 253         }
 254     }
 255
 256 #define INIT_OPSLOT \
 257             slot->opslot_slab = slab;                   \
 258             slot->opslot_next = slab2->opslab_first;    \
 259             slab2->opslab_first = slot;                 \
 260             o = &slot->opslot_op;                       \
 261             o->op_slabbed = 1
 262
 263     /* The partially-filled slab is next in the chain. */
 264     slab2 = slab->opslab_next ? slab->opslab_next : slab;
 265     if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
 266         /* Remaining space is too small. */
 267
 268         /* If we can fit a BASEOP, add it to the free chain, so as not
 269            to waste it. */
 270         if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
 271             slot = &slab2->opslab_slots;
 272             INIT_OPSLOT;
 273             o->op_type = OP_FREED;
 274             o->op_next = slab->opslab_freed;
 275             slab->opslab_freed = o;
 276         }
 277
 278         /* Create a new slab.  Make this one twice as big. */
 279         slot = slab2->opslab_first;
 280         while (slot->opslot_next) slot = slot->opslot_next;
 281         slab2 = S_new_slab(aTHX_
 282                             (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
 283                                         ? PERL_MAX_SLAB_SIZE
 284                                         : (DIFF(slab2, slot)+1)*2);
 285         slab2->opslab_next = slab->opslab_next;
 286         slab->opslab_next = slab2;
 287     }
 288     assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
 289
 290     /* Create a new op slot */
 291     slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
 292     assert(slot >= &slab2->opslab_slots);
 293     if (DIFF(&slab2->opslab_slots, slot)
 294          < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
 295         slot = &slab2->opslab_slots;
 296     INIT_OPSLOT;
 297     DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab));
 298
 299   gotit:
 300 #ifdef PERL_OP_PARENT
 301     /* moresib == 0, op_sibling == 0 implies a solitary unattached op */
 302     assert(!o->op_moresib);
 303     assert(!o->op_sibparent);
 304 #endif
 305
 306     return (void *)o;
 307 }
 308
 309 #undef INIT_OPSLOT
 310
 311 #ifdef PERL_DEBUG_READONLY_OPS
 312 void
 313 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
 314 {
 315     PERL_ARGS_ASSERT_SLAB_TO_RO;
 316
 317     if (slab->opslab_readonly) return;
 318     slab->opslab_readonly = 1;
 319     for (; slab; slab = slab->opslab_next) {
 320         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
 321                               (unsigned long) slab->opslab_size, slab));*/
 322         if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
 323             Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
 324                              (unsigned long)slab->opslab_size, errno);
 325     }
 326 }
 327
 328 void
 329 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
 330 {
 331     OPSLAB *slab2;
 332
 333     PERL_ARGS_ASSERT_SLAB_TO_RW;
 334
 335     if (!slab->opslab_readonly) return;
 336     slab2 = slab;
 337     for (; slab2; slab2 = slab2->opslab_next) {
 338         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
 339                               (unsigned long) size, slab2));*/
 340         if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
 341                      PROT_READ|PROT_WRITE)) {
 342             Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
 343                              (unsigned long)slab2->opslab_size, errno);
 344         }
 345     }
 346     slab->opslab_readonly = 0;
 347 }
 348
 349 #else
 350 #  define Slab_to_rw(op)    NOOP
 351 #endif
 352
 353 /* This cannot possibly be right, but it was copied from the old slab
 354    allocator, to which it was originally added, without explanation, in
 355    commit 083fcd5. */
 356 #ifdef NETWARE
 357 #    define PerlMemShared PerlMem
 358 #endif
 359
 360 void
 361 Perl_Slab_Free(pTHX_ void *op)
 362 {
 363     OP * const o = (OP *)op;
 364     OPSLAB *slab;
 365
 366     PERL_ARGS_ASSERT_SLAB_FREE;
 367
 368     if (!o->op_slabbed) {
 369         if (!o->op_static)
 370             PerlMemShared_free(op);
 371         return;
 372     }
 373
 374     slab = OpSLAB(o);
 375     /* If this op is already freed, our refcount will get screwy. */
 376     assert(o->op_type != OP_FREED);
 377     o->op_type = OP_FREED;
 378     o->op_next = slab->opslab_freed;
 379     slab->opslab_freed = o;
 380     DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", (void*)o, (void*)slab));
 381     OpslabREFCNT_dec_padok(slab);
 382 }
 383
 384 void
 385 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
 386 {
 387     const bool havepad = !!PL_comppad;
 388     PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
 389     if (havepad) {
 390         ENTER;
 391         PAD_SAVE_SETNULLPAD();
 392     }
 393     opslab_free(slab);
 394     if (havepad) LEAVE;
 395 }
 396
 397 void
 398 Perl_opslab_free(pTHX_ OPSLAB *slab)
 399 {
 400     OPSLAB *slab2;
 401     PERL_ARGS_ASSERT_OPSLAB_FREE;
 402     PERL_UNUSED_CONTEXT;
 403     DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
 404     assert(slab->opslab_refcnt == 1);
 405     do {
 406         slab2 = slab->opslab_next;
 407 #ifdef DEBUGGING
 408         slab->opslab_refcnt = ~(size_t)0;
 409 #endif
 410 #ifdef PERL_DEBUG_READONLY_OPS
 411         DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
 412                                                (void*)slab));
 413         if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
 414             perror("munmap failed");
 415             abort();
 416         }
 417 #else
 418         PerlMemShared_free(slab);
 419 #endif
 420         slab = slab2;
 421     } while (slab);
 422 }
 423
 424 void
 425 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
 426 {
 427     OPSLAB *slab2;
 428     OPSLOT *slot;
 429 #ifdef DEBUGGING
 430     size_t savestack_count = 0;
 431 #endif
 432     PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
 433     slab2 = slab;
 434     do {
 435         for (slot = slab2->opslab_first;
 436              slot->opslot_next;
 437              slot = slot->opslot_next) {
 438             if (slot->opslot_op.op_type != OP_FREED
 439              && !(slot->opslot_op.op_savefree
 440 #ifdef DEBUGGING
 441                   && ++savestack_count
 442 #endif
 443                  )
 444             ) {
 445                 assert(slot->opslot_op.op_slabbed);
 446                 op_free(&slot->opslot_op);
 447                 if (slab->opslab_refcnt == 1) goto free;
 448             }
 449         }
 450     } while ((slab2 = slab2->opslab_next));
 451     /* > 1 because the CV still holds a reference count. */
 452     if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
 453 #ifdef DEBUGGING
 454         assert(savestack_count == slab->opslab_refcnt-1);
 455 #endif
 456         /* Remove the CV’s reference count. */
 457         slab->opslab_refcnt--;
 458         return;
 459     }
 460    free:
 461     opslab_free(slab);
 462 }
 463
 464 #ifdef PERL_DEBUG_READONLY_OPS
 465 OP *
 466 Perl_op_refcnt_inc(pTHX_ OP *o)
 467 {
 468     if(o) {
 469         OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
 470         if (slab && slab->opslab_readonly) {
 471             Slab_to_rw(slab);
 472             ++o->op_targ;
 473             Slab_to_ro(slab);
 474         } else {
 475             ++o->op_targ;
 476         }
 477     }
 478     return o;
 479
 480 }
 481
 482 PADOFFSET
 483 Perl_op_refcnt_dec(pTHX_ OP *o)
 484 {
 485     PADOFFSET result;
 486     OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
 487
 488     PERL_ARGS_ASSERT_OP_REFCNT_DEC;
 489
 490     if (slab && slab->opslab_readonly) {
 491         Slab_to_rw(slab);
 492         result = --o->op_targ;
 493         Slab_to_ro(slab);
 494     } else {
 495         result = --o->op_targ;
 496     }
 497     return result;
 498 }
 499 #endif
 500 /*
 501  * In the following definition, the ", (OP*)0" is just to make the compiler
 502  * think the expression is of the right type: croak actually does a Siglongjmp.
 503  */
 504 #define CHECKOP(type,o) \
 505     ((PL_op_mask && PL_op_mask[type])                           \
 506      ? ( op_free((OP*)o),                                       \
 507          Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]),  \
 508          (OP*)0 )                                               \
 509      : PL_check[type](aTHX_ (OP*)o))
 510
 511 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
 512
 513 #define OpTYPE_set(o,type) \
 514     STMT_START {                                \
 515         o->op_type = (OPCODE)type;              \
 516         o->op_ppaddr = PL_ppaddr[type];         \
 517     } STMT_END
 518
 519 STATIC OP *
 520 S_no_fh_allowed(pTHX_ OP *o)
 521 {
 522     PERL_ARGS_ASSERT_NO_FH_ALLOWED;
 523
 524     yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
 525                  OP_DESC(o)));
 526     return o;
 527 }
 528
 529 STATIC OP *
 530 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
 531 {
 532     PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
 533     yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
 534     return o;
 535 }
 536
 537 STATIC OP *
 538 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
 539 {
 540     PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
 541
 542     yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
 543     return o;
 544 }
 545
 546 STATIC void
 547 S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid)
 548 {
 549     PERL_ARGS_ASSERT_BAD_TYPE_PV;
 550
 551     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
 552                  (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);
 553 }
 554
 555 /* remove flags var, its unused in all callers, move to to right end since gv
 556   and kid are always the same */
 557 STATIC void
 558 S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)
 559 {
 560     SV * const namesv = cv_name((CV *)gv, NULL, 0);
 561     PERL_ARGS_ASSERT_BAD_TYPE_GV;
 562
 563     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
 564                  (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
 565 }
 566
 567 STATIC void
 568 S_no_bareword_allowed(pTHX_ OP *o)
 569 {
 570     PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
 571
 572     qerror(Perl_mess(aTHX_
 573                      "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
 574                      SVfARG(cSVOPo_sv)));
 575     o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
 576 }
 577
 578 /* "register" allocation */
 579
 580 PADOFFSET
 581 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
 582 {
 583     PADOFFSET off;
 584     const bool is_our = (PL_parser->in_my == KEY_our);
 585
 586     PERL_ARGS_ASSERT_ALLOCMY;
 587
 588     if (flags & ~SVf_UTF8)
 589         Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
 590                    (UV)flags);
 591
 592     /* complain about "my $<special_var>" etc etc */
 593     if (len &&
 594         !(is_our ||
 595           isALPHA(name[1]) ||
 596           ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
 597           (name[1] == '_' && (*name == '$' || len > 2))))
 598     {
 599         if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
 600          && isASCII(name[1])
 601          && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
 602             yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
 603                               name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
 604                               PL_parser->in_my == KEY_state ? "state" : "my"));
 605         } else {
 606             yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
 607                               PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
 608         }
 609     }
 610     else if (len == 2 && name[1] == '_' && !is_our)
 611         /* diag_listed_as: Use of my $_ is experimental */
 612         Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__LEXICAL_TOPIC),
 613                               "Use of %s $_ is experimental",
 614                                PL_parser->in_my == KEY_state
 615                                  ? "state"
 616                                  : "my");
 617
 618     /* allocate a spare slot and store the name in that slot */
 619
 620     off = pad_add_name_pvn(name, len,
 621                        (is_our ? padadd_OUR :
 622                         PL_parser->in_my == KEY_state ? padadd_STATE : 0),
 623                     PL_parser->in_my_stash,
 624                     (is_our
 625                         /* $_ is always in main::, even with our */
 626                         ? (PL_curstash && !memEQs(name,len,"$_")
 627                             ? PL_curstash
 628                             : PL_defstash)
 629                         : NULL
 630                     )
 631     );
 632     /* anon sub prototypes contains state vars should always be cloned,
 633      * otherwise the state var would be shared between anon subs */
 634
 635     if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
 636         CvCLONE_on(PL_compcv);
 637
 638     return off;
 639 }
 640
 641 /*
 642 =head1 Optree Manipulation Functions
 643
 644 =for apidoc alloccopstash
 645
 646 Available only under threaded builds, this function allocates an entry in
 647 C<PL_stashpad> for the stash passed to it.
 648
 649 =cut
 650 */
 651
 652 #ifdef USE_ITHREADS
 653 PADOFFSET
 654 Perl_alloccopstash(pTHX_ HV *hv)
 655 {
 656     PADOFFSET off = 0, o = 1;
 657     bool found_slot = FALSE;
 658
 659     PERL_ARGS_ASSERT_ALLOCCOPSTASH;
 660
 661     if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
 662
 663     for (; o < PL_stashpadmax; ++o) {
 664         if (PL_stashpad[o] == hv) return PL_stashpadix = o;
 665         if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
 666             found_slot = TRUE, off = o;
 667     }
 668     if (!found_slot) {
 669         Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
 670         Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
 671         off = PL_stashpadmax;
 672         PL_stashpadmax += 10;
 673     }
 674
 675     PL_stashpad[PL_stashpadix = off] = hv;
 676     return off;
 677 }
 678 #endif
 679
 680 /* free the body of an op without examining its contents.
 681  * Always use this rather than FreeOp directly */
 682
 683 static void
 684 S_op_destroy(pTHX_ OP *o)
 685 {
 686     FreeOp(o);
 687 }
 688
 689 /* Destructor */
 690
 691 /*
 692 =for apidoc Am|void|op_free|OP *o
 693
 694 Free an op.  Only use this when an op is no longer linked to from any
 695 optree.
 696
 697 =cut
 698 */
 699
 700 void
 701 Perl_op_free(pTHX_ OP *o)
 702 {
 703     dVAR;
 704     OPCODE type;
 705     SSize_t defer_ix = -1;
 706     SSize_t defer_stack_alloc = 0;
 707     OP **defer_stack = NULL;
 708
 709     do {
 710
 711         /* Though ops may be freed twice, freeing the op after its slab is a
 712            big no-no. */
 713         assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
 714         /* During the forced freeing of ops after compilation failure, kidops
 715            may be freed before their parents. */
 716         if (!o || o->op_type == OP_FREED)
 717             continue;
 718
 719         type = o->op_type;
 720
 721         /* an op should only ever acquire op_private flags that we know about.
 722          * If this fails, you may need to fix something in regen/op_private */
 723         if (o->op_ppaddr == PL_ppaddr[o->op_type]) {
 724             assert(!(o->op_private & ~PL_op_private_valid[type]));
 725         }
 726
 727         if (o->op_private & OPpREFCOUNTED) {
 728             switch (type) {
 729             case OP_LEAVESUB:
 730             case OP_LEAVESUBLV:
 731             case OP_LEAVEEVAL:
 732             case OP_LEAVE:
 733             case OP_SCOPE:
 734             case OP_LEAVEWRITE:
 735                 {
 736                 PADOFFSET refcnt;
 737                 OP_REFCNT_LOCK;
 738                 refcnt = OpREFCNT_dec(o);
 739                 OP_REFCNT_UNLOCK;
 740                 if (refcnt) {
 741                     /* Need to find and remove any pattern match ops from the list
 742                        we maintain for reset().  */
 743                     find_and_forget_pmops(o);
 744                     continue;
 745                 }
 746                 }
 747                 break;
 748             default:
 749                 break;
 750             }
 751         }
 752
 753         /* Call the op_free hook if it has been set. Do it now so that it's called
 754          * at the right time for refcounted ops, but still before all of the kids
 755          * are freed. */
 756         CALL_OPFREEHOOK(o);
 757
 758         if (o->op_flags & OPf_KIDS) {
 759             OP *kid, *nextkid;
 760             for (kid = cUNOPo->op_first; kid; kid = nextkid) {
 761                 nextkid = OpSIBLING(kid); /* Get before next freeing kid */
 762                 if (!kid || kid->op_type == OP_FREED)
 763                     /* During the forced freeing of ops after
 764                        compilation failure, kidops may be freed before
 765                        their parents. */
 766                     continue;
 767                 if (!(kid->op_flags & OPf_KIDS))
 768                     /* If it has no kids, just free it now */
 769                     op_free(kid);
 770                 else
 771                     DEFER_OP(kid);
 772             }
 773         }
 774         if (type == OP_NULL)
 775             type = (OPCODE)o->op_targ;
 776
 777         if (o->op_slabbed)
 778             Slab_to_rw(OpSLAB(o));
 779
 780         /* COP* is not cleared by op_clear() so that we may track line
 781          * numbers etc even after null() */
 782         if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
 783             cop_free((COP*)o);
 784         }
 785
 786         op_clear(o);
 787         FreeOp(o);
 788 #ifdef DEBUG_LEAKING_SCALARS
 789         if (PL_op == o)
 790             PL_op = NULL;
 791 #endif
 792     } while ( (o = POP_DEFERRED_OP()) );
 793
 794     Safefree(defer_stack);
 795 }
 796
 797 /* S_op_clear_gv(): free a GV attached to an OP */
 798
 799 #ifdef USE_ITHREADS
 800 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
 801 #else
 802 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
 803 #endif
 804 {
 805
 806     GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
 807             || o->op_type == OP_MULTIDEREF)
 808 #ifdef USE_ITHREADS
 809                 && PL_curpad
 810                 ? ((GV*)PAD_SVl(*ixp)) : NULL;
 811 #else
 812                 ? (GV*)(*svp) : NULL;
 813 #endif
 814     /* It's possible during global destruction that the GV is freed
 815        before the optree. Whilst the SvREFCNT_inc is happy to bump from
 816        0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
 817        will trigger an assertion failure, because the entry to sv_clear
 818        checks that the scalar is not already freed.  A check of for
 819        !SvIS_FREED(gv) turns out to be invalid, because during global
 820        destruction the reference count can be forced down to zero
 821        (with SVf_BREAK set).  In which case raising to 1 and then
 822        dropping to 0 triggers cleanup before it should happen.  I
 823        *think* that this might actually be a general, systematic,
 824        weakness of the whole idea of SVf_BREAK, in that code *is*
 825        allowed to raise and lower references during global destruction,
 826        so any *valid* code that happens to do this during global
 827        destruction might well trigger premature cleanup.  */
 828     bool still_valid = gv && SvREFCNT(gv);
 829
 830     if (still_valid)
 831         SvREFCNT_inc_simple_void(gv);
 832 #ifdef USE_ITHREADS
 833     if (*ixp > 0) {
 834         pad_swipe(*ixp, TRUE);
 835         *ixp = 0;
 836     }
 837 #else
 838     SvREFCNT_dec(*svp);
 839     *svp = NULL;
 840 #endif
 841     if (still_valid) {
 842         int try_downgrade = SvREFCNT(gv) == 2;
 843         SvREFCNT_dec_NN(gv);
 844         if (try_downgrade)
 845             gv_try_downgrade(gv);
 846     }
 847 }
 848
 849
 850 void
 851 Perl_op_clear(pTHX_ OP *o)
 852 {
 853
 854     dVAR;
 855
 856     PERL_ARGS_ASSERT_OP_CLEAR;
 857
 858     switch (o->op_type) {
 859     case OP_NULL:       /* Was holding old type, if any. */
 860         /* FALLTHROUGH */
 861     case OP_ENTERTRY:
 862     case OP_ENTEREVAL:  /* Was holding hints. */
 863         o->op_targ = 0;
 864         break;
 865     default:
 866         if (!(o->op_flags & OPf_REF)
 867             || (PL_check[o->op_type] != Perl_ck_ftst))
 868             break;
 869         /* FALLTHROUGH */
 870     case OP_GVSV:
 871     case OP_GV:
 872     case OP_AELEMFAST:
 873 #ifdef USE_ITHREADS
 874             S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
 875 #else
 876             S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
 877 #endif
 878         break;
 879     case OP_METHOD_REDIR:
 880     case OP_METHOD_REDIR_SUPER:
 881 #ifdef USE_ITHREADS
 882         if (cMETHOPx(o)->op_rclass_targ) {
 883             pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
 884             cMETHOPx(o)->op_rclass_targ = 0;
 885         }
 886 #else
 887         SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
 888         cMETHOPx(o)->op_rclass_sv = NULL;
 889 #endif
 890     case OP_METHOD_NAMED:
 891     case OP_METHOD_SUPER:
 892         SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
 893         cMETHOPx(o)->op_u.op_meth_sv = NULL;
 894 #ifdef USE_ITHREADS
 895         if (o->op_targ) {
 896             pad_swipe(o->op_targ, 1);
 897             o->op_targ = 0;
 898         }
 899 #endif
 900         break;
 901     case OP_CONST:
 902     case OP_HINTSEVAL:
 903         SvREFCNT_dec(cSVOPo->op_sv);
 904         cSVOPo->op_sv = NULL;
 905 #ifdef USE_ITHREADS
 906         /** Bug #15654
 907           Even if op_clear does a pad_free for the target of the op,
 908           pad_free doesn't actually remove the sv that exists in the pad;
 909           instead it lives on. This results in that it could be reused as
 910           a target later on when the pad was reallocated.
 911         **/
 912         if(o->op_targ) {
 913           pad_swipe(o->op_targ,1);
 914           o->op_targ = 0;
 915         }
 916 #endif
 917         break;
 918     case OP_DUMP:
 919     case OP_GOTO:
 920     case OP_NEXT:
 921     case OP_LAST:
 922     case OP_REDO:
 923         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
 924             break;
 925         /* FALLTHROUGH */
 926     case OP_TRANS:
 927     case OP_TRANSR:
 928         if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
 929             assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
 930 #ifdef USE_ITHREADS
 931             if (cPADOPo->op_padix > 0) {
 932                 pad_swipe(cPADOPo->op_padix, TRUE);
 933                 cPADOPo->op_padix = 0;
 934             }
 935 #else
 936             SvREFCNT_dec(cSVOPo->op_sv);
 937             cSVOPo->op_sv = NULL;
 938 #endif
 939         }
 940         else {
 941             PerlMemShared_free(cPVOPo->op_pv);
 942             cPVOPo->op_pv = NULL;
 943         }
 944         break;
 945     case OP_SUBST:
 946         op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
 947         goto clear_pmop;
 948     case OP_PUSHRE:
 949 #ifdef USE_ITHREADS
 950         if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
 951             pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
 952         }
 953 #else
 954         SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
 955 #endif
 956         /* FALLTHROUGH */
 957     case OP_MATCH:
 958     case OP_QR:
 959     clear_pmop:
 960         if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
 961             op_free(cPMOPo->op_code_list);
 962         cPMOPo->op_code_list = NULL;
 963         forget_pmop(cPMOPo);
 964         cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
 965         /* we use the same protection as the "SAFE" version of the PM_ macros
 966          * here since sv_clean_all might release some PMOPs
 967          * after PL_regex_padav has been cleared
 968          * and the clearing of PL_regex_padav needs to
 969          * happen before sv_clean_all
 970          */
 971 #ifdef USE_ITHREADS
 972         if(PL_regex_pad) {        /* We could be in destruction */
 973             const IV offset = (cPMOPo)->op_pmoffset;
 974             ReREFCNT_dec(PM_GETRE(cPMOPo));
 975             PL_regex_pad[offset] = &PL_sv_undef;
 976             sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
 977                            sizeof(offset));
 978         }
 979 #else
 980         ReREFCNT_dec(PM_GETRE(cPMOPo));
 981         PM_SETRE(cPMOPo, NULL);
 982 #endif
 983
 984         break;
 985
 986     case OP_MULTIDEREF:
 987         {
 988             UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
 989             UV actions = items->uv;
 990             bool last = 0;
 991             bool is_hash = FALSE;
 992
 993             while (!last) {
 994                 switch (actions & MDEREF_ACTION_MASK) {
 995
 996                 case MDEREF_reload:
 997                     actions = (++items)->uv;
 998                     continue;
 999
1000                 case MDEREF_HV_padhv_helem:
1001                     is_hash = TRUE;
1002                 case MDEREF_AV_padav_aelem:
1003                     pad_free((++items)->pad_offset);
1004                     goto do_elem;
1005
1006                 case MDEREF_HV_gvhv_helem:
1007                     is_hash = TRUE;
1008                 case MDEREF_AV_gvav_aelem:
1009 #ifdef USE_ITHREADS
1010                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1011 #else
1012                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1013 #endif
1014                     goto do_elem;
1015
1016                 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1017                     is_hash = TRUE;
1018                 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1019 #ifdef USE_ITHREADS
1020                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1021 #else
1022                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1023 #endif
1024                     goto do_vivify_rv2xv_elem;
1025
1026                 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1027                     is_hash = TRUE;
1028                 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1029                     pad_free((++items)->pad_offset);
1030                     goto do_vivify_rv2xv_elem;
1031
1032                 case MDEREF_HV_pop_rv2hv_helem:
1033                 case MDEREF_HV_vivify_rv2hv_helem:
1034                     is_hash = TRUE;
1035                 do_vivify_rv2xv_elem:
1036                 case MDEREF_AV_pop_rv2av_aelem:
1037                 case MDEREF_AV_vivify_rv2av_aelem:
1038                 do_elem:
1039                     switch (actions & MDEREF_INDEX_MASK) {
1040                     case MDEREF_INDEX_none:
1041                         last = 1;
1042                         break;
1043                     case MDEREF_INDEX_const:
1044                         if (is_hash) {
1045 #ifdef USE_ITHREADS
1046                             /* see RT #15654 */
1047                             pad_swipe((++items)->pad_offset, 1);
1048 #else
1049                             SvREFCNT_dec((++items)->sv);
1050 #endif
1051                         }
1052                         else
1053                             items++;
1054                         break;
1055                     case MDEREF_INDEX_padsv:
1056                         pad_free((++items)->pad_offset);
1057                         break;
1058                     case MDEREF_INDEX_gvsv:
1059 #ifdef USE_ITHREADS
1060                         S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1061 #else
1062                         S_op_clear_gv(aTHX_ o, &((++items)->sv));
1063 #endif
1064                         break;
1065                     }
1066
1067                     if (actions & MDEREF_FLAG_last)
1068                         last = 1;
1069                     is_hash = FALSE;
1070
1071                     break;
1072
1073                 default:
1074                     assert(0);
1075                     last = 1;
1076                     break;
1077
1078                 } /* switch */
1079
1080                 actions >>= MDEREF_SHIFT;
1081             } /* while */
1082
1083             /* start of malloc is at op_aux[-1], where the length is
1084              * stored */
1085             PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1086         }
1087         break;
1088     }
1089
1090     if (o->op_targ > 0) {
1091         pad_free(o->op_targ);
1092         o->op_targ = 0;
1093     }
1094 }
1095
1096 STATIC void
1097 S_cop_free(pTHX_ COP* cop)
1098 {
1099     PERL_ARGS_ASSERT_COP_FREE;
1100
1101     CopFILE_free(cop);
1102     if (! specialWARN(cop->cop_warnings))
1103         PerlMemShared_free(cop->cop_warnings);
1104     cophh_free(CopHINTHASH_get(cop));
1105     if (PL_curcop == cop)
1106        PL_curcop = NULL;
1107 }
1108
1109 STATIC void
1110 S_forget_pmop(pTHX_ PMOP *const o
1111               )
1112 {
1113     HV * const pmstash = PmopSTASH(o);
1114
1115     PERL_ARGS_ASSERT_FORGET_PMOP;
1116
1117     if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1118         MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1119         if (mg) {
1120             PMOP **const array = (PMOP**) mg->mg_ptr;
1121             U32 count = mg->mg_len / sizeof(PMOP**);
1122             U32 i = count;
1123
1124             while (i--) {
1125                 if (array[i] == o) {
1126                     /* Found it. Move the entry at the end to overwrite it.  */
1127                     array[i] = array[--count];
1128                     mg->mg_len = count * sizeof(PMOP**);
1129                     /* Could realloc smaller at this point always, but probably
1130                        not worth it. Probably worth free()ing if we're the
1131                        last.  */
1132                     if(!count) {
1133                         Safefree(mg->mg_ptr);
1134                         mg->mg_ptr = NULL;
1135                     }
1136                     break;
1137                 }
1138             }
1139         }
1140     }
1141     if (PL_curpm == o)
1142         PL_curpm = NULL;
1143 }
1144
1145 STATIC void
1146 S_find_and_forget_pmops(pTHX_ OP *o)
1147 {
1148     PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1149
1150     if (o->op_flags & OPf_KIDS) {
1151         OP *kid = cUNOPo->op_first;
1152         while (kid) {
1153             switch (kid->op_type) {
1154             case OP_SUBST:
1155             case OP_PUSHRE:
1156             case OP_MATCH:
1157             case OP_QR:
1158                 forget_pmop((PMOP*)kid);
1159             }
1160             find_and_forget_pmops(kid);
1161             kid = OpSIBLING(kid);
1162         }
1163     }
1164 }
1165
1166 /*
1167 =for apidoc Am|void|op_null|OP *o
1168
1169 Neutralizes an op when it is no longer needed, but is still linked to from
1170 other ops.
1171
1172 =cut
1173 */
1174
1175 void
1176 Perl_op_null(pTHX_ OP *o)
1177 {
1178     dVAR;
1179
1180     PERL_ARGS_ASSERT_OP_NULL;
1181
1182     if (o->op_type == OP_NULL)
1183         return;
1184     op_clear(o);
1185     o->op_targ = o->op_type;
1186     OpTYPE_set(o, OP_NULL);
1187 }
1188
1189 void
1190 Perl_op_refcnt_lock(pTHX)
1191 {
1192 #ifdef USE_ITHREADS
1193     dVAR;
1194 #endif
1195     PERL_UNUSED_CONTEXT;
1196     OP_REFCNT_LOCK;
1197 }
1198
1199 void
1200 Perl_op_refcnt_unlock(pTHX)
1201 {
1202 #ifdef USE_ITHREADS
1203     dVAR;
1204 #endif
1205     PERL_UNUSED_CONTEXT;
1206     OP_REFCNT_UNLOCK;
1207 }
1208
1209
1210 /*
1211 =for apidoc op_sibling_splice
1212
1213 A general function for editing the structure of an existing chain of
1214 op_sibling nodes.  By analogy with the perl-level splice() function, allows
1215 you to delete zero or more sequential nodes, replacing them with zero or
1216 more different nodes.  Performs the necessary op_first/op_last
1217 housekeeping on the parent node and op_sibling manipulation on the
1218 children.  The last deleted node will be marked as as the last node by
1219 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1220
1221 Note that op_next is not manipulated, and nodes are not freed; that is the
1222 responsibility of the caller.  It also won't create a new list op for an
1223 empty list etc; use higher-level functions like op_append_elem() for that.
1224
1225 parent is the parent node of the sibling chain. It may passed as NULL if
1226 the splicing doesn't affect the first or last op in the chain.
1227
1228 start is the node preceding the first node to be spliced.  Node(s)
1229 following it will be deleted, and ops will be inserted after it.  If it is
1230 NULL, the first node onwards is deleted, and nodes are inserted at the
1231 beginning.
1232
1233 del_count is the number of nodes to delete.  If zero, no nodes are deleted.
1234 If -1 or greater than or equal to the number of remaining kids, all
1235 remaining kids are deleted.
1236
1237 insert is the first of a chain of nodes to be inserted in place of the nodes.
1238 If NULL, no nodes are inserted.
1239
1240 The head of the chain of deleted ops is returned, or NULL if no ops were
1241 deleted.
1242
1243 For example:
1244
1245     action                    before      after         returns
1246     ------                    -----       -----         -------
1247
1248                               P           P
1249     splice(P, A, 2, X-Y-Z)    |           |             B-C
1250                               A-B-C-D     A-X-Y-Z-D
1251
1252                               P           P
1253     splice(P, NULL, 1, X-Y)   |           |             A
1254                               A-B-C-D     X-Y-B-C-D
1255
1256                               P           P
1257     splice(P, NULL, 3, NULL)  |           |             A-B-C
1258                               A-B-C-D     D
1259
1260                               P           P
1261     splice(P, B, 0, X-Y)      |           |             NULL
1262                               A-B-C-D     A-B-X-Y-C-D
1263
1264
1265 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1266 see C<OpMORESIB_set>, C<OpLASTSIB_set>, C<OpMAYBESIB_set>.
1267
1268 =cut
1269 */
1270
1271 OP *
1272 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1273 {
1274     OP *first;
1275     OP *rest;
1276     OP *last_del = NULL;
1277     OP *last_ins = NULL;
1278
1279     if (start)
1280         first = OpSIBLING(start);
1281     else if (!parent)
1282         goto no_parent;
1283     else
1284         first = cLISTOPx(parent)->op_first;
1285
1286     assert(del_count >= -1);
1287
1288     if (del_count && first) {
1289         last_del = first;
1290         while (--del_count && OpHAS_SIBLING(last_del))
1291             last_del = OpSIBLING(last_del);
1292         rest = OpSIBLING(last_del);
1293         OpLASTSIB_set(last_del, NULL);
1294     }
1295     else
1296         rest = first;
1297
1298     if (insert) {
1299         last_ins = insert;
1300         while (OpHAS_SIBLING(last_ins))
1301             last_ins = OpSIBLING(last_ins);
1302         OpMAYBESIB_set(last_ins, rest, NULL);
1303     }
1304     else
1305         insert = rest;
1306
1307     if (start) {
1308         OpMAYBESIB_set(start, insert, NULL);
1309     }
1310     else {
1311         if (!parent)
1312             goto no_parent;
1313         cLISTOPx(parent)->op_first = insert;
1314         if (insert)
1315             parent->op_flags |= OPf_KIDS;
1316         else
1317             parent->op_flags &= ~OPf_KIDS;
1318     }
1319
1320     if (!rest) {
1321         /* update op_last etc */
1322         U32 type;
1323         OP *lastop;
1324
1325         if (!parent)
1326             goto no_parent;
1327
1328         /* ought to use OP_CLASS(parent) here, but that can't handle
1329          * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1330          * either */
1331         type = parent->op_type;
1332         if (type == OP_CUSTOM) {
1333             dTHX;
1334             type = XopENTRYCUSTOM(parent, xop_class);
1335         }
1336         else {
1337             if (type == OP_NULL)
1338                 type = parent->op_targ;
1339             type = PL_opargs[type] & OA_CLASS_MASK;
1340         }
1341
1342         lastop = last_ins ? last_ins : start ? start : NULL;
1343         if (   type == OA_BINOP
1344             || type == OA_LISTOP
1345             || type == OA_PMOP
1346             || type == OA_LOOP
1347         )
1348             cLISTOPx(parent)->op_last = lastop;
1349
1350         if (lastop)
1351             OpLASTSIB_set(lastop, parent);
1352     }
1353     return last_del ? first : NULL;
1354
1355   no_parent:
1356     Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1357 }
1358
1359
1360 #ifdef PERL_OP_PARENT
1361
1362 /*
1363 =for apidoc op_parent
1364
1365 Returns the parent OP of o, if it has a parent. Returns NULL otherwise.
1366 This function is only available on perls built with C<-DPERL_OP_PARENT>.
1367
1368 =cut
1369 */
1370
1371 OP *
1372 Perl_op_parent(OP *o)
1373 {
1374     PERL_ARGS_ASSERT_OP_PARENT;
1375     while (OpHAS_SIBLING(o))
1376         o = OpSIBLING(o);
1377     return o->op_sibparent;
1378 }
1379
1380 #endif
1381
1382
1383 /* replace the sibling following start with a new UNOP, which becomes
1384  * the parent of the original sibling; e.g.
1385  *
1386  *  op_sibling_newUNOP(P, A, unop-args...)
1387  *
1388  *  P              P
1389  *  |      becomes |
1390  *  A-B-C          A-U-C
1391  *                   |
1392  *                   B
1393  *
1394  * where U is the new UNOP.
1395  *
1396  * parent and start args are the same as for op_sibling_splice();
1397  * type and flags args are as newUNOP().
1398  *
1399  * Returns the new UNOP.
1400  */
1401
1402 OP *
1403 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1404 {
1405     OP *kid, *newop;
1406
1407     kid = op_sibling_splice(parent, start, 1, NULL);
1408     newop = newUNOP(type, flags, kid);
1409     op_sibling_splice(parent, start, 0, newop);
1410     return newop;
1411 }
1412
1413
1414 /* lowest-level newLOGOP-style function - just allocates and populates
1415  * the struct. Higher-level stuff should be done by S_new_logop() /
1416  * newLOGOP(). This function exists mainly to avoid op_first assignment
1417  * being spread throughout this file.
1418  */
1419
1420 LOGOP *
1421 S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1422 {
1423     dVAR;
1424     LOGOP *logop;
1425     OP *kid = first;
1426     NewOp(1101, logop, 1, LOGOP);
1427     OpTYPE_set(logop, type);
1428     logop->op_first = first;
1429     logop->op_other = other;
1430     logop->op_flags = OPf_KIDS;
1431     while (kid && OpHAS_SIBLING(kid))
1432         kid = OpSIBLING(kid);
1433     if (kid)
1434         OpLASTSIB_set(kid, (OP*)logop);
1435     return logop;
1436 }
1437
1438
1439 /* Contextualizers */
1440
1441 /*
1442 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1443
1444 Applies a syntactic context to an op tree representing an expression.
1445 I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
1446 or C<G_VOID> to specify the context to apply.  The modified op tree
1447 is returned.
1448
1449 =cut
1450 */
1451
1452 OP *
1453 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1454 {
1455     PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1456     switch (context) {
1457         case G_SCALAR: return scalar(o);
1458         case G_ARRAY:  return list(o);
1459         case G_VOID:   return scalarvoid(o);
1460         default:
1461             Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1462                        (long) context);
1463     }
1464 }
1465
1466 /*
1467
1468 =for apidoc Am|OP*|op_linklist|OP *o
1469 This function is the implementation of the L</LINKLIST> macro.  It should
1470 not be called directly.
1471
1472 =cut
1473 */
1474
1475 OP *
1476 Perl_op_linklist(pTHX_ OP *o)
1477 {
1478     OP *first;
1479
1480     PERL_ARGS_ASSERT_OP_LINKLIST;
1481
1482     if (o->op_next)
1483         return o->op_next;
1484
1485     /* establish postfix order */
1486     first = cUNOPo->op_first;
1487     if (first) {
1488         OP *kid;
1489         o->op_next = LINKLIST(first);
1490         kid = first;
1491         for (;;) {
1492             OP *sibl = OpSIBLING(kid);
1493             if (sibl) {
1494                 kid->op_next = LINKLIST(sibl);
1495                 kid = sibl;
1496             } else {
1497                 kid->op_next = o;
1498                 break;
1499             }
1500         }
1501     }
1502     else
1503         o->op_next = o;
1504
1505     return o->op_next;
1506 }
1507
1508 static OP *
1509 S_scalarkids(pTHX_ OP *o)
1510 {
1511     if (o && o->op_flags & OPf_KIDS) {
1512         OP *kid;
1513         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1514             scalar(kid);
1515     }
1516     return o;
1517 }
1518
1519 STATIC OP *
1520 S_scalarboolean(pTHX_ OP *o)
1521 {
1522     PERL_ARGS_ASSERT_SCALARBOOLEAN;
1523
1524     if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
1525      && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
1526         if (ckWARN(WARN_SYNTAX)) {
1527             const line_t oldline = CopLINE(PL_curcop);
1528
1529             if (PL_parser && PL_parser->copline != NOLINE) {
1530                 /* This ensures that warnings are reported at the first line
1531                    of the conditional, not the last.  */
1532                 CopLINE_set(PL_curcop, PL_parser->copline);
1533             }
1534             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1535             CopLINE_set(PL_curcop, oldline);
1536         }
1537     }
1538     return scalar(o);
1539 }
1540
1541 static SV *
1542 S_op_varname(pTHX_ const OP *o)
1543 {
1544     assert(o);
1545     assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1546            o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1547     {
1548         const char funny  = o->op_type == OP_PADAV
1549                          || o->op_type == OP_RV2AV ? '@' : '%';
1550         if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1551             GV *gv;
1552             if (cUNOPo->op_first->op_type != OP_GV
1553              || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1554                 return NULL;
1555             return varname(gv, funny, 0, NULL, 0, 1);
1556         }
1557         return
1558             varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, 1);
1559     }
1560 }
1561
1562 static void
1563 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1564 { /* or not so pretty :-) */
1565     if (o->op_type == OP_CONST) {
1566         *retsv = cSVOPo_sv;
1567         if (SvPOK(*retsv)) {
1568             SV *sv = *retsv;
1569             *retsv = sv_newmortal();
1570             pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1571                       PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1572         }
1573         else if (!SvOK(*retsv))
1574             *retpv = "undef";
1575     }
1576     else *retpv = "...";
1577 }
1578
1579 static void
1580 S_scalar_slice_warning(pTHX_ const OP *o)
1581 {
1582     OP *kid;
1583     const char lbrack =
1584         o->op_type == OP_HSLICE ? '{' : '[';
1585     const char rbrack =
1586         o->op_type == OP_HSLICE ? '}' : ']';
1587     SV *name;
1588     SV *keysv = NULL; /* just to silence compiler warnings */
1589     const char *key = NULL;
1590
1591     if (!(o->op_private & OPpSLICEWARNING))
1592         return;
1593     if (PL_parser && PL_parser->error_count)
1594         /* This warning can be nonsensical when there is a syntax error. */
1595         return;
1596
1597     kid = cLISTOPo->op_first;
1598     kid = OpSIBLING(kid); /* get past pushmark */
1599     /* weed out false positives: any ops that can return lists */
1600     switch (kid->op_type) {
1601     case OP_BACKTICK:
1602     case OP_GLOB:
1603     case OP_READLINE:
1604     case OP_MATCH:
1605     case OP_RV2AV:
1606     case OP_EACH:
1607     case OP_VALUES:
1608     case OP_KEYS:
1609     case OP_SPLIT:
1610     case OP_LIST:
1611     case OP_SORT:
1612     case OP_REVERSE:
1613     case OP_ENTERSUB:
1614     case OP_CALLER:
1615     case OP_LSTAT:
1616     case OP_STAT:
1617     case OP_READDIR:
1618     case OP_SYSTEM:
1619     case OP_TMS:
1620     case OP_LOCALTIME:
1621     case OP_GMTIME:
1622     case OP_ENTEREVAL:
1623     case OP_REACH:
1624     case OP_RKEYS:
1625     case OP_RVALUES:
1626         return;
1627     }
1628
1629     /* Don't warn if we have a nulled list either. */
1630     if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1631         return;
1632
1633     assert(OpSIBLING(kid));
1634     name = S_op_varname(aTHX_ OpSIBLING(kid));
1635     if (!name) /* XS module fiddling with the op tree */
1636         return;
1637     S_op_pretty(aTHX_ kid, &keysv, &key);
1638     assert(SvPOK(name));
1639     sv_chop(name,SvPVX(name)+1);
1640     if (key)
1641        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1642         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1643                    "Scalar value @%"SVf"%c%s%c better written as $%"SVf
1644                    "%c%s%c",
1645                     SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1646                     lbrack, key, rbrack);
1647     else
1648        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1649         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1650                    "Scalar value @%"SVf"%c%"SVf"%c better written as $%"
1651                     SVf"%c%"SVf"%c",
1652                     SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1653                     SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1654 }
1655
1656 OP *
1657 Perl_scalar(pTHX_ OP *o)
1658 {
1659     OP *kid;
1660
1661     /* assumes no premature commitment */
1662     if (!o || (PL_parser && PL_parser->error_count)
1663          || (o->op_flags & OPf_WANT)
1664          || o->op_type == OP_RETURN)
1665     {
1666         return o;
1667     }
1668
1669     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1670
1671     switch (o->op_type) {
1672     case OP_REPEAT:
1673         scalar(cBINOPo->op_first);
1674         if (o->op_private & OPpREPEAT_DOLIST) {
1675             kid = cLISTOPx(cUNOPo->op_first)->op_first;
1676             assert(kid->op_type == OP_PUSHMARK);
1677             if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1678                 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1679                 o->op_private &=~ OPpREPEAT_DOLIST;
1680             }
1681         }
1682         break;
1683     case OP_OR:
1684     case OP_AND:
1685     case OP_COND_EXPR:
1686         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
1687             scalar(kid);
1688         break;
1689         /* FALLTHROUGH */
1690     case OP_SPLIT:
1691     case OP_MATCH:
1692     case OP_QR:
1693     case OP_SUBST:
1694     case OP_NULL:
1695     default:
1696         if (o->op_flags & OPf_KIDS) {
1697             for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1698                 scalar(kid);
1699         }
1700         break;
1701     case OP_LEAVE:
1702     case OP_LEAVETRY:
1703         kid = cLISTOPo->op_first;
1704         scalar(kid);
1705         kid = OpSIBLING(kid);
1706     do_kids:
1707         while (kid) {
1708             OP *sib = OpSIBLING(kid);
1709             if (sib && kid->op_type != OP_LEAVEWHEN
1710              && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
1711                 || (  sib->op_targ != OP_NEXTSTATE
1712                    && sib->op_targ != OP_DBSTATE  )))
1713                 scalarvoid(kid);
1714             else
1715                 scalar(kid);
1716             kid = sib;
1717         }
1718         PL_curcop = &PL_compiling;
1719         break;
1720     case OP_SCOPE:
1721     case OP_LINESEQ:
1722     case OP_LIST:
1723         kid = cLISTOPo->op_first;
1724         goto do_kids;
1725     case OP_SORT:
1726         Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1727         break;
1728     case OP_KVHSLICE:
1729     case OP_KVASLICE:
1730     {
1731         /* Warn about scalar context */
1732         const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1733         const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1734         SV *name;
1735         SV *keysv;
1736         const char *key = NULL;
1737
1738         /* This warning can be nonsensical when there is a syntax error. */
1739         if (PL_parser && PL_parser->error_count)
1740             break;
1741
1742         if (!ckWARN(WARN_SYNTAX)) break;
1743
1744         kid = cLISTOPo->op_first;
1745         kid = OpSIBLING(kid); /* get past pushmark */
1746         assert(OpSIBLING(kid));
1747         name = S_op_varname(aTHX_ OpSIBLING(kid));
1748         if (!name) /* XS module fiddling with the op tree */
1749             break;
1750         S_op_pretty(aTHX_ kid, &keysv, &key);
1751         assert(SvPOK(name));
1752         sv_chop(name,SvPVX(name)+1);
1753         if (key)
1754   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1755             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1756                        "%%%"SVf"%c%s%c in scalar context better written "
1757                        "as $%"SVf"%c%s%c",
1758                         SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1759                         lbrack, key, rbrack);
1760         else
1761   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1762             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1763                        "%%%"SVf"%c%"SVf"%c in scalar context better "
1764                        "written as $%"SVf"%c%"SVf"%c",
1765                         SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1766                         SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1767     }
1768     }
1769     return o;
1770 }
1771
1772 OP *
1773 Perl_scalarvoid(pTHX_ OP *arg)
1774 {
1775     dVAR;
1776     OP *kid;
1777     SV* sv;
1778     U8 want;
1779     SSize_t defer_stack_alloc = 0;
1780     SSize_t defer_ix = -1;
1781     OP **defer_stack = NULL;
1782     OP *o = arg;
1783
1784     PERL_ARGS_ASSERT_SCALARVOID;
1785
1786     do {
1787         SV *useless_sv = NULL;
1788         const char* useless = NULL;
1789
1790         if (o->op_type == OP_NEXTSTATE
1791             || o->op_type == OP_DBSTATE
1792             || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1793                                           || o->op_targ == OP_DBSTATE)))
1794             PL_curcop = (COP*)o;                /* for warning below */
1795
1796         /* assumes no premature commitment */
1797         want = o->op_flags & OPf_WANT;
1798         if ((want && want != OPf_WANT_SCALAR)
1799             || (PL_parser && PL_parser->error_count)
1800             || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1801         {
1802             continue;
1803         }
1804
1805         if ((o->op_private & OPpTARGET_MY)
1806             && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1807         {
1808             /* newASSIGNOP has already applied scalar context, which we
1809                leave, as if this op is inside SASSIGN.  */
1810             continue;
1811         }
1812
1813         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1814
1815         switch (o->op_type) {
1816         default:
1817             if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1818                 break;
1819             /* FALLTHROUGH */
1820         case OP_REPEAT:
1821             if (o->op_flags & OPf_STACKED)
1822                 break;
1823             if (o->op_type == OP_REPEAT)
1824                 scalar(cBINOPo->op_first);
1825             goto func_ops;
1826         case OP_SUBSTR:
1827             if (o->op_private == 4)
1828                 break;
1829             /* FALLTHROUGH */
1830         case OP_WANTARRAY:
1831         case OP_GV:
1832         case OP_SMARTMATCH:
1833         case OP_AV2ARYLEN:
1834         case OP_REF:
1835         case OP_REFGEN:
1836         case OP_SREFGEN:
1837         case OP_DEFINED:
1838         case OP_HEX:
1839         case OP_OCT:
1840         case OP_LENGTH:
1841         case OP_VEC:
1842         case OP_INDEX:
1843         case OP_RINDEX:
1844         case OP_SPRINTF:
1845         case OP_KVASLICE:
1846         case OP_KVHSLICE:
1847         case OP_UNPACK:
1848         case OP_PACK:
1849         case OP_JOIN:
1850         case OP_LSLICE:
1851         case OP_ANONLIST:
1852         case OP_ANONHASH:
1853         case OP_SORT:
1854         case OP_REVERSE:
1855         case OP_RANGE:
1856         case OP_FLIP:
1857         case OP_FLOP:
1858         case OP_CALLER:
1859         case OP_FILENO:
1860         case OP_EOF:
1861         case OP_TELL:
1862         case OP_GETSOCKNAME:
1863         case OP_GETPEERNAME:
1864         case OP_READLINK:
1865         case OP_TELLDIR:
1866         case OP_GETPPID:
1867         case OP_GETPGRP:
1868         case OP_GETPRIORITY:
1869         case OP_TIME:
1870         case OP_TMS:
1871         case OP_LOCALTIME:
1872         case OP_GMTIME:
1873         case OP_GHBYNAME:
1874         case OP_GHBYADDR:
1875         case OP_GHOSTENT:
1876         case OP_GNBYNAME:
1877         case OP_GNBYADDR:
1878         case OP_GNETENT:
1879         case OP_GPBYNAME:
1880         case OP_GPBYNUMBER:
1881         case OP_GPROTOENT:
1882         case OP_GSBYNAME:
1883         case OP_GSBYPORT:
1884         case OP_GSERVENT:
1885         case OP_GPWNAM:
1886         case OP_GPWUID:
1887         case OP_GGRNAM:
1888         case OP_GGRGID:
1889         case OP_GETLOGIN:
1890         case OP_PROTOTYPE:
1891         case OP_RUNCV:
1892         func_ops:
1893             useless = OP_DESC(o);
1894             break;
1895
1896         case OP_GVSV:
1897         case OP_PADSV:
1898         case OP_PADAV:
1899         case OP_PADHV:
1900         case OP_PADANY:
1901         case OP_AELEM:
1902         case OP_AELEMFAST:
1903         case OP_AELEMFAST_LEX:
1904         case OP_ASLICE:
1905         case OP_HELEM:
1906         case OP_HSLICE:
1907             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1908                 /* Otherwise it's "Useless use of grep iterator" */
1909                 useless = OP_DESC(o);
1910             break;
1911
1912         case OP_SPLIT:
1913             kid = cLISTOPo->op_first;
1914             if (kid && kid->op_type == OP_PUSHRE
1915                 && !kid->op_targ
1916                 && !(o->op_flags & OPf_STACKED)
1917 #ifdef USE_ITHREADS
1918                 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
1919 #else
1920                 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
1921 #endif
1922                 )
1923                 useless = OP_DESC(o);
1924             break;
1925
1926         case OP_NOT:
1927             kid = cUNOPo->op_first;
1928             if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1929                 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1930                 goto func_ops;
1931             }
1932             useless = "negative pattern binding (!~)";
1933             break;
1934
1935         case OP_SUBST:
1936             if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1937                 useless = "non-destructive substitution (s///r)";
1938             break;
1939
1940         case OP_TRANSR:
1941             useless = "non-destructive transliteration (tr///r)";
1942             break;
1943
1944         case OP_RV2GV:
1945         case OP_RV2SV:
1946         case OP_RV2AV:
1947         case OP_RV2HV:
1948             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1949                 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
1950                 useless = "a variable";
1951             break;
1952
1953         case OP_CONST:
1954             sv = cSVOPo_sv;
1955             if (cSVOPo->op_private & OPpCONST_STRICT)
1956                 no_bareword_allowed(o);
1957             else {
1958                 if (ckWARN(WARN_VOID)) {
1959                     NV nv;
1960                     /* don't warn on optimised away booleans, eg
1961                      * use constant Foo, 5; Foo || print; */
1962                     if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1963                         useless = NULL;
1964                     /* the constants 0 and 1 are permitted as they are
1965                        conventionally used as dummies in constructs like
1966                        1 while some_condition_with_side_effects;  */
1967                     else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
1968                         useless = NULL;
1969                     else if (SvPOK(sv)) {
1970                         SV * const dsv = newSVpvs("");
1971                         useless_sv
1972                             = Perl_newSVpvf(aTHX_
1973                                             "a constant (%s)",
1974                                             pv_pretty(dsv, SvPVX_const(sv),
1975                                                       SvCUR(sv), 32, NULL, NULL,
1976                                                       PERL_PV_PRETTY_DUMP
1977                                                       | PERL_PV_ESCAPE_NOCLEAR
1978                                                       | PERL_PV_ESCAPE_UNI_DETECT));
1979                         SvREFCNT_dec_NN(dsv);
1980                     }
1981                     else if (SvOK(sv)) {
1982                         useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", SVfARG(sv));
1983                     }
1984                     else
1985                         useless = "a constant (undef)";
1986                 }
1987             }
1988             op_null(o);         /* don't execute or even remember it */
1989             break;
1990
1991         case OP_POSTINC:
1992             OpTYPE_set(o, OP_PREINC);  /* pre-increment is faster */
1993             break;
1994
1995         case OP_POSTDEC:
1996             OpTYPE_set(o, OP_PREDEC);  /* pre-decrement is faster */
1997             break;
1998
1999         case OP_I_POSTINC:
2000             OpTYPE_set(o, OP_I_PREINC);        /* pre-increment is faster */
2001             break;
2002
2003         case OP_I_POSTDEC:
2004             OpTYPE_set(o, OP_I_PREDEC);        /* pre-decrement is faster */
2005             break;
2006
2007         case OP_SASSIGN: {
2008             OP *rv2gv;
2009             UNOP *refgen, *rv2cv;
2010             LISTOP *exlist;
2011
2012             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2013                 break;
2014
2015             rv2gv = ((BINOP *)o)->op_last;
2016             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2017                 break;
2018
2019             refgen = (UNOP *)((BINOP *)o)->op_first;
2020
2021             if (!refgen || (refgen->op_type != OP_REFGEN
2022                             && refgen->op_type != OP_SREFGEN))
2023                 break;
2024
2025             exlist = (LISTOP *)refgen->op_first;
2026             if (!exlist || exlist->op_type != OP_NULL
2027                 || exlist->op_targ != OP_LIST)
2028                 break;
2029
2030             if (exlist->op_first->op_type != OP_PUSHMARK
2031                 && exlist->op_first != exlist->op_last)
2032                 break;
2033
2034             rv2cv = (UNOP*)exlist->op_last;
2035
2036             if (rv2cv->op_type != OP_RV2CV)
2037                 break;
2038
2039             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2040             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2041             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2042
2043             o->op_private |= OPpASSIGN_CV_TO_GV;
2044             rv2gv->op_private |= OPpDONT_INIT_GV;
2045             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2046
2047             break;
2048         }
2049
2050         case OP_AASSIGN: {
2051             inplace_aassign(o);
2052             break;
2053         }
2054
2055         case OP_OR:
2056         case OP_AND:
2057             kid = cLOGOPo->op_first;
2058             if (kid->op_type == OP_NOT
2059                 && (kid->op_flags & OPf_KIDS)) {
2060                 if (o->op_type == OP_AND) {
2061                     OpTYPE_set(o, OP_OR);
2062                 } else {
2063                     OpTYPE_set(o, OP_AND);
2064                 }
2065                 op_null(kid);
2066             }
2067             /* FALLTHROUGH */
2068
2069         case OP_DOR:
2070         case OP_COND_EXPR:
2071         case OP_ENTERGIVEN:
2072         case OP_ENTERWHEN:
2073             for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2074                 if (!(kid->op_flags & OPf_KIDS))
2075                     scalarvoid(kid);
2076                 else
2077                     DEFER_OP(kid);
2078         break;
2079
2080         case OP_NULL:
2081             if (o->op_flags & OPf_STACKED)
2082                 break;
2083             /* FALLTHROUGH */
2084         case OP_NEXTSTATE:
2085         case OP_DBSTATE:
2086         case OP_ENTERTRY:
2087         case OP_ENTER:
2088             if (!(o->op_flags & OPf_KIDS))
2089                 break;
2090             /* FALLTHROUGH */
2091         case OP_SCOPE:
2092         case OP_LEAVE:
2093         case OP_LEAVETRY:
2094         case OP_LEAVELOOP:
2095         case OP_LINESEQ:
2096         case OP_LEAVEGIVEN:
2097         case OP_LEAVEWHEN:
2098         kids:
2099             for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2100                 if (!(kid->op_flags & OPf_KIDS))
2101                     scalarvoid(kid);
2102                 else
2103                     DEFER_OP(kid);
2104             break;
2105         case OP_LIST:
2106             /* If the first kid after pushmark is something that the padrange
2107                optimisation would reject, then null the list and the pushmark.
2108             */
2109             if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2110                 && (  !(kid = OpSIBLING(kid))
2111                       || (  kid->op_type != OP_PADSV
2112                             && kid->op_type != OP_PADAV
2113                             && kid->op_type != OP_PADHV)
2114                       || kid->op_private & ~OPpLVAL_INTRO
2115                       || !(kid = OpSIBLING(kid))
2116                       || (  kid->op_type != OP_PADSV
2117                             && kid->op_type != OP_PADAV
2118                             && kid->op_type != OP_PADHV)
2119                       || kid->op_private & ~OPpLVAL_INTRO)
2120             ) {
2121                 op_null(cUNOPo->op_first); /* NULL the pushmark */
2122                 op_null(o); /* NULL the list */
2123             }
2124             goto kids;
2125         case OP_ENTEREVAL:
2126             scalarkids(o);
2127             break;
2128         case OP_SCALAR:
2129             scalar(o);
2130             break;
2131         }
2132
2133         if (useless_sv) {
2134             /* mortalise it, in case warnings are fatal.  */
2135             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2136                            "Useless use of %"SVf" in void context",
2137                            SVfARG(sv_2mortal(useless_sv)));
2138         }
2139         else if (useless) {
2140             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2141                            "Useless use of %s in void context",
2142                            useless);
2143         }
2144     } while ( (o = POP_DEFERRED_OP()) );
2145
2146     Safefree(defer_stack);
2147
2148     return arg;
2149 }
2150
2151 static OP *
2152 S_listkids(pTHX_ OP *o)
2153 {
2154     if (o && o->op_flags & OPf_KIDS) {
2155         OP *kid;
2156         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2157             list(kid);
2158     }
2159     return o;
2160 }
2161
2162 OP *
2163 Perl_list(pTHX_ OP *o)
2164 {
2165     OP *kid;
2166
2167     /* assumes no premature commitment */
2168     if (!o || (o->op_flags & OPf_WANT)
2169          || (PL_parser && PL_parser->error_count)
2170          || o->op_type == OP_RETURN)
2171     {
2172         return o;
2173     }
2174
2175     if ((o->op_private & OPpTARGET_MY)
2176         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2177     {
2178         return o;                               /* As if inside SASSIGN */
2179     }
2180
2181     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2182
2183     switch (o->op_type) {
2184     case OP_FLOP:
2185         list(cBINOPo->op_first);
2186         break;
2187     case OP_REPEAT:
2188         if (o->op_private & OPpREPEAT_DOLIST
2189          && !(o->op_flags & OPf_STACKED))
2190         {
2191             list(cBINOPo->op_first);
2192             kid = cBINOPo->op_last;
2193             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2194              && SvIVX(kSVOP_sv) == 1)
2195             {
2196                 op_null(o); /* repeat */
2197                 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2198                 /* const (rhs): */
2199                 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2200             }
2201         }
2202         break;
2203     case OP_OR:
2204     case OP_AND:
2205     case OP_COND_EXPR:
2206         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2207             list(kid);
2208         break;
2209     default:
2210     case OP_MATCH:
2211     case OP_QR:
2212     case OP_SUBST:
2213     case OP_NULL:
2214         if (!(o->op_flags & OPf_KIDS))
2215             break;
2216         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2217             list(cBINOPo->op_first);
2218             return gen_constant_list(o);
2219         }
2220         listkids(o);
2221         break;
2222     case OP_LIST:
2223         listkids(o);
2224         if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2225             op_null(cUNOPo->op_first); /* NULL the pushmark */
2226             op_null(o); /* NULL the list */
2227         }
2228         break;
2229     case OP_LEAVE:
2230     case OP_LEAVETRY:
2231         kid = cLISTOPo->op_first;
2232         list(kid);
2233         kid = OpSIBLING(kid);
2234     do_kids:
2235         while (kid) {
2236             OP *sib = OpSIBLING(kid);
2237             if (sib && kid->op_type != OP_LEAVEWHEN)
2238                 scalarvoid(kid);
2239             else
2240                 list(kid);
2241             kid = sib;
2242         }
2243         PL_curcop = &PL_compiling;
2244         break;
2245     case OP_SCOPE:
2246     case OP_LINESEQ:
2247         kid = cLISTOPo->op_first;
2248         goto do_kids;
2249     }
2250     return o;
2251 }
2252
2253 static OP *
2254 S_scalarseq(pTHX_ OP *o)
2255 {
2256     if (o) {
2257         const OPCODE type = o->op_type;
2258
2259         if (type == OP_LINESEQ || type == OP_SCOPE ||
2260             type == OP_LEAVE || type == OP_LEAVETRY)
2261         {
2262             OP *kid, *sib;
2263             for (kid = cLISTOPo->op_first; kid; kid = sib) {
2264                 if ((sib = OpSIBLING(kid))
2265                  && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2266                     || (  sib->op_targ != OP_NEXTSTATE
2267                        && sib->op_targ != OP_DBSTATE  )))
2268                 {
2269                     scalarvoid(kid);
2270                 }
2271             }
2272             PL_curcop = &PL_compiling;
2273         }
2274         o->op_flags &= ~OPf_PARENS;
2275         if (PL_hints & HINT_BLOCK_SCOPE)
2276             o->op_flags |= OPf_PARENS;
2277     }
2278     else
2279         o = newOP(OP_STUB, 0);
2280     return o;
2281 }
2282
2283 STATIC OP *
2284 S_modkids(pTHX_ OP *o, I32 type)
2285 {
2286     if (o && o->op_flags & OPf_KIDS) {
2287         OP *kid;
2288         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2289             op_lvalue(kid, type);
2290     }
2291     return o;
2292 }
2293
2294
2295 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2296  * const fields. Also, convert CONST keys to HEK-in-SVs.
2297  * rop is the op that retrieves the hash;
2298  * key_op is the first key
2299  */
2300
2301 void
2302 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op)
2303 {
2304     PADNAME *lexname;
2305     GV **fields;
2306     bool check_fields;
2307
2308     /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2309     if (rop) {
2310         if (rop->op_first->op_type == OP_PADSV)
2311             /* @$hash{qw(keys here)} */
2312             rop = (UNOP*)rop->op_first;
2313         else {
2314             /* @{$hash}{qw(keys here)} */
2315             if (rop->op_first->op_type == OP_SCOPE
2316                 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2317                 {
2318                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2319                 }
2320             else
2321                 rop = NULL;
2322         }
2323     }
2324
2325     lexname = NULL; /* just to silence compiler warnings */
2326     fields  = NULL; /* just to silence compiler warnings */
2327
2328     check_fields =
2329             rop
2330          && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2331              SvPAD_TYPED(lexname))
2332          && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2333          && isGV(*fields) && GvHV(*fields);
2334
2335     for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2336         SV **svp, *sv;
2337         if (key_op->op_type != OP_CONST)
2338             continue;
2339         svp = cSVOPx_svp(key_op);
2340
2341         /* Make the CONST have a shared SV */
2342         if (   !SvIsCOW_shared_hash(sv = *svp)
2343             && SvTYPE(sv) < SVt_PVMG
2344             && SvOK(sv)
2345             && !SvROK(sv))
2346         {
2347             SSize_t keylen;
2348             const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2349             SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2350             SvREFCNT_dec_NN(sv);
2351             *svp = nsv;
2352         }
2353
2354         if (   check_fields
2355             && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2356         {
2357             Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
2358                         "in variable %"PNf" of type %"HEKf,
2359                         SVfARG(*svp), PNfARG(lexname),
2360                         HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2361         }
2362     }
2363 }
2364
2365
2366 /*
2367 =for apidoc finalize_optree
2368
2369 This function finalizes the optree.  Should be called directly after
2370 the complete optree is built.  It does some additional
2371 checking which can't be done in the normal ck_xxx functions and makes
2372 the tree thread-safe.
2373
2374 =cut
2375 */
2376 void
2377 Perl_finalize_optree(pTHX_ OP* o)
2378 {
2379     PERL_ARGS_ASSERT_FINALIZE_OPTREE;
2380
2381     ENTER;
2382     SAVEVPTR(PL_curcop);
2383
2384     finalize_op(o);
2385
2386     LEAVE;
2387 }
2388
2389 #ifdef USE_ITHREADS
2390 /* Relocate sv to the pad for thread safety.
2391  * Despite being a "constant", the SV is written to,
2392  * for reference counts, sv_upgrade() etc. */
2393 PERL_STATIC_INLINE void
2394 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
2395 {
2396     PADOFFSET ix;
2397     PERL_ARGS_ASSERT_OP_RELOCATE_SV;
2398     if (!*svp) return;
2399     ix = pad_alloc(OP_CONST, SVf_READONLY);
2400     SvREFCNT_dec(PAD_SVl(ix));
2401     PAD_SETSV(ix, *svp);
2402     /* XXX I don't know how this isn't readonly already. */
2403     if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
2404     *svp = NULL;
2405     *targp = ix;
2406 }
2407 #endif
2408
2409
2410 STATIC void
2411 S_finalize_op(pTHX_ OP* o)
2412 {
2413     PERL_ARGS_ASSERT_FINALIZE_OP;
2414
2415
2416     switch (o->op_type) {
2417     case OP_NEXTSTATE:
2418     case OP_DBSTATE:
2419         PL_curcop = ((COP*)o);          /* for warnings */
2420         break;
2421     case OP_EXEC:
2422         if (OpHAS_SIBLING(o)) {
2423             OP *sib = OpSIBLING(o);
2424             if ((  sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
2425                 && ckWARN(WARN_EXEC)
2426                 && OpHAS_SIBLING(sib))
2427             {
2428                     const OPCODE type = OpSIBLING(sib)->op_type;
2429                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
2430                         const line_t oldline = CopLINE(PL_curcop);
2431                         CopLINE_set(PL_curcop, CopLINE((COP*)sib));
2432                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
2433                             "Statement unlikely to be reached");
2434                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
2435                             "\t(Maybe you meant system() when you said exec()?)\n");
2436                         CopLINE_set(PL_curcop, oldline);
2437                     }
2438             }
2439         }
2440         break;
2441
2442     case OP_GV:
2443         if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
2444             GV * const gv = cGVOPo_gv;
2445             if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
2446                 /* XXX could check prototype here instead of just carping */
2447                 SV * const sv = sv_newmortal();
2448                 gv_efullname3(sv, gv, NULL);
2449                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
2450                     "%"SVf"() called too early to check prototype",
2451                     SVfARG(sv));
2452             }
2453         }
2454         break;
2455
2456     case OP_CONST:
2457         if (cSVOPo->op_private & OPpCONST_STRICT)
2458             no_bareword_allowed(o);
2459         /* FALLTHROUGH */
2460 #ifdef USE_ITHREADS
2461     case OP_HINTSEVAL:
2462         op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
2463 #endif
2464         break;
2465
2466 #ifdef USE_ITHREADS
2467     /* Relocate all the METHOP's SVs to the pad for thread safety. */
2468     case OP_METHOD_NAMED:
2469     case OP_METHOD_SUPER:
2470     case OP_METHOD_REDIR:
2471     case OP_METHOD_REDIR_SUPER:
2472         op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
2473         break;
2474 #endif
2475
2476     case OP_HELEM: {
2477         UNOP *rop;
2478         SVOP *key_op;
2479         OP *kid;
2480
2481         if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
2482             break;
2483
2484         rop = (UNOP*)((BINOP*)o)->op_first;
2485
2486         goto check_keys;
2487
2488     case OP_HSLICE:
2489         S_scalar_slice_warning(aTHX_ o);
2490         /* FALLTHROUGH */
2491
2492     case OP_KVHSLICE:
2493         kid = OpSIBLING(cLISTOPo->op_first);
2494         if (/* I bet there's always a pushmark... */
2495             OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
2496             && OP_TYPE_ISNT_NN(kid, OP_CONST))
2497         {
2498             break;
2499         }
2500
2501         key_op = (SVOP*)(kid->op_type == OP_CONST
2502                                 ? kid
2503                                 : OpSIBLING(kLISTOP->op_first));
2504
2505         rop = (UNOP*)((LISTOP*)o)->op_last;
2506
2507       check_keys:
2508         if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
2509             rop = NULL;
2510         S_check_hash_fields_and_hekify(aTHX_ rop, key_op);
2511         break;
2512     }
2513     case OP_ASLICE:
2514         S_scalar_slice_warning(aTHX_ o);
2515         break;
2516
2517     case OP_SUBST: {
2518         if (cPMOPo->op_pmreplrootu.op_pmreplroot)
2519             finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
2520         break;
2521     }
2522     default:
2523         break;
2524     }
2525
2526     if (o->op_flags & OPf_KIDS) {
2527         OP *kid;
2528
2529 #ifdef DEBUGGING
2530         /* check that op_last points to the last sibling, and that
2531          * the last op_sibling/op_sibparent field points back to the
2532          * parent, and that the only ops with KIDS are those which are
2533          * entitled to them */
2534         U32 type = o->op_type;
2535         U32 family;
2536         bool has_last;
2537
2538         if (type == OP_NULL) {
2539             type = o->op_targ;
2540             /* ck_glob creates a null UNOP with ex-type GLOB
2541              * (which is a list op. So pretend it wasn't a listop */
2542             if (type == OP_GLOB)
2543                 type = OP_NULL;
2544         }
2545         family = PL_opargs[type] & OA_CLASS_MASK;
2546
2547         has_last = (   family == OA_BINOP
2548                     || family == OA_LISTOP
2549                     || family == OA_PMOP
2550                     || family == OA_LOOP
2551                    );
2552         assert(  has_last /* has op_first and op_last, or ...
2553               ... has (or may have) op_first: */
2554               || family == OA_UNOP
2555               || family == OA_UNOP_AUX
2556               || family == OA_LOGOP
2557               || family == OA_BASEOP_OR_UNOP
2558               || family == OA_FILESTATOP
2559               || family == OA_LOOPEXOP
2560               || family == OA_METHOP
2561               /* I don't know why SASSIGN is tagged as OA_BASEOP - DAPM */
2562               || type == OP_SASSIGN
2563               || type == OP_CUSTOM
2564               || type == OP_NULL /* new_logop does this */
2565               );
2566
2567         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2568 #  ifdef PERL_OP_PARENT
2569             if (!OpHAS_SIBLING(kid)) {
2570                 if (has_last)
2571                     assert(kid == cLISTOPo->op_last);
2572                 assert(kid->op_sibparent == o);
2573             }
2574 #  else
2575             if (has_last && !OpHAS_SIBLING(kid))
2576                 assert(kid == cLISTOPo->op_last);
2577 #  endif
2578         }
2579 #endif
2580
2581         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
2582             finalize_op(kid);
2583     }
2584 }
2585
2586 /*
2587 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
2588
2589 Propagate lvalue ("modifiable") context to an op and its children.
2590 I<type> represents the context type, roughly based on the type of op that
2591 would do the modifying, although C<local()> is represented by OP_NULL,
2592 because it has no op type of its own (it is signalled by a flag on
2593 the lvalue op).
2594
2595 This function detects things that can't be modified, such as C<$x+1>, and
2596 generates errors for them.  For example, C<$x+1 = 2> would cause it to be
2597 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
2598
2599 It also flags things that need to behave specially in an lvalue context,
2600 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
2601
2602 =cut
2603 */
2604
2605 static void
2606 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
2607 {
2608     CV *cv = PL_compcv;
2609     PadnameLVALUE_on(pn);
2610     while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
2611         cv = CvOUTSIDE(cv);
2612         assert(cv);
2613         assert(CvPADLIST(cv));
2614         pn =
2615            PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
2616         assert(PadnameLEN(pn));
2617         PadnameLVALUE_on(pn);
2618     }
2619 }
2620
2621 static bool
2622 S_vivifies(const OPCODE type)
2623 {
2624     switch(type) {
2625     case OP_RV2AV:     case   OP_ASLICE:
2626     case OP_RV2HV:     case OP_KVASLICE:
2627     case OP_RV2SV:     case   OP_HSLICE:
2628     case OP_AELEMFAST: case OP_KVHSLICE:
2629     case OP_HELEM:
2630     case OP_AELEM:
2631         return 1;
2632     }
2633     return 0;
2634 }
2635
2636 static void
2637 S_lvref(pTHX_ OP *o, I32 type)
2638 {
2639     dVAR;
2640     OP *kid;
2641     switch (o->op_type) {
2642     case OP_COND_EXPR:
2643         for (kid = OpSIBLING(cUNOPo->op_first); kid;
2644              kid = OpSIBLING(kid))
2645             S_lvref(aTHX_ kid, type);
2646         /* FALLTHROUGH */
2647     case OP_PUSHMARK:
2648         return;
2649     case OP_RV2AV:
2650         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2651         o->op_flags |= OPf_STACKED;
2652         if (o->op_flags & OPf_PARENS) {
2653             if (o->op_private & OPpLVAL_INTRO) {
2654                  yyerror(Perl_form(aTHX_ "Can't modify reference to "
2655                       "localized parenthesized array in list assignment"));
2656                 return;
2657             }
2658           slurpy:
2659             OpTYPE_set(o, OP_LVAVREF);
2660             o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
2661             o->op_flags |= OPf_MOD|OPf_REF;
2662             return;
2663         }
2664         o->op_private |= OPpLVREF_AV;
2665         goto checkgv;
2666     case OP_RV2CV:
2667         kid = cUNOPo->op_first;
2668         if (kid->op_type == OP_NULL)
2669             kid = cUNOPx(OpSIBLING(kUNOP->op_first))
2670                 ->op_first;
2671         o->op_private = OPpLVREF_CV;
2672         if (kid->op_type == OP_GV)
2673             o->op_flags |= OPf_STACKED;
2674         else if (kid->op_type == OP_PADCV) {
2675             o->op_targ = kid->op_targ;
2676             kid->op_targ = 0;
2677             op_free(cUNOPo->op_first);
2678             cUNOPo->op_first = NULL;
2679             o->op_flags &=~ OPf_KIDS;
2680         }
2681         else goto badref;
2682         break;
2683     case OP_RV2HV:
2684         if (o->op_flags & OPf_PARENS) {
2685           parenhash:
2686             yyerror(Perl_form(aTHX_ "Can't modify reference to "
2687                                  "parenthesized hash in list assignment"));
2688                 return;
2689         }
2690         o->op_private |= OPpLVREF_HV;
2691         /* FALLTHROUGH */
2692     case OP_RV2SV:
2693       checkgv:
2694         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2695         o->op_flags |= OPf_STACKED;
2696         break;
2697     case OP_PADHV:
2698         if (o->op_flags & OPf_PARENS) goto parenhash;
2699         o->op_private |= OPpLVREF_HV;
2700         /* FALLTHROUGH */
2701     case OP_PADSV:
2702         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2703         break;
2704     case OP_PADAV:
2705         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2706         if (o->op_flags & OPf_PARENS) goto slurpy;
2707         o->op_private |= OPpLVREF_AV;
2708         break;
2709     case OP_AELEM:
2710     case OP_HELEM:
2711         o->op_private |= OPpLVREF_ELEM;
2712         o->op_flags   |= OPf_STACKED;
2713         break;
2714     case OP_ASLICE:
2715     case OP_HSLICE:
2716         OpTYPE_set(o, OP_LVREFSLICE);
2717         o->op_private &= OPpLVAL_INTRO|OPpLVREF_ELEM;
2718         return;
2719     case OP_NULL:
2720         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
2721             goto badref;
2722         else if (!(o->op_flags & OPf_KIDS))
2723             return;
2724         if (o->op_targ != OP_LIST) {
2725             S_lvref(aTHX_ cBINOPo->op_first, type);
2726             return;
2727         }
2728         /* FALLTHROUGH */
2729     case OP_LIST:
2730         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
2731             assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
2732             S_lvref(aTHX_ kid, type);
2733         }
2734         return;
2735     case OP_STUB:
2736         if (o->op_flags & OPf_PARENS)
2737             return;
2738         /* FALLTHROUGH */
2739     default:
2740       badref:
2741         /* diag_listed_as: Can't modify reference to %s in %s assignment */
2742         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
2743                      o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
2744                       ? "do block"
2745                       : OP_DESC(o),
2746                      PL_op_desc[type]));
2747     }
2748     OpTYPE_set(o, OP_LVREF);
2749     o->op_private &=
2750         OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
2751     if (type == OP_ENTERLOOP)
2752         o->op_private |= OPpLVREF_ITER;
2753 }
2754
2755 OP *
2756 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
2757 {
2758     dVAR;
2759     OP *kid;
2760     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2761     int localize = -1;
2762
2763     if (!o || (PL_parser && PL_parser->error_count))
2764         return o;
2765
2766     if ((o->op_private & OPpTARGET_MY)
2767         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2768     {
2769         return o;
2770     }
2771
2772     assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2773
2774     if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2775
2776     switch (o->op_type) {
2777     case OP_UNDEF:
2778         PL_modcount++;
2779         return o;
2780     case OP_STUB:
2781         if ((o->op_flags & OPf_PARENS))
2782             break;
2783         goto nomod;
2784     case OP_ENTERSUB:
2785         if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
2786             !(o->op_flags & OPf_STACKED)) {
2787             OpTYPE_set(o, OP_RV2CV);            /* entersub => rv2cv */
2788             assert(cUNOPo->op_first->op_type == OP_NULL);
2789             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
2790             break;
2791         }
2792         else {                          /* lvalue subroutine call */
2793             o->op_private |= OPpLVAL_INTRO;
2794             PL_modcount = RETURN_UNLIMITED_NUMBER;
2795             if (type == OP_GREPSTART || type == OP_ENTERSUB
2796              || type == OP_REFGEN    || type == OP_LEAVESUBLV) {
2797                 /* Potential lvalue context: */
2798                 o->op_private |= OPpENTERSUB_INARGS;
2799                 break;
2800             }
2801             else {                      /* Compile-time error message: */
2802                 OP *kid = cUNOPo->op_first;
2803                 CV *cv;
2804                 GV *gv;
2805
2806                 if (kid->op_type != OP_PUSHMARK) {
2807                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2808                         Perl_croak(aTHX_
2809                                 "panic: unexpected lvalue entersub "
2810                                 "args: type/targ %ld:%"UVuf,
2811                                 (long)kid->op_type, (UV)kid->op_targ);
2812                     kid = kLISTOP->op_first;
2813                 }
2814                 while (OpHAS_SIBLING(kid))
2815                     kid = OpSIBLING(kid);
2816                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
2817                     break;      /* Postpone until runtime */
2818                 }
2819
2820                 kid = kUNOP->op_first;
2821                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2822                     kid = kUNOP->op_first;
2823                 if (kid->op_type == OP_NULL)
2824                     Perl_croak(aTHX_
2825                                "Unexpected constant lvalue entersub "
2826                                "entry via type/targ %ld:%"UVuf,
2827                                (long)kid->op_type, (UV)kid->op_targ);
2828                 if (kid->op_type != OP_GV) {
2829                     break;
2830                 }
2831
2832                 gv = kGVOP_gv;
2833                 cv = isGV(gv)
2834                     ? GvCV(gv)
2835                     : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
2836                         ? MUTABLE_CV(SvRV(gv))
2837                         : NULL;
2838                 if (!cv)
2839                     break;
2840                 if (CvLVALUE(cv))
2841                     break;
2842             }
2843         }
2844         /* FALLTHROUGH */
2845     default:
2846       nomod:
2847         if (flags & OP_LVALUE_NO_CROAK) return NULL;
2848         /* grep, foreach, subcalls, refgen */
2849         if (type == OP_GREPSTART || type == OP_ENTERSUB
2850          || type == OP_REFGEN    || type == OP_LEAVESUBLV)
2851             break;
2852         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2853                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
2854                       ? "do block"
2855                       : (o->op_type == OP_ENTERSUB
2856                         ? "non-lvalue subroutine call"
2857                         : OP_DESC(o))),
2858                      type ? PL_op_desc[type] : "local"));
2859         return o;
2860
2861     case OP_PREINC:
2862     case OP_PREDEC:
2863     case OP_POW:
2864     case OP_MULTIPLY:
2865     case OP_DIVIDE:
2866     case OP_MODULO:
2867     case OP_ADD:
2868     case OP_SUBTRACT:
2869     case OP_CONCAT:
2870     case OP_LEFT_SHIFT:
2871     case OP_RIGHT_SHIFT:
2872     case OP_BIT_AND:
2873     case OP_BIT_XOR:
2874     case OP_BIT_OR:
2875     case OP_I_MULTIPLY:
2876     case OP_I_DIVIDE:
2877     case OP_I_MODULO:
2878     case OP_I_ADD:
2879     case OP_I_SUBTRACT:
2880         if (!(o->op_flags & OPf_STACKED))
2881             goto nomod;
2882         PL_modcount++;
2883         break;
2884
2885     case OP_REPEAT:
2886         if (o->op_flags & OPf_STACKED) {
2887             PL_modcount++;
2888             break;
2889         }
2890         if (!(o->op_private & OPpREPEAT_DOLIST))
2891             goto nomod;
2892         else {
2893             const I32 mods = PL_modcount;
2894             modkids(cBINOPo->op_first, type);
2895             if (type != OP_AASSIGN)
2896                 goto nomod;
2897             kid = cBINOPo->op_last;
2898             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
2899                 const IV iv = SvIV(kSVOP_sv);
2900                 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
2901                     PL_modcount =
2902                         mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
2903             }
2904             else
2905                 PL_modcount = RETURN_UNLIMITED_NUMBER;
2906         }
2907         break;
2908
2909     case OP_COND_EXPR:
2910         localize = 1;
2911         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2912             op_lvalue(kid, type);
2913         break;
2914
2915     case OP_RV2AV:
2916     case OP_RV2HV:
2917         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
2918            PL_modcount = RETURN_UNLIMITED_NUMBER;
2919             return o;           /* Treat \(@foo) like ordinary list. */
2920         }
2921         /* FALLTHROUGH */
2922     case OP_RV2GV:
2923         if (scalar_mod_type(o, type))
2924             goto nomod;
2925         ref(cUNOPo->op_first, o->op_type);
2926         /* FALLTHROUGH */
2927     case OP_ASLICE:
2928     case OP_HSLICE:
2929         localize = 1;
2930         /* FALLTHROUGH */
2931     case OP_AASSIGN:
2932         /* Do not apply the lvsub flag for rv2[ah]v in scalar context.  */
2933         if (type == OP_LEAVESUBLV && (
2934                 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
2935              || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2936            ))
2937             o->op_private |= OPpMAYBE_LVSUB;
2938         /* FALLTHROUGH */
2939     case OP_NEXTSTATE:
2940     case OP_DBSTATE:
2941        PL_modcount = RETURN_UNLIMITED_NUMBER;
2942         break;
2943     case OP_KVHSLICE:
2944     case OP_KVASLICE:
2945         if (type == OP_LEAVESUBLV)
2946             o->op_private |= OPpMAYBE_LVSUB;
2947         goto nomod;
2948     case OP_AV2ARYLEN:
2949         PL_hints |= HINT_BLOCK_SCOPE;
2950         if (type == OP_LEAVESUBLV)
2951             o->op_private |= OPpMAYBE_LVSUB;
2952         PL_modcount++;
2953         break;
2954     case OP_RV2SV:
2955         ref(cUNOPo->op_first, o->op_type);
2956         localize = 1;
2957         /* FALLTHROUGH */
2958     case OP_GV:
2959         PL_hints |= HINT_BLOCK_SCOPE;
2960         /* FALLTHROUGH */
2961     case OP_SASSIGN:
2962     case OP_ANDASSIGN:
2963     case OP_ORASSIGN:
2964     case OP_DORASSIGN:
2965         PL_modcount++;
2966         break;
2967
2968     case OP_AELEMFAST:
2969     case OP_AELEMFAST_LEX:
2970         localize = -1;
2971         PL_modcount++;
2972         break;
2973
2974     case OP_PADAV:
2975     case OP_PADHV:
2976        PL_modcount = RETURN_UNLIMITED_NUMBER;
2977         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
2978             return o;           /* Treat \(@foo) like ordinary list. */
2979         if (scalar_mod_type(o, type))
2980             goto nomod;
2981         if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2982           && type == OP_LEAVESUBLV)
2983             o->op_private |= OPpMAYBE_LVSUB;
2984         /* FALLTHROUGH */
2985     case OP_PADSV:
2986         PL_modcount++;
2987         if (!type) /* local() */
2988             Perl_croak(aTHX_ "Can't localize lexical variable %"PNf,
2989                               PNfARG(PAD_COMPNAME(o->op_targ)));
2990         if (!(o->op_private & OPpLVAL_INTRO)
2991          || (  type != OP_SASSIGN && type != OP_AASSIGN
2992             && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ))  ))
2993             S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
2994         break;
2995
2996     case OP_PUSHMARK:
2997         localize = 0;
2998         break;
2999
3000     case OP_KEYS:
3001     case OP_RKEYS:
3002         if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
3003             goto nomod;
3004         goto lvalue_func;
3005     case OP_SUBSTR:
3006         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
3007             goto nomod;
3008         /* FALLTHROUGH */
3009     case OP_POS:
3010     case OP_VEC:
3011       lvalue_func:
3012         if (type == OP_LEAVESUBLV)
3013             o->op_private |= OPpMAYBE_LVSUB;
3014         if (o->op_flags & OPf_KIDS)
3015             op_lvalue(OpSIBLING(cBINOPo->op_first), type);
3016         break;
3017
3018     case OP_AELEM:
3019     case OP_HELEM:
3020         ref(cBINOPo->op_first, o->op_type);
3021         if (type == OP_ENTERSUB &&
3022              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
3023             o->op_private |= OPpLVAL_DEFER;
3024         if (type == OP_LEAVESUBLV)
3025             o->op_private |= OPpMAYBE_LVSUB;
3026         localize = 1;
3027         PL_modcount++;
3028         break;
3029
3030     case OP_LEAVE:
3031     case OP_LEAVELOOP:
3032         o->op_private |= OPpLVALUE;
3033         /* FALLTHROUGH */
3034     case OP_SCOPE:
3035     case OP_ENTER:
3036     case OP_LINESEQ:
3037         localize = 0;
3038         if (o->op_flags & OPf_KIDS)
3039             op_lvalue(cLISTOPo->op_last, type);
3040         break;
3041
3042     case OP_NULL:
3043         localize = 0;
3044         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
3045             goto nomod;
3046         else if (!(o->op_flags & OPf_KIDS))
3047             break;
3048         if (o->op_targ != OP_LIST) {
3049             op_lvalue(cBINOPo->op_first, type);
3050             break;
3051         }
3052         /* FALLTHROUGH */
3053     case OP_LIST:
3054         localize = 0;
3055         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3056             /* elements might be in void context because the list is
3057                in scalar context or because they are attribute sub calls */
3058             if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
3059                 op_lvalue(kid, type);
3060         break;
3061
3062     case OP_COREARGS:
3063         return o;
3064
3065     case OP_AND:
3066     case OP_OR:
3067         if (type == OP_LEAVESUBLV
3068          || !S_vivifies(cLOGOPo->op_first->op_type))
3069             op_lvalue(cLOGOPo->op_first, type);
3070         if (type == OP_LEAVESUBLV
3071          || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
3072             op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
3073         goto nomod;
3074
3075     case OP_SREFGEN:
3076         if (type != OP_AASSIGN && type != OP_SASSIGN
3077          && type != OP_ENTERLOOP)
3078             goto nomod;
3079         /* Don’t bother applying lvalue context to the ex-list.  */
3080         kid = cUNOPx(cUNOPo->op_first)->op_first;
3081         assert (!OpHAS_SIBLING(kid));
3082         goto kid_2lvref;
3083     case OP_REFGEN:
3084         if (type != OP_AASSIGN) goto nomod;
3085         kid = cUNOPo->op_first;
3086       kid_2lvref:
3087         {
3088             const U8 ec = PL_parser ? PL_parser->error_count : 0;
3089             S_lvref(aTHX_ kid, type);
3090             if (!PL_parser || PL_parser->error_count == ec) {
3091                 if (!FEATURE_REFALIASING_IS_ENABLED)
3092                     Perl_croak(aTHX_
3093                        "Experimental aliasing via reference not enabled");
3094                 Perl_ck_warner_d(aTHX_
3095                                  packWARN(WARN_EXPERIMENTAL__REFALIASING),
3096                                 "Aliasing via reference is experimental");
3097             }
3098         }
3099         if (o->op_type == OP_REFGEN)
3100             op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
3101         op_null(o);
3102         return o;
3103
3104     case OP_SPLIT:
3105         kid = cLISTOPo->op_first;
3106         if (kid && kid->op_type == OP_PUSHRE &&
3107                 (  kid->op_targ
3108                 || o->op_flags & OPf_STACKED
3109 #ifdef USE_ITHREADS
3110                 || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
3111 #else
3112                 || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
3113 #endif
3114         )) {
3115             /* This is actually @array = split.  */
3116             PL_modcount = RETURN_UNLIMITED_NUMBER;
3117             break;
3118         }
3119         goto nomod;
3120
3121     case OP_SCALAR:
3122         op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
3123         goto nomod;
3124     }
3125
3126     /* [20011101.069] File test operators interpret OPf_REF to mean that
3127        their argument is a filehandle; thus \stat(".") should not set
3128        it. AMS 20011102 */
3129     if (type == OP_REFGEN &&
3130         PL_check[o->op_type] == Perl_ck_ftst)
3131         return o;
3132
3133     if (type != OP_LEAVESUBLV)
3134         o->op_flags |= OPf_MOD;
3135
3136     if (type == OP_AASSIGN || type == OP_SASSIGN)
3137         o->op_flags |= OPf_SPECIAL|OPf_REF;
3138     else if (!type) { /* local() */
3139         switch (localize) {
3140         case 1:
3141             o->op_private |= OPpLVAL_INTRO;
3142             o->op_flags &= ~OPf_SPECIAL;
3143             PL_hints |= HINT_BLOCK_SCOPE;
3144             break;
3145         case 0:
3146             break;
3147         case -1:
3148             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
3149                            "Useless localization of %s", OP_DESC(o));
3150         }
3151     }
3152     else if (type != OP_GREPSTART && type != OP_ENTERSUB
3153              && type != OP_LEAVESUBLV)
3154         o->op_flags |= OPf_REF;
3155     return o;
3156 }
3157
3158 STATIC bool
3159 S_scalar_mod_type(const OP *o, I32 type)
3160 {
3161     switch (type) {
3162     case OP_POS:
3163     case OP_SASSIGN:
3164         if (o && o->op_type == OP_RV2GV)
3165             return FALSE;
3166         /* FALLTHROUGH */
3167     case OP_PREINC:
3168     case OP_PREDEC:
3169     case OP_POSTINC:
3170     case OP_POSTDEC:
3171     case OP_I_PREINC:
3172     case OP_I_PREDEC:
3173     case OP_I_POSTINC:
3174     case OP_I_POSTDEC:
3175     case OP_POW:
3176     case OP_MULTIPLY:
3177     case OP_DIVIDE:
3178     case OP_MODULO:
3179     case OP_REPEAT:
3180     case OP_ADD:
3181     case OP_SUBTRACT:
3182     case OP_I_MULTIPLY:
3183     case OP_I_DIVIDE:
3184     case OP_I_MODULO:
3185     case OP_I_ADD:
3186     case OP_I_SUBTRACT:
3187     case OP_LEFT_SHIFT:
3188     case OP_RIGHT_SHIFT:
3189     case OP_BIT_AND:
3190     case OP_BIT_XOR:
3191     case OP_BIT_OR:
3192     case OP_CONCAT:
3193     case OP_SUBST:
3194     case OP_TRANS:
3195     case OP_TRANSR:
3196     case OP_READ:
3197     case OP_SYSREAD:
3198     case OP_RECV:
3199     case OP_ANDASSIGN:
3200     case OP_ORASSIGN:
3201     case OP_DORASSIGN:
3202         return TRUE;
3203     default:
3204         return FALSE;
3205     }
3206 }
3207
3208 STATIC bool
3209 S_is_handle_constructor(const OP *o, I32 numargs)
3210 {
3211     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
3212
3213     switch (o->op_type) {
3214     case OP_PIPE_OP:
3215     case OP_SOCKPAIR:
3216         if (numargs == 2)
3217             return TRUE;
3218         /* FALLTHROUGH */
3219     case OP_SYSOPEN:
3220     case OP_OPEN:
3221     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
3222     case OP_SOCKET:
3223     case OP_OPEN_DIR:
3224     case OP_ACCEPT:
3225         if (numargs == 1)
3226             return TRUE;
3227         /* FALLTHROUGH */
3228     default:
3229         return FALSE;
3230     }
3231 }
3232
3233 static OP *
3234 S_refkids(pTHX_ OP *o, I32 type)
3235 {
3236     if (o && o->op_flags & OPf_KIDS) {
3237         OP *kid;
3238         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3239             ref(kid, type);
3240     }
3241     return o;
3242 }
3243
3244 OP *
3245 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
3246 {
3247     dVAR;
3248     OP *kid;
3249
3250     PERL_ARGS_ASSERT_DOREF;
3251
3252     if (PL_parser && PL_parser->error_count)
3253         return o;
3254
3255     switch (o->op_type) {
3256     case OP_ENTERSUB:
3257         if ((type == OP_EXISTS || type == OP_DEFINED) &&
3258             !(o->op_flags & OPf_STACKED)) {
3259             OpTYPE_set(o, OP_RV2CV);             /* entersub => rv2cv */
3260             assert(cUNOPo->op_first->op_type == OP_NULL);
3261             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
3262             o->op_flags |= OPf_SPECIAL;
3263         }
3264         else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
3265             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3266                               : type == OP_RV2HV ? OPpDEREF_HV
3267                               : OPpDEREF_SV);
3268             o->op_flags |= OPf_MOD;
3269         }
3270
3271         break;
3272
3273     case OP_COND_EXPR:
3274         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
3275             doref(kid, type, set_op_ref);
3276         break;
3277     case OP_RV2SV:
3278         if (type == OP_DEFINED)
3279             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
3280         doref(cUNOPo->op_first, o->op_type, set_op_ref);
3281         /* FALLTHROUGH */
3282     case OP_PADSV:
3283         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3284             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3285                               : type == OP_RV2HV ? OPpDEREF_HV
3286                               : OPpDEREF_SV);
3287             o->op_flags |= OPf_MOD;
3288         }
3289         break;
3290
3291     case OP_RV2AV:
3292     case OP_RV2HV:
3293         if (set_op_ref)
3294             o->op_flags |= OPf_REF;
3295         /* FALLTHROUGH */
3296     case OP_RV2GV:
3297         if (type == OP_DEFINED)
3298             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
3299         doref(cUNOPo->op_first, o->op_type, set_op_ref);
3300         break;
3301
3302     case OP_PADAV:
3303     case OP_PADHV:
3304         if (set_op_ref)
3305             o->op_flags |= OPf_REF;
3306         break;
3307
3308     case OP_SCALAR:
3309     case OP_NULL:
3310         if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
3311             break;
3312         doref(cBINOPo->op_first, type, set_op_ref);
3313         break;
3314     case OP_AELEM:
3315     case OP_HELEM:
3316         doref(cBINOPo->op_first, o->op_type, set_op_ref);
3317         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3318             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3319                               : type == OP_RV2HV ? OPpDEREF_HV
3320                               : OPpDEREF_SV);
3321             o->op_flags |= OPf_MOD;
3322         }
3323         break;
3324
3325     case OP_SCOPE:
3326     case OP_LEAVE:
3327         set_op_ref = FALSE;
3328         /* FALLTHROUGH */
3329     case OP_ENTER:
3330     case OP_LIST:
3331         if (!(o->op_flags & OPf_KIDS))
3332             break;
3333         doref(cLISTOPo->op_last, type, set_op_ref);
3334         break;
3335     default:
3336         break;
3337     }
3338     return scalar(o);
3339
3340 }
3341
3342 STATIC OP *
3343 S_dup_attrlist(pTHX_ OP *o)
3344 {
3345     OP *rop;
3346
3347     PERL_ARGS_ASSERT_DUP_ATTRLIST;
3348
3349     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
3350      * where the first kid is OP_PUSHMARK and the remaining ones
3351      * are OP_CONST.  We need to push the OP_CONST values.
3352      */
3353     if (o->op_type == OP_CONST)
3354         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
3355     else {
3356         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
3357         rop = NULL;
3358         for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
3359             if (o->op_type == OP_CONST)
3360                 rop = op_append_elem(OP_LIST, rop,
3361                                   newSVOP(OP_CONST, o->op_flags,
3362                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
3363         }
3364     }
3365     return rop;
3366 }
3367
3368 STATIC void
3369 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
3370 {
3371     SV * const stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
3372
3373     PERL_ARGS_ASSERT_APPLY_ATTRS;
3374
3375     /* fake up C<use attributes $pkg,$rv,@attrs> */
3376
3377 #define ATTRSMODULE "attributes"
3378 #define ATTRSMODULE_PM "attributes.pm"
3379
3380     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3381                          newSVpvs(ATTRSMODULE),
3382                          NULL,
3383                          op_prepend_elem(OP_LIST,
3384                                       newSVOP(OP_CONST, 0, stashsv),
3385                                       op_prepend_elem(OP_LIST,
3386                                                    newSVOP(OP_CONST, 0,
3387                                                            newRV(target)),
3388                                                    dup_attrlist(attrs))));
3389 }
3390
3391 STATIC void
3392 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
3393 {
3394     OP *pack, *imop, *arg;
3395     SV *meth, *stashsv, **svp;
3396
3397     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
3398
3399     if (!attrs)
3400         return;
3401
3402     assert(target->op_type == OP_PADSV ||
3403            target->op_type == OP_PADHV ||
3404            target->op_type == OP_PADAV);
3405
3406     /* Ensure that attributes.pm is loaded. */
3407     /* Don't force the C<use> if we don't need it. */
3408     svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
3409     if (svp && *svp != &PL_sv_undef)
3410         NOOP;   /* already in %INC */
3411     else
3412         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
3413                                newSVpvs(ATTRSMODULE), NULL);
3414
3415     /* Need package name for method call. */
3416     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
3417
3418     /* Build up the real arg-list. */
3419     stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
3420
3421     arg = newOP(OP_PADSV, 0);
3422     arg->op_targ = target->op_targ;
3423     arg = op_prepend_elem(OP_LIST,
3424                        newSVOP(OP_CONST, 0, stashsv),
3425                        op_prepend_elem(OP_LIST,
3426                                     newUNOP(OP_REFGEN, 0,
3427                                             arg),
3428                                     dup_attrlist(attrs)));
3429
3430     /* Fake up a method call to import */
3431     meth = newSVpvs_share("import");
3432     imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
3433                    op_append_elem(OP_LIST,
3434                                op_prepend_elem(OP_LIST, pack, arg),
3435                                newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
3436
3437     /* Combine the ops. */
3438     *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
3439 }
3440
3441 /*
3442 =notfor apidoc apply_attrs_string
3443
3444 Attempts to apply a list of attributes specified by the C<attrstr> and
3445 C<len> arguments to the subroutine identified by the C<cv> argument which
3446 is expected to be associated with the package identified by the C<stashpv>
3447 argument (see L<attributes>).  It gets this wrong, though, in that it
3448 does not correctly identify the boundaries of the individual attribute
3449 specifications within C<attrstr>.  This is not really intended for the
3450 public API, but has to be listed here for systems such as AIX which
3451 need an explicit export list for symbols.  (It's called from XS code
3452 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
3453 to respect attribute syntax properly would be welcome.
3454
3455 =cut
3456 */
3457
3458 void
3459 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
3460                         const char *attrstr, STRLEN len)
3461 {
3462     OP *attrs = NULL;
3463
3464     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
3465
3466     if (!len) {
3467         len = strlen(attrstr);
3468     }
3469
3470     while (len) {
3471         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
3472         if (len) {
3473             const char * const sstr = attrstr;
3474             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
3475             attrs = op_append_elem(OP_LIST, attrs,
3476                                 newSVOP(OP_CONST, 0,
3477                                         newSVpvn(sstr, attrstr-sstr)));
3478         }
3479     }
3480
3481     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3482                      newSVpvs(ATTRSMODULE),
3483                      NULL, op_prepend_elem(OP_LIST,
3484                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
3485                                   op_prepend_elem(OP_LIST,
3486                                                newSVOP(OP_CONST, 0,
3487                                                        newRV(MUTABLE_SV(cv))),
3488                                                attrs)));
3489 }
3490
3491 STATIC void
3492 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
3493 {
3494     OP *new_proto = NULL;
3495     STRLEN pvlen;
3496     char *pv;
3497     OP *o;
3498
3499     PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
3500
3501     if (!*attrs)
3502         return;
3503
3504     o = *attrs;
3505     if (o->op_type == OP_CONST) {
3506         pv = SvPV(cSVOPo_sv, pvlen);
3507         if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3508             SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3509             SV ** const tmpo = cSVOPx_svp(o);
3510             SvREFCNT_dec(cSVOPo_sv);
3511             *tmpo = tmpsv;
3512             new_proto = o;
3513             *attrs = NULL;
3514         }
3515     } else if (o->op_type == OP_LIST) {
3516         OP * lasto;
3517         assert(o->op_flags & OPf_KIDS);
3518         lasto = cLISTOPo->op_first;
3519         assert(lasto->op_type == OP_PUSHMARK);
3520         for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
3521             if (o->op_type == OP_CONST) {
3522                 pv = SvPV(cSVOPo_sv, pvlen);
3523                 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3524                     SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3525                     SV ** const tmpo = cSVOPx_svp(o);
3526                     SvREFCNT_dec(cSVOPo_sv);
3527                     *tmpo = tmpsv;
3528                     if (new_proto && ckWARN(WARN_MISC)) {
3529                         STRLEN new_len;
3530                         const char * newp = SvPV(cSVOPo_sv, new_len);
3531                         Perl_warner(aTHX_ packWARN(WARN_MISC),
3532                             "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub",
3533                             UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
3534                         op_free(new_proto);
3535                     }
3536                     else if (new_proto)
3537                         op_free(new_proto);
3538                     new_proto = o;
3539                     /* excise new_proto from the list */
3540                     op_sibling_splice(*attrs, lasto, 1, NULL);
3541                     o = lasto;
3542                     continue;
3543                 }
3544             }
3545             lasto = o;
3546         }
3547         /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
3548            would get pulled in with no real need */
3549         if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
3550             op_free(*attrs);
3551             *attrs = NULL;
3552         }
3553     }
3554
3555     if (new_proto) {
3556         SV *svname;
3557         if (isGV(name)) {
3558             svname = sv_newmortal();
3559             gv_efullname3(svname, name, NULL);
3560         }
3561         else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
3562             svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
3563         else
3564             svname = (SV *)name;
3565         if (ckWARN(WARN_ILLEGALPROTO))
3566             (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
3567         if (*proto && ckWARN(WARN_PROTOTYPE)) {
3568             STRLEN old_len, new_len;
3569             const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
3570             const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
3571
3572             Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3573                 "Prototype '%"UTF8f"' overridden by attribute 'prototype(%"UTF8f")'"
3574                 " in %"SVf,
3575                 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
3576                 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
3577                 SVfARG(svname));
3578         }
3579         if (*proto)
3580             op_free(*proto);
3581         *proto = new_proto;
3582     }
3583 }
3584
3585 static void
3586 S_cant_declare(pTHX_ OP *o)
3587 {
3588     if (o->op_type == OP_NULL
3589      && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
3590         o = cUNOPo->op_first;
3591     yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
3592                              o->op_type == OP_NULL
3593                                && o->op_flags & OPf_SPECIAL
3594                                  ? "do block"
3595                                  : OP_DESC(o),
3596                              PL_parser->in_my == KEY_our   ? "our"   :
3597                              PL_parser->in_my == KEY_state ? "state" :
3598                                                              "my"));
3599 }
3600
3601 STATIC OP *
3602 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
3603 {
3604     I32 type;
3605     const bool stately = PL_parser && PL_parser->in_my == KEY_state;
3606
3607     PERL_ARGS_ASSERT_MY_KID;
3608
3609     if (!o || (PL_parser && PL_parser->error_count))
3610         return o;
3611
3612     type = o->op_type;
3613
3614     if (type == OP_LIST) {
3615         OP *kid;
3616         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3617             my_kid(kid, attrs, imopsp);
3618         return o;
3619     } else if (type == OP_UNDEF || type == OP_STUB) {
3620         return o;
3621     } else if (type == OP_RV2SV ||      /* "our" declaration */
3622                type == OP_RV2AV ||
3623                type == OP_RV2HV) { /* XXX does this let anything illegal in? */
3624         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
3625             S_cant_declare(aTHX_ o);
3626         } else if (attrs) {
3627             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
3628             assert(PL_parser);
3629             PL_parser->in_my = FALSE;
3630             PL_parser->in_my_stash = NULL;
3631             apply_attrs(GvSTASH(gv),
3632                         (type == OP_RV2SV ? GvSV(gv) :
3633                          type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
3634                          type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
3635                         attrs);
3636         }
3637         o->op_private |= OPpOUR_INTRO;
3638         return o;
3639     }
3640     else if (type != OP_PADSV &&
3641              type != OP_PADAV &&
3642              type != OP_PADHV &&
3643              type != OP_PUSHMARK)
3644     {
3645         S_cant_declare(aTHX_ o);
3646         return o;
3647     }
3648     else if (attrs && type != OP_PUSHMARK) {
3649         HV *stash;
3650
3651         assert(PL_parser);
3652         PL_parser->in_my = FALSE;
3653         PL_parser->in_my_stash = NULL;
3654
3655         /* check for C<my Dog $spot> when deciding package */
3656         stash = PAD_COMPNAME_TYPE(o->op_targ);
3657         if (!stash)
3658             stash = PL_curstash;
3659         apply_attrs_my(stash, o, attrs, imopsp);
3660     }
3661     o->op_flags |= OPf_MOD;
3662     o->op_private |= OPpLVAL_INTRO;
3663     if (stately)
3664         o->op_private |= OPpPAD_STATE;
3665     return o;
3666 }
3667
3668 OP *
3669 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
3670 {
3671     OP *rops;
3672     int maybe_scalar = 0;
3673
3674     PERL_ARGS_ASSERT_MY_ATTRS;
3675
3676 /* [perl #17376]: this appears to be premature, and results in code such as
3677    C< our(%x); > executing in list mode rather than void mode */
3678 #if 0
3679     if (o->op_flags & OPf_PARENS)
3680         list(o);
3681     else
3682         maybe_scalar = 1;
3683 #else
3684     maybe_scalar = 1;
3685 #endif
3686     if (attrs)
3687         SAVEFREEOP(attrs);
3688     rops = NULL;
3689     o = my_kid(o, attrs, &rops);
3690     if (rops) {
3691         if (maybe_scalar && o->op_type == OP_PADSV) {
3692             o = scalar(op_append_list(OP_LIST, rops, o));
3693             o->op_private |= OPpLVAL_INTRO;
3694         }
3695         else {
3696             /* The listop in rops might have a pushmark at the beginning,
3697                which will mess up list assignment. */
3698             LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
3699             if (rops->op_type == OP_LIST &&
3700                 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
3701             {
3702                 OP * const pushmark = lrops->op_first;
3703                 /* excise pushmark */
3704                 op_sibling_splice(rops, NULL, 1, NULL);
3705                 op_free(pushmark);
3706             }
3707             o = op_append_list(OP_LIST, o, rops);
3708         }
3709     }
3710     PL_parser->in_my = FALSE;
3711     PL_parser->in_my_stash = NULL;
3712     return o;
3713 }
3714
3715 OP *
3716 Perl_sawparens(pTHX_ OP *o)
3717 {
3718     PERL_UNUSED_CONTEXT;
3719     if (o)
3720         o->op_flags |= OPf_PARENS;
3721     return o;
3722 }
3723
3724 OP *
3725 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
3726 {
3727     OP *o;
3728     bool ismatchop = 0;
3729     const OPCODE ltype = left->op_type;
3730     const OPCODE rtype = right->op_type;
3731
3732     PERL_ARGS_ASSERT_BIND_MATCH;
3733
3734     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
3735           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
3736     {
3737       const char * const desc
3738           = PL_op_desc[(
3739                           rtype == OP_SUBST || rtype == OP_TRANS
3740                        || rtype == OP_TRANSR
3741                        )
3742                        ? (int)rtype : OP_MATCH];
3743       const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
3744       SV * const name =
3745         S_op_varname(aTHX_ left);
3746       if (name)
3747         Perl_warner(aTHX_ packWARN(WARN_MISC),
3748              "Applying %s to %"SVf" will act on scalar(%"SVf")",
3749              desc, SVfARG(name), SVfARG(name));
3750       else {
3751         const char * const sample = (isary
3752              ? "@array" : "%hash");
3753         Perl_warner(aTHX_ packWARN(WARN_MISC),
3754              "Applying %s to %s will act on scalar(%s)",
3755              desc, sample, sample);
3756       }
3757     }
3758
3759     if (rtype == OP_CONST &&
3760         cSVOPx(right)->op_private & OPpCONST_BARE &&
3761         cSVOPx(right)->op_private & OPpCONST_STRICT)
3762     {
3763         no_bareword_allowed(right);
3764     }
3765
3766     /* !~ doesn't make sense with /r, so error on it for now */
3767     if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
3768         type == OP_NOT)
3769         /* diag_listed_as: Using !~ with %s doesn't make sense */
3770         yyerror("Using !~ with s///r doesn't make sense");
3771     if (rtype == OP_TRANSR && type == OP_NOT)
3772         /* diag_listed_as: Using !~ with %s doesn't make sense */
3773         yyerror("Using !~ with tr///r doesn't make sense");
3774
3775     ismatchop = (rtype == OP_MATCH ||
3776                  rtype == OP_SUBST ||
3777                  rtype == OP_TRANS || rtype == OP_TRANSR)
3778              && !(right->op_flags & OPf_SPECIAL);
3779     if (ismatchop && right->op_private & OPpTARGET_MY) {
3780         right->op_targ = 0;
3781         right->op_private &= ~OPpTARGET_MY;
3782     }
3783     if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
3784         if (left->op_type == OP_PADSV
3785          && !(left->op_private & OPpLVAL_INTRO))
3786         {
3787             right->op_targ = left->op_targ;
3788             op_free(left);
3789             o = right;
3790         }
3791         else {
3792             right->op_flags |= OPf_STACKED;
3793             if (rtype != OP_MATCH && rtype != OP_TRANSR &&
3794             ! (rtype == OP_TRANS &&
3795                right->op_private & OPpTRANS_IDENTICAL) &&
3796             ! (rtype == OP_SUBST &&
3797                (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3798                 left = op_lvalue(left, rtype);
3799             if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
3800                 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
3801             else
3802                 o = op_prepend_elem(rtype, scalar(left), right);
3803         }
3804         if (type == OP_NOT)
3805             return newUNOP(OP_NOT, 0, scalar(o));
3806         return o;
3807     }
3808     else
3809         return bind_match(type, left,
3810                 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
3811 }
3812
3813 OP *
3814 Perl_invert(pTHX_ OP *o)
3815 {
3816     if (!o)
3817         return NULL;
3818     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
3819 }
3820
3821 /*
3822 =for apidoc Amx|OP *|op_scope|OP *o
3823
3824 Wraps up an op tree with some additional ops so that at runtime a dynamic
3825 scope will be created.  The original ops run in the new dynamic scope,
3826 and then, provided that they exit normally, the scope will be unwound.
3827 The additional ops used to create and unwind the dynamic scope will
3828 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
3829 instead if the ops are simple enough to not need the full dynamic scope
3830 structure.
3831
3832 =cut
3833 */
3834
3835 OP *
3836 Perl_op_scope(pTHX_ OP *o)
3837 {
3838     dVAR;
3839     if (o) {
3840         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
3841             o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
3842             OpTYPE_set(o, OP_LEAVE);
3843         }
3844         else if (o->op_type == OP_LINESEQ) {
3845             OP *kid;
3846             OpTYPE_set(o, OP_SCOPE);
3847             kid = ((LISTOP*)o)->op_first;
3848             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
3849                 op_null(kid);
3850
3851                 /* The following deals with things like 'do {1 for 1}' */
3852                 kid = OpSIBLING(kid);
3853                 if (kid &&
3854                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
3855                     op_null(kid);
3856             }
3857         }
3858         else
3859             o = newLISTOP(OP_SCOPE, 0, o, NULL);
3860     }
3861     return o;
3862 }
3863
3864 OP *
3865 Perl_op_unscope(pTHX_ OP *o)
3866 {
3867     if (o && o->op_type == OP_LINESEQ) {
3868         OP *kid = cLISTOPo->op_first;
3869         for(; kid; kid = OpSIBLING(kid))
3870             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
3871                 op_null(kid);
3872     }
3873     return o;
3874 }
3875
3876 /*
3877 =for apidoc Am|int|block_start|int full
3878
3879 Handles compile-time scope entry.
3880 Arranges for hints to be restored on block
3881 exit and also handles pad sequence numbers to make lexical variables scope
3882 right.  Returns a savestack index for use with C<block_end>.
3883
3884 =cut
3885 */
3886
3887 int
3888 Perl_block_start(pTHX_ int full)
3889 {
3890     const int retval = PL_savestack_ix;
3891
3892     PL_compiling.cop_seq = PL_cop_seqmax;
3893     COP_SEQMAX_INC;
3894     pad_block_start(full);
3895     SAVEHINTS();
3896     PL_hints &= ~HINT_BLOCK_SCOPE;
3897     SAVECOMPILEWARNINGS();
3898     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
3899     SAVEI32(PL_compiling.cop_seq);
3900     PL_compiling.cop_seq = 0;
3901
3902     CALL_BLOCK_HOOKS(bhk_start, full);
3903
3904     return retval;
3905 }
3906
3907 /*
3908 =for apidoc Am|OP *|block_end|I32 floor|OP *seq
3909
3910 Handles compile-time scope exit.  I<floor>
3911 is the savestack index returned by
3912 C<block_start>, and I<seq> is the body of the block.  Returns the block,
3913 possibly modified.
3914
3915 =cut
3916 */
3917
3918 OP*
3919 Perl_block_end(pTHX_ I32 floor, OP *seq)
3920 {
3921     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
3922     OP* retval = scalarseq(seq);
3923     OP *o;
3924
3925     /* XXX Is the null PL_parser check necessary here? */
3926     assert(PL_parser); /* Let’s find out under debugging builds.  */
3927     if (PL_parser && PL_parser->parsed_sub) {
3928         o = newSTATEOP(0, NULL, NULL);
3929         op_null(o);
3930         retval = op_append_elem(OP_LINESEQ, retval, o);
3931     }
3932
3933     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
3934
3935     LEAVE_SCOPE(floor);
3936     if (needblockscope)
3937         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
3938     o = pad_leavemy();
3939
3940     if (o) {
3941         /* pad_leavemy has created a sequence of introcv ops for all my
3942            subs declared in the block.  We have to replicate that list with
3943            clonecv ops, to deal with this situation:
3944
3945                sub {
3946                    my sub s1;
3947                    my sub s2;
3948                    sub s1 { state sub foo { \&s2 } }
3949                }->()
3950
3951            Originally, I was going to have introcv clone the CV and turn
3952            off the stale flag.  Since &s1 is declared before &s2, the
3953            introcv op for &s1 is executed (on sub entry) before the one for
3954            &s2.  But the &foo sub inside &s1 (which is cloned when &s1 is
3955            cloned, since it is a state sub) closes over &s2 and expects
3956            to see it in its outer CV’s pad.  If the introcv op clones &s1,
3957            then &s2 is still marked stale.  Since &s1 is not active, and
3958            &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
3959            ble will not stay shared’ warning.  Because it is the same stub
3960            that will be used when the introcv op for &s2 is executed, clos-
3961            ing over it is safe.  Hence, we have to turn off the stale flag
3962            on all lexical subs in the block before we clone any of them.
3963            Hence, having introcv clone the sub cannot work.  So we create a
3964            list of ops like this:
3965
3966                lineseq
3967                   |
3968                   +-- introcv
3969                   |
3970                   +-- introcv
3971                   |
3972                   +-- introcv
3973                   |
3974                   .
3975                   .
3976                   .
3977                   |
3978                   +-- clonecv
3979                   |
3980                   +-- clonecv
3981                   |
3982                   +-- clonecv
3983                   |
3984                   .
3985                   .
3986                   .
3987          */
3988         OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
3989         OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
3990         for (;; kid = OpSIBLING(kid)) {
3991             OP *newkid = newOP(OP_CLONECV, 0);
3992             newkid->op_targ = kid->op_targ;
3993             o = op_append_elem(OP_LINESEQ, o, newkid);
3994             if (kid == last) break;
3995         }
3996         retval = op_prepend_elem(OP_LINESEQ, o, retval);
3997     }
3998
3999     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
4000
4001     return retval;
4002 }
4003
4004 /*
4005 =head1 Compile-time scope hooks
4006
4007 =for apidoc Aox||blockhook_register
4008
4009 Register a set of hooks to be called when the Perl lexical scope changes
4010 at compile time.  See L<perlguts/"Compile-time scope hooks">.
4011
4012 =cut
4013 */
4014
4015 void
4016 Perl_blockhook_register(pTHX_ BHK *hk)
4017 {
4018     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
4019
4020     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
4021 }
4022
4023 void
4024 Perl_newPROG(pTHX_ OP *o)
4025 {
4026     PERL_ARGS_ASSERT_NEWPROG;
4027
4028     if (PL_in_eval) {
4029         PERL_CONTEXT *cx;
4030         I32 i;
4031         if (PL_eval_root)
4032                 return;
4033         PL_eval_root = newUNOP(OP_LEAVEEVAL,
4034                                ((PL_in_eval & EVAL_KEEPERR)
4035                                 ? OPf_SPECIAL : 0), o);
4036
4037         cx = &cxstack[cxstack_ix];
4038         assert(CxTYPE(cx) == CXt_EVAL);
4039
4040         if ((cx->blk_gimme & G_WANT) == G_VOID)
4041             scalarvoid(PL_eval_root);
4042         else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
4043             list(PL_eval_root);
4044         else
4045             scalar(PL_eval_root);
4046
4047         PL_eval_start = op_linklist(PL_eval_root);
4048         PL_eval_root->op_private |= OPpREFCOUNTED;
4049         OpREFCNT_set(PL_eval_root, 1);
4050         PL_eval_root->op_next = 0;
4051         i = PL_savestack_ix;
4052         SAVEFREEOP(o);
4053         ENTER;
4054         CALL_PEEP(PL_eval_start);
4055         finalize_optree(PL_eval_root);
4056         S_prune_chain_head(&PL_eval_start);
4057         LEAVE;
4058         PL_savestack_ix = i;
4059     }
4060     else {
4061         if (o->op_type == OP_STUB) {
4062             /* This block is entered if nothing is compiled for the main
4063                program. This will be the case for an genuinely empty main
4064                program, or one which only has BEGIN blocks etc, so already
4065                run and freed.
4066
4067                Historically (5.000) the guard above was !o. However, commit
4068                f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
4069                c71fccf11fde0068, changed perly.y so that newPROG() is now
4070                called with the output of block_end(), which returns a new
4071                OP_STUB for the case of an empty optree. ByteLoader (and
4072                maybe other things) also take this path, because they set up
4073                PL_main_start and PL_main_root directly, without generating an
4074                optree.
4075
4076                If the parsing the main program aborts (due to parse errors,
4077                or due to BEGIN or similar calling exit), then newPROG()
4078                isn't even called, and hence this code path and its cleanups
4079                are skipped. This shouldn't make a make a difference:
4080                * a non-zero return from perl_parse is a failure, and
4081                  perl_destruct() should be called immediately.
4082                * however, if exit(0) is called during the parse, then
4083                  perl_parse() returns 0, and perl_run() is called. As
4084                  PL_main_start will be NULL, perl_run() will return
4085                  promptly, and the exit code will remain 0.
4086             */
4087
4088             PL_comppad_name = 0;
4089             PL_compcv = 0;
4090             S_op_destroy(aTHX_ o);
4091             return;
4092         }
4093         PL_main_root = op_scope(sawparens(scalarvoid(o)));
4094         PL_curcop = &PL_compiling;
4095         PL_main_start = LINKLIST(PL_main_root);
4096         PL_main_root->op_private |= OPpREFCOUNTED;
4097         OpREFCNT_set(PL_main_root, 1);
4098         PL_main_root->op_next = 0;
4099         CALL_PEEP(PL_main_start);
4100         finalize_optree(PL_main_root);
4101         S_prune_chain_head(&PL_main_start);
4102         cv_forget_slab(PL_compcv);
4103         PL_compcv = 0;
4104
4105         /* Register with debugger */
4106         if (PERLDB_INTER) {
4107             CV * const cv = get_cvs("DB::postponed", 0);
4108             if (cv) {
4109                 dSP;
4110                 PUSHMARK(SP);
4111                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
4112                 PUTBACK;
4113                 call_sv(MUTABLE_SV(cv), G_DISCARD);
4114             }
4115         }
4116     }
4117 }
4118
4119 OP *
4120 Perl_localize(pTHX_ OP *o, I32 lex)
4121 {
4122     PERL_ARGS_ASSERT_LOCALIZE;
4123
4124     if (o->op_flags & OPf_PARENS)
4125 /* [perl #17376]: this appears to be premature, and results in code such as
4126    C< our(%x); > executing in list mode rather than void mode */
4127 #if 0
4128         list(o);
4129 #else
4130         NOOP;
4131 #endif
4132     else {
4133         if ( PL_parser->bufptr > PL_parser->oldbufptr
4134             && PL_parser->bufptr[-1] == ','
4135             && ckWARN(WARN_PARENTHESIS))
4136         {
4137             char *s = PL_parser->bufptr;
4138             bool sigil = FALSE;
4139
4140             /* some heuristics to detect a potential error */
4141             while (*s && (strchr(", \t\n", *s)))
4142                 s++;
4143
4144             while (1) {
4145                 if (*s && strchr("@$%*", *s) && *++s
4146                        && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
4147                     s++;
4148                     sigil = TRUE;
4149                     while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
4150                         s++;
4151                     while (*s && (strchr(", \t\n", *s)))
4152                         s++;
4153                 }
4154                 else
4155                     break;
4156             }
4157             if (sigil && (*s == ';' || *s == '=')) {
4158                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
4159                                 "Parentheses missing around \"%s\" list",
4160                                 lex
4161                                     ? (PL_parser->in_my == KEY_our
4162                                         ? "our"
4163                                         : PL_parser->in_my == KEY_state
4164                                             ? "state"
4165                                             : "my")
4166                                     : "local");
4167             }
4168         }
4169     }
4170     if (lex)
4171         o = my(o);
4172     else
4173         o = op_lvalue(o, OP_NULL);              /* a bit kludgey */
4174     PL_parser->in_my = FALSE;
4175     PL_parser->in_my_stash = NULL;
4176     return o;
4177 }
4178
4179 OP *
4180 Perl_jmaybe(pTHX_ OP *o)
4181 {
4182     PERL_ARGS_ASSERT_JMAYBE;
4183
4184     if (o->op_type == OP_LIST) {
4185         OP * const o2
4186             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
4187         o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
4188     }
4189     return o;
4190 }
4191
4192 PERL_STATIC_INLINE OP *
4193 S_op_std_init(pTHX_ OP *o)
4194 {
4195     I32 type = o->op_type;
4196
4197     PERL_ARGS_ASSERT_OP_STD_INIT;
4198
4199     if (PL_opargs[type] & OA_RETSCALAR)
4200         scalar(o);
4201     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
4202         o->op_targ = pad_alloc(type, SVs_PADTMP);
4203
4204     return o;
4205 }
4206
4207 PERL_STATIC_INLINE OP *
4208 S_op_integerize(pTHX_ OP *o)
4209 {
4210     I32 type = o->op_type;
4211
4212     PERL_ARGS_ASSERT_OP_INTEGERIZE;
4213
4214     /* integerize op. */
4215     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
4216     {
4217         dVAR;
4218         o->op_ppaddr = PL_ppaddr[++(o->op_type)];
4219     }
4220
4221     if (type == OP_NEGATE)
4222         /* XXX might want a ck_negate() for this */
4223         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
4224
4225     return o;
4226 }
4227
4228 static OP *
4229 S_fold_constants(pTHX_ OP *o)
4230 {
4231     dVAR;
4232     OP * VOL curop;
4233     OP *newop;
4234     VOL I32 type = o->op_type;
4235     bool is_stringify;
4236     SV * VOL sv = NULL;
4237     int ret = 0;
4238     I32 oldscope;
4239     OP *old_next;
4240     SV * const oldwarnhook = PL_warnhook;
4241     SV * const olddiehook  = PL_diehook;
4242     COP not_compiling;
4243     U8 oldwarn = PL_dowarn;
4244     dJMPENV;
4245
4246     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
4247
4248     if (!(PL_opargs[type] & OA_FOLDCONST))
4249         goto nope;
4250
4251     switch (type) {
4252     case OP_UCFIRST:
4253     case OP_LCFIRST:
4254     case OP_UC:
4255     case OP_LC:
4256     case OP_FC:
4257 #ifdef USE_LOCALE_CTYPE
4258         if (IN_LC_COMPILETIME(LC_CTYPE))
4259             goto nope;
4260 #endif
4261         break;
4262     case OP_SLT:
4263     case OP_SGT:
4264     case OP_SLE:
4265     case OP_SGE:
4266     case OP_SCMP:
4267 #ifdef USE_LOCALE_COLLATE
4268         if (IN_LC_COMPILETIME(LC_COLLATE))
4269             goto nope;
4270 #endif
4271         break;
4272     case OP_SPRINTF:
4273         /* XXX what about the numeric ops? */
4274 #ifdef USE_LOCALE_NUMERIC
4275         if (IN_LC_COMPILETIME(LC_NUMERIC))
4276             goto nope;
4277 #endif
4278         break;
4279     case OP_PACK:
4280         if (!OpHAS_SIBLING(cLISTOPo->op_first)
4281           || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
4282             goto nope;
4283         {
4284             SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
4285             if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
4286             {
4287                 const char *s = SvPVX_const(sv);
4288                 while (s < SvEND(sv)) {
4289                     if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
4290                     s++;
4291                 }
4292             }
4293         }
4294         break;
4295     case OP_REPEAT:
4296         if (o->op_private & OPpREPEAT_DOLIST) goto nope;
4297         break;
4298     case OP_SREFGEN:
4299         if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
4300          || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
4301             goto nope;
4302     }
4303
4304     if (PL_parser && PL_parser->error_count)
4305         goto nope;              /* Don't try to run w/ errors */
4306
4307     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4308         const OPCODE type = curop->op_type;
4309         if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
4310             type != OP_LIST &&
4311             type != OP_SCALAR &&
4312             type != OP_NULL &&
4313             type != OP_PUSHMARK)
4314         {
4315             goto nope;
4316         }
4317     }
4318
4319     curop = LINKLIST(o);
4320     old_next = o->op_next;
4321     o->op_next = 0;
4322     PL_op = curop;
4323
4324     oldscope = PL_scopestack_ix;
4325     create_eval_scope(G_FAKINGEVAL);
4326
4327     /* Verify that we don't need to save it:  */
4328     assert(PL_curcop == &PL_compiling);
4329     StructCopy(&PL_compiling, &not_compiling, COP);
4330     PL_curcop = &not_compiling;
4331     /* The above ensures that we run with all the correct hints of the
4332        currently compiling COP, but that IN_PERL_RUNTIME is true. */
4333     assert(IN_PERL_RUNTIME);
4334     PL_warnhook = PERL_WARNHOOK_FATAL;
4335     PL_diehook  = NULL;
4336     JMPENV_PUSH(ret);
4337
4338     /* Effective $^W=1.  */
4339     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
4340         PL_dowarn |= G_WARN_ON;
4341
4342     switch (ret) {
4343     case 0:
4344         CALLRUNOPS(aTHX);
4345         sv = *(PL_stack_sp--);
4346         if (o->op_targ && sv == PAD_SV(o->op_targ)) {   /* grab pad temp? */
4347             pad_swipe(o->op_targ,  FALSE);
4348         }
4349         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
4350             SvREFCNT_inc_simple_void(sv);
4351             SvTEMP_off(sv);
4352         }
4353         else { assert(SvIMMORTAL(sv)); }
4354         break;
4355     case 3:
4356         /* Something tried to die.  Abandon constant folding.  */
4357         /* Pretend the error never happened.  */
4358         CLEAR_ERRSV();
4359         o->op_next = old_next;
4360         break;
4361     default:
4362         JMPENV_POP;
4363         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
4364         PL_warnhook = oldwarnhook;
4365         PL_diehook  = olddiehook;
4366         /* XXX note that this croak may fail as we've already blown away
4367          * the stack - eg any nested evals */
4368         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
4369     }
4370     JMPENV_POP;
4371     PL_dowarn   = oldwarn;
4372     PL_warnhook = oldwarnhook;
4373     PL_diehook  = olddiehook;
4374     PL_curcop = &PL_compiling;
4375
4376     if (PL_scopestack_ix > oldscope)
4377         delete_eval_scope();
4378
4379     if (ret)
4380         goto nope;
4381
4382     /* OP_STRINGIFY and constant folding are used to implement qq.
4383        Here the constant folding is an implementation detail that we
4384        want to hide.  If the stringify op is itself already marked
4385        folded, however, then it is actually a folded join.  */
4386     is_stringify = type == OP_STRINGIFY && !o->op_folded;
4387     op_free(o);
4388     assert(sv);
4389     if (is_stringify)
4390         SvPADTMP_off(sv);
4391     else if (!SvIMMORTAL(sv)) {
4392         SvPADTMP_on(sv);
4393         SvREADONLY_on(sv);
4394     }
4395     newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
4396     if (!is_stringify) newop->op_folded = 1;
4397     return newop;
4398
4399  nope:
4400     return o;
4401 }
4402
4403 static OP *
4404 S_gen_constant_list(pTHX_ OP *o)
4405 {
4406     dVAR;
4407     OP *curop;
4408     const SSize_t oldtmps_floor = PL_tmps_floor;
4409     SV **svp;
4410     AV *av;
4411
4412     list(o);
4413     if (PL_parser && PL_parser->error_count)
4414         return o;               /* Don't attempt to run with errors */
4415
4416     curop = LINKLIST(o);
4417     o->op_next = 0;
4418     CALL_PEEP(curop);
4419     S_prune_chain_head(&curop);
4420     PL_op = curop;
4421     Perl_pp_pushmark(aTHX);
4422     CALLRUNOPS(aTHX);
4423     PL_op = curop;
4424     assert (!(curop->op_flags & OPf_SPECIAL));
4425     assert(curop->op_type == OP_RANGE);
4426     Perl_pp_anonlist(aTHX);
4427     PL_tmps_floor = oldtmps_floor;
4428
4429     OpTYPE_set(o, OP_RV2AV);
4430     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
4431     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
4432     o->op_opt = 0;              /* needs to be revisited in rpeep() */
4433     av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
4434
4435     /* replace subtree with an OP_CONST */
4436     curop = ((UNOP*)o)->op_first;
4437     op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
4438     op_free(curop);
4439
4440     if (AvFILLp(av) != -1)
4441         for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
4442         {
4443             SvPADTMP_on(*svp);
4444             SvREADONLY_on(*svp);
4445         }
4446     LINKLIST(o);
4447     return list(o);
4448 }
4449
4450 /*
4451 =head1 Optree Manipulation Functions
4452 */
4453
4454 /* List constructors */
4455
4456 /*
4457 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
4458
4459 Append an item to the list of ops contained directly within a list-type
4460 op, returning the lengthened list.  I<first> is the list-type op,
4461 and I<last> is the op to append to the list.  I<optype> specifies the
4462 intended opcode for the list.  If I<first> is not already a list of the
4463 right type, it will be upgraded into one.  If either I<first> or I<last>
4464 is null, the other is returned unchanged.
4465
4466 =cut
4467 */
4468
4469 OP *
4470 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
4471 {
4472     if (!first)
4473         return last;
4474
4475     if (!last)
4476         return first;
4477
4478     if (first->op_type != (unsigned)type
4479         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
4480     {
4481         return newLISTOP(type, 0, first, last);
4482     }
4483
4484     op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
4485     first->op_flags |= OPf_KIDS;
4486     return first;
4487 }
4488
4489 /*
4490 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
4491
4492 Concatenate the lists of ops contained directly within two list-type ops,
4493 returning the combined list.  I<first> and I<last> are the list-type ops
4494 to concatenate.  I<optype> specifies the intended opcode for the list.
4495 If either I<first> or I<last> is not already a list of the right type,
4496 it will be upgraded into one.  If either I<first> or I<last> is null,
4497 the other is returned unchanged.
4498
4499 =cut
4500 */
4501
4502 OP *
4503 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
4504 {
4505     if (!first)
4506         return last;
4507
4508     if (!last)
4509         return first;
4510
4511     if (first->op_type != (unsigned)type)
4512         return op_prepend_elem(type, first, last);
4513
4514     if (last->op_type != (unsigned)type)
4515         return op_append_elem(type, first, last);
4516
4517     OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
4518     ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
4519     OpLASTSIB_set(((LISTOP*)first)->op_last, first);
4520     first->op_flags |= (last->op_flags & OPf_KIDS);
4521
4522     S_op_destroy(aTHX_ last);
4523
4524     return first;
4525 }
4526
4527 /*
4528 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
4529
4530 Prepend an item to the list of ops contained directly within a list-type
4531 op, returning the lengthened list.  I<first> is the op to prepend to the
4532 list, and I<last> is the list-type op.  I<optype> specifies the intended
4533 opcode for the list.  If I<last> is not already a list of the right type,
4534 it will be upgraded into one.  If either I<first> or I<last> is null,
4535 the other is returned unchanged.
4536
4537 =cut
4538 */
4539
4540 OP *
4541 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
4542 {
4543     if (!first)
4544         return last;
4545
4546     if (!last)
4547         return first;
4548
4549     if (last->op_type == (unsigned)type) {
4550         if (type == OP_LIST) {  /* already a PUSHMARK there */
4551             /* insert 'first' after pushmark */
4552             op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
4553             if (!(first->op_flags & OPf_PARENS))
4554                 last->op_flags &= ~OPf_PARENS;
4555         }
4556         else
4557             op_sibling_splice(last, NULL, 0, first);
4558         last->op_flags |= OPf_KIDS;
4559         return last;
4560     }
4561
4562     return newLISTOP(type, 0, first, last);
4563 }
4564
4565 /*
4566 =for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
4567
4568 Converts I<o> into a list op if it is not one already, and then converts it
4569 into the specified I<type>, calling its check function, allocating a target if
4570 it needs one, and folding constants.
4571
4572 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
4573 C<op_prepend_elem> and C<op_append_elem>.  Then finally it is passed to
4574 C<op_convert_list> to make it the right type.
4575
4576 =cut
4577 */
4578
4579 OP *
4580 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
4581 {
4582     dVAR;
4583     if (type < 0) type = -type, flags |= OPf_SPECIAL;
4584     if (!o || o->op_type != OP_LIST)
4585         o = force_list(o, 0);
4586     else
4587     {
4588         o->op_flags &= ~OPf_WANT;
4589         o->op_private &= ~OPpLVAL_INTRO;
4590     }
4591
4592     if (!(PL_opargs[type] & OA_MARK))
4593         op_null(cLISTOPo->op_first);
4594     else {
4595         OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
4596         if (kid2 && kid2->op_type == OP_COREARGS) {
4597             op_null(cLISTOPo->op_first);
4598             kid2->op_private |= OPpCOREARGS_PUSHMARK;
4599         }
4600     }
4601
4602     OpTYPE_set(o, type);
4603     o->op_flags |= flags;
4604     if (flags & OPf_FOLDED)
4605         o->op_folded = 1;
4606
4607     o = CHECKOP(type, o);
4608     if (o->op_type != (unsigned)type)
4609         return o;
4610
4611     return fold_constants(op_integerize(op_std_init(o)));
4612 }
4613
4614 /* Constructors */
4615
4616
4617 /*
4618 =head1 Optree construction
4619
4620 =for apidoc Am|OP *|newNULLLIST
4621
4622 Constructs, checks, and returns a new C<stub> op, which represents an
4623 empty list expression.
4624
4625 =cut
4626 */
4627
4628 OP *
4629 Perl_newNULLLIST(pTHX)
4630 {
4631     return newOP(OP_STUB, 0);
4632 }
4633
4634 /* promote o and any siblings to be a list if its not already; i.e.
4635  *
4636  *  o - A - B
4637  *
4638  * becomes
4639  *
4640  *  list
4641  *    |
4642  *  pushmark - o - A - B
4643  *
4644  * If nullit it true, the list op is nulled.
4645  */
4646
4647 static OP *
4648 S_force_list(pTHX_ OP *o, bool nullit)
4649 {
4650     if (!o || o->op_type != OP_LIST) {
4651         OP *rest = NULL;
4652         if (o) {
4653             /* manually detach any siblings then add them back later */
4654             rest = OpSIBLING(o);
4655             OpLASTSIB_set(o, NULL);
4656         }
4657         o = newLISTOP(OP_LIST, 0, o, NULL);
4658         if (rest)
4659             op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
4660     }
4661     if (nullit)
4662         op_null(o);
4663     return o;
4664 }
4665
4666 /*
4667 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
4668
4669 Constructs, checks, and returns an op of any list type.  I<type> is
4670 the opcode.  I<flags> gives the eight bits of C<op_flags>, except that
4671 C<OPf_KIDS> will be set automatically if required.  I<first> and I<last>
4672 supply up to two ops to be direct children of the list op; they are
4673 consumed by this function and become part of the constructed op tree.
4674
4675 For most list operators, the check function expects all the kid ops to be
4676 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
4677 appropriate.  What you want to do in that case is create an op of type
4678 OP_LIST, append more children to it, and then call L</op_convert_list>.
4679 See L</op_convert_list> for more information.
4680
4681
4682 =cut
4683 */
4684
4685 OP *
4686 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4687 {
4688     dVAR;
4689     LISTOP *listop;
4690
4691     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
4692         || type == OP_CUSTOM);
4693
4694     NewOp(1101, listop, 1, LISTOP);
4695
4696     OpTYPE_set(listop, type);
4697     if (first || last)
4698         flags |= OPf_KIDS;
4699     listop->op_flags = (U8)flags;
4700
4701     if (!last && first)
4702         last = first;
4703     else if (!first && last)
4704         first = last;
4705     else if (first)
4706         OpMORESIB_set(first, last);
4707     listop->op_first = first;
4708     listop->op_last = last;
4709     if (type == OP_LIST) {
4710         OP* const pushop = newOP(OP_PUSHMARK, 0);
4711         OpMORESIB_set(pushop, first);
4712         listop->op_first = pushop;
4713         listop->op_flags |= OPf_KIDS;
4714         if (!last)
4715             listop->op_last = pushop;
4716     }
4717     if (listop->op_last)
4718         OpLASTSIB_set(listop->op_last, (OP*)listop);
4719
4720     return CHECKOP(type, listop);
4721 }
4722
4723 /*
4724 =for apidoc Am|OP *|newOP|I32 type|I32 flags
4725
4726 Constructs, checks, and returns an op of any base type (any type that
4727 has no extra fields).  I<type> is the opcode.  I<flags> gives the
4728 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
4729 of C<op_private>.
4730
4731 =cut
4732 */
4733
4734 OP *
4735 Perl_newOP(pTHX_ I32 type, I32 flags)
4736 {
4737     dVAR;
4738     OP *o;
4739
4740     if (type == -OP_ENTEREVAL) {
4741         type = OP_ENTEREVAL;
4742         flags |= OPpEVAL_BYTES<<8;
4743     }
4744
4745     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
4746         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4747         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4748         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4749
4750     NewOp(1101, o, 1, OP);
4751     OpTYPE_set(o, type);
4752     o->op_flags = (U8)flags;
4753
4754     o->op_next = o;
4755     o->op_private = (U8)(0 | (flags >> 8));
4756     if (PL_opargs[type] & OA_RETSCALAR)
4757         scalar(o);
4758     if (PL_opargs[type] & OA_TARGET)
4759         o->op_targ = pad_alloc(type, SVs_PADTMP);
4760     return CHECKOP(type, o);
4761 }
4762
4763 /*
4764 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
4765
4766 Constructs, checks, and returns an op of any unary type.  I<type> is
4767 the opcode.  I<flags> gives the eight bits of C<op_flags>, except that
4768 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
4769 bits, the eight bits of C<op_private>, except that the bit with value 1
4770 is automatically set.  I<first> supplies an optional op to be the direct
4771 child of the unary op; it is consumed by this function and become part
4772 of the constructed op tree.
4773
4774 =cut
4775 */
4776
4777 OP *
4778 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
4779 {
4780     dVAR;
4781     UNOP *unop;
4782
4783     if (type == -OP_ENTEREVAL) {
4784         type = OP_ENTEREVAL;
4785         flags |= OPpEVAL_BYTES<<8;
4786     }
4787
4788     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
4789         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4790         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4791         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
4792         || type == OP_SASSIGN
4793         || type == OP_ENTERTRY
4794         || type == OP_CUSTOM
4795         || type == OP_NULL );
4796
4797     if (!first)
4798         first = newOP(OP_STUB, 0);
4799     if (PL_opargs[type] & OA_MARK)
4800         first = force_list(first, 1);
4801
4802     NewOp(1101, unop, 1, UNOP);
4803     OpTYPE_set(unop, type);
4804     unop->op_first = first;
4805     unop->op_flags = (U8)(flags | OPf_KIDS);
4806     unop->op_private = (U8)(1 | (flags >> 8));
4807
4808     if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
4809         OpLASTSIB_set(first, (OP*)unop);
4810
4811     unop = (UNOP*) CHECKOP(type, unop);
4812     if (unop->op_next)
4813         return (OP*)unop;
4814
4815     return fold_constants(op_integerize(op_std_init((OP *) unop)));
4816 }
4817
4818 /*
4819 =for apidoc newUNOP_AUX
4820
4821 Similar to C<newUNOP>, but creates an UNOP_AUX struct instead, with op_aux
4822 initialised to aux
4823
4824 =cut
4825 */
4826
4827 OP *
4828 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
4829 {
4830     dVAR;
4831     UNOP_AUX *unop;
4832
4833     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
4834         || type == OP_CUSTOM);
4835
4836     NewOp(1101, unop, 1, UNOP_AUX);
4837     unop->op_type = (OPCODE)type;
4838     unop->op_ppaddr = PL_ppaddr[type];
4839     unop->op_first = first;
4840     unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
4841     unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
4842     unop->op_aux = aux;
4843
4844     if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
4845         OpLASTSIB_set(first, (OP*)unop);
4846
4847     unop = (UNOP_AUX*) CHECKOP(type, unop);
4848
4849     return op_std_init((OP *) unop);
4850 }
4851
4852 /*
4853 =for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
4854
4855 Constructs, checks, and returns an op of method type with a method name
4856 evaluated at runtime.  I<type> is the opcode.  I<flags> gives the eight
4857 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
4858 and, shifted up eight bits, the eight bits of C<op_private>, except that
4859 the bit with value 1 is automatically set.  I<dynamic_meth> supplies an
4860 op which evaluates method name; it is consumed by this function and
4861 become part of the constructed op tree.
4862 Supported optypes: OP_METHOD.
4863
4864 =cut
4865 */
4866
4867 static OP*
4868 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
4869     dVAR;
4870     METHOP *methop;
4871
4872     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
4873         || type == OP_CUSTOM);
4874
4875     NewOp(1101, methop, 1, METHOP);
4876     if (dynamic_meth) {
4877         if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
4878         methop->op_flags = (U8)(flags | OPf_KIDS);
4879         methop->op_u.op_first = dynamic_meth;
4880         methop->op_private = (U8)(1 | (flags >> 8));
4881
4882         if (!OpHAS_SIBLING(dynamic_meth))
4883             OpLASTSIB_set(dynamic_meth, (OP*)methop);
4884     }
4885     else {
4886         assert(const_meth);
4887         methop->op_flags = (U8)(flags & ~OPf_KIDS);
4888         methop->op_u.op_meth_sv = const_meth;
4889         methop->op_private = (U8)(0 | (flags >> 8));
4890         methop->op_next = (OP*)methop;
4891     }
4892
4893 #ifdef USE_ITHREADS
4894     methop->op_rclass_targ = 0;
4895 #else
4896     methop->op_rclass_sv = NULL;
4897 #endif
4898
4899     OpTYPE_set(methop, type);
4900     return CHECKOP(type, methop);
4901 }
4902
4903 OP *
4904 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
4905     PERL_ARGS_ASSERT_NEWMETHOP;
4906     return newMETHOP_internal(type, flags, dynamic_meth, NULL);
4907 }
4908
4909 /*
4910 =for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
4911
4912 Constructs, checks, and returns an op of method type with a constant
4913 method name.  I<type> is the opcode.  I<flags> gives the eight bits of
4914 C<op_flags>, and, shifted up eight bits, the eight bits of
4915 C<op_private>.  I<const_meth> supplies a constant method name;
4916 it must be a shared COW string.
4917 Supported optypes: OP_METHOD_NAMED.
4918
4919 =cut
4920 */
4921
4922 OP *
4923 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
4924     PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
4925     return newMETHOP_internal(type, flags, NULL, const_meth);
4926 }
4927
4928 /*
4929 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
4930
4931 Constructs, checks, and returns an op of any binary type.  I<type>
4932 is the opcode.  I<flags> gives the eight bits of C<op_flags>, except
4933 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4934 the eight bits of C<op_private>, except that the bit with value 1 or
4935 2 is automatically set as required.  I<first> and I<last> supply up to
4936 two ops to be the direct children of the binary op; they are consumed
4937 by this function and become part of the constructed op tree.
4938
4939 =cut
4940 */
4941
4942 OP *
4943 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4944 {
4945     dVAR;
4946     BINOP *binop;
4947
4948     ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
4949         || type == OP_SASSIGN || type == OP_NULL || type == OP_CUSTOM);
4950
4951     NewOp(1101, binop, 1, BINOP);
4952
4953     if (!first)
4954         first = newOP(OP_NULL, 0);
4955
4956     OpTYPE_set(binop, type);
4957     binop->op_first = first;
4958     binop->op_flags = (U8)(flags | OPf_KIDS);
4959     if (!last) {
4960         last = first;
4961         binop->op_private = (U8)(1 | (flags >> 8));
4962     }
4963     else {
4964         binop->op_private = (U8)(2 | (flags >> 8));
4965         OpMORESIB_set(first, last);
4966     }
4967
4968     if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
4969         OpLASTSIB_set(last, (OP*)binop);
4970
4971     binop->op_last = OpSIBLING(binop->op_first);
4972     if (binop->op_last)
4973         OpLASTSIB_set(binop->op_last, (OP*)binop);
4974
4975     binop = (BINOP*)CHECKOP(type, binop);
4976     if (binop->op_next || binop->op_type != (OPCODE)type)
4977         return (OP*)binop;
4978
4979     return fold_constants(op_integerize(op_std_init((OP *)binop)));
4980 }
4981
4982 static int uvcompare(const void *a, const void *b)
4983     __attribute__nonnull__(1)
4984     __attribute__nonnull__(2)
4985     __attribute__pure__;
4986 static int uvcompare(const void *a, const void *b)
4987 {
4988     if (*((const UV *)a) < (*(const UV *)b))
4989         return -1;
4990     if (*((const UV *)a) > (*(const UV *)b))
4991         return 1;
4992     if (*((const UV *)a+1) < (*(const UV *)b+1))
4993         return -1;
4994     if (*((const UV *)a+1) > (*(const UV *)b+1))
4995         return 1;
4996     return 0;
4997 }
4998
4999 static OP *
5000 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
5001 {
5002     SV * const tstr = ((SVOP*)expr)->op_sv;
5003     SV * const rstr =
5004                               ((SVOP*)repl)->op_sv;
5005     STRLEN tlen;
5006     STRLEN rlen;
5007     const U8 *t = (U8*)SvPV_const(tstr, tlen);
5008     const U8 *r = (U8*)SvPV_const(rstr, rlen);
5009     I32 i;
5010     I32 j;
5011     I32 grows = 0;
5012     short *tbl;
5013
5014     const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
5015     const I32 squash     = o->op_private & OPpTRANS_SQUASH;
5016     I32 del              = o->op_private & OPpTRANS_DELETE;
5017     SV* swash;
5018
5019     PERL_ARGS_ASSERT_PMTRANS;
5020
5021     PL_hints |= HINT_BLOCK_SCOPE;
5022
5023     if (SvUTF8(tstr))
5024         o->op_private |= OPpTRANS_FROM_UTF;
5025
5026     if (SvUTF8(rstr))
5027         o->op_private |= OPpTRANS_TO_UTF;
5028
5029     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
5030         SV* const listsv = newSVpvs("# comment\n");
5031         SV* transv = NULL;
5032         const U8* tend = t + tlen;
5033         const U8* rend = r + rlen;
5034         STRLEN ulen;
5035         UV tfirst = 1;
5036         UV tlast = 0;
5037         IV tdiff;
5038         STRLEN tcount = 0;
5039         UV rfirst = 1;
5040         UV rlast = 0;
5041         IV rdiff;
5042         STRLEN rcount = 0;
5043         IV diff;
5044         I32 none = 0;
5045         U32 max = 0;
5046         I32 bits;
5047         I32 havefinal = 0;
5048         U32 final = 0;
5049         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
5050         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
5051         U8* tsave = NULL;
5052         U8* rsave = NULL;
5053         const U32 flags = UTF8_ALLOW_DEFAULT;
5054
5055         if (!from_utf) {
5056             STRLEN len = tlen;
5057             t = tsave = bytes_to_utf8(t, &len);
5058             tend = t + len;
5059         }
5060         if (!to_utf && rlen) {
5061             STRLEN len = rlen;
5062             r = rsave = bytes_to_utf8(r, &len);
5063             rend = r + len;
5064         }
5065
5066 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
5067  * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
5068  * odd.  */
5069
5070         if (complement) {
5071             U8 tmpbuf[UTF8_MAXBYTES+1];
5072             UV *cp;
5073             UV nextmin = 0;
5074             Newx(cp, 2*tlen, UV);
5075             i = 0;
5076             transv = newSVpvs("");
5077             while (t < tend) {
5078                 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
5079                 t += ulen;
5080                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
5081                     t++;
5082                     cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
5083                     t += ulen;
5084                 }
5085                 else {
5086                  cp[2*i+1] = cp[2*i];
5087                 }
5088                 i++;
5089             }
5090             qsort(cp, i, 2*sizeof(UV), uvcompare);
5091             for (j = 0; j < i; j++) {
5092                 UV  val = cp[2*j];
5093                 diff = val - nextmin;
5094                 if (diff > 0) {
5095                     t = uvchr_to_utf8(tmpbuf,nextmin);
5096                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5097                     if (diff > 1) {
5098                         U8  range_mark = ILLEGAL_UTF8_BYTE;
5099                         t = uvchr_to_utf8(tmpbuf, val - 1);
5100                         sv_catpvn(transv, (char *)&range_mark, 1);
5101                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5102                     }
5103                 }
5104                 val = cp[2*j+1];
5105                 if (val >= nextmin)
5106                     nextmin = val + 1;
5107             }
5108             t = uvchr_to_utf8(tmpbuf,nextmin);
5109             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5110             {
5111                 U8 range_mark = ILLEGAL_UTF8_BYTE;
5112                 sv_catpvn(transv, (char *)&range_mark, 1);
5113             }
5114             t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
5115             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5116             t = (const U8*)SvPVX_const(transv);
5117             tlen = SvCUR(transv);
5118             tend = t + tlen;
5119             Safefree(cp);
5120         }
5121         else if (!rlen && !del) {
5122             r = t; rlen = tlen; rend = tend;
5123         }
5124         if (!squash) {
5125                 if ((!rlen && !del) || t == r ||
5126                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
5127                 {
5128                     o->op_private |= OPpTRANS_IDENTICAL;
5129                 }
5130         }
5131
5132         while (t < tend || tfirst <= tlast) {
5133             /* see if we need more "t" chars */
5134             if (tfirst > tlast) {
5135                 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
5136                 t += ulen;
5137                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {      /* illegal utf8 val indicates range */
5138                     t++;
5139                     tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
5140                     t += ulen;
5141                 }
5142                 else
5143                     tlast = tfirst;
5144             }
5145
5146             /* now see if we need more "r" chars */
5147             if (rfirst > rlast) {
5148                 if (r < rend) {
5149                     rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
5150                     r += ulen;
5151                     if (r < rend && *r == ILLEGAL_UTF8_BYTE) {  /* illegal utf8 val indicates range */
5152                         r++;
5153                         rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
5154                         r += ulen;
5155                     }
5156                     else
5157                         rlast = rfirst;
5158                 }
5159                 else {
5160                     if (!havefinal++)
5161                         final = rlast;
5162                     rfirst = rlast = 0xffffffff;
5163                 }
5164             }
5165
5166             /* now see which range will peter our first, if either. */
5167             tdiff = tlast - tfirst;
5168             rdiff = rlast - rfirst;
5169             tcount += tdiff + 1;
5170             rcount += rdiff + 1;
5171
5172             if (tdiff <= rdiff)
5173                 diff = tdiff;
5174             else
5175                 diff = rdiff;
5176
5177             if (rfirst == 0xffffffff) {
5178                 diff = tdiff;   /* oops, pretend rdiff is infinite */
5179                 if (diff > 0)
5180                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
5181                                    (long)tfirst, (long)tlast);
5182                 else
5183                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
5184             }
5185             else {
5186                 if (diff > 0)
5187                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
5188                                    (long)tfirst, (long)(tfirst + diff),
5189                                    (long)rfirst);
5190                 else
5191                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
5192                                    (long)tfirst, (long)rfirst);
5193
5194                 if (rfirst + diff > max)
5195                     max = rfirst + diff;
5196                 if (!grows)
5197                     grows = (tfirst < rfirst &&
5198                              UNISKIP(tfirst) < UNISKIP(rfirst + diff));
5199                 rfirst += diff + 1;
5200             }
5201             tfirst += diff + 1;
5202         }
5203
5204         none = ++max;
5205         if (del)
5206             del = ++max;
5207
5208         if (max > 0xffff)
5209             bits = 32;
5210         else if (max > 0xff)
5211             bits = 16;
5212         else
5213             bits = 8;
5214
5215         swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
5216 #ifdef USE_ITHREADS
5217         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
5218         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
5219         PAD_SETSV(cPADOPo->op_padix, swash);
5220         SvPADTMP_on(swash);
5221         SvREADONLY_on(swash);
5222 #else
5223         cSVOPo->op_sv = swash;
5224 #endif
5225         SvREFCNT_dec(listsv);
5226         SvREFCNT_dec(transv);
5227
5228         if (!del && havefinal && rlen)
5229             (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
5230                            newSVuv((UV)final), 0);
5231
5232         Safefree(tsave);
5233         Safefree(rsave);
5234
5235         tlen = tcount;
5236         rlen = rcount;
5237         if (r < rend)
5238             rlen++;
5239         else if (rlast == 0xffffffff)
5240             rlen = 0;
5241
5242         goto warnins;
5243     }
5244
5245     tbl = (short*)PerlMemShared_calloc(
5246         (o->op_private & OPpTRANS_COMPLEMENT) &&
5247             !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
5248         sizeof(short));
5249     cPVOPo->op_pv = (char*)tbl;
5250     if (complement) {
5251         for (i = 0; i < (I32)tlen; i++)
5252             tbl[t[i]] = -1;
5253         for (i = 0, j = 0; i < 256; i++) {
5254             if (!tbl[i]) {
5255                 if (j >= (I32)rlen) {
5256                     if (del)
5257                         tbl[i] = -2;
5258                     else if (rlen)
5259                         tbl[i] = r[j-1];
5260                     else
5261                         tbl[i] = (short)i;
5262                 }
5263                 else {
5264                     if (i < 128 && r[j] >= 128)
5265                         grows = 1;
5266                     tbl[i] = r[j++];
5267                 }
5268             }
5269         }
5270         if (!del) {
5271             if (!rlen) {
5272                 j = rlen;
5273                 if (!squash)
5274                     o->op_private |= OPpTRANS_IDENTICAL;
5275             }
5276             else if (j >= (I32)rlen)
5277                 j = rlen - 1;
5278             else {
5279                 tbl =
5280                     (short *)
5281                     PerlMemShared_realloc(tbl,
5282                                           (0x101+rlen-j) * sizeof(short));
5283                 cPVOPo->op_pv = (char*)tbl;
5284             }
5285             tbl[0x100] = (short)(rlen - j);
5286             for (i=0; i < (I32)rlen - j; i++)
5287                 tbl[0x101+i] = r[j+i];
5288         }
5289     }
5290     else {
5291         if (!rlen && !del) {
5292             r = t; rlen = tlen;
5293             if (!squash)
5294                 o->op_private |= OPpTRANS_IDENTICAL;
5295         }
5296         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
5297             o->op_private |= OPpTRANS_IDENTICAL;
5298         }
5299         for (i = 0; i < 256; i++)
5300             tbl[i] = -1;
5301         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
5302             if (j >= (I32)rlen) {
5303                 if (del) {
5304                     if (tbl[t[i]] == -1)
5305                         tbl[t[i]] = -2;
5306                     continue;
5307                 }
5308                 --j;
5309             }
5310             if (tbl[t[i]] == -1) {
5311                 if (t[i] < 128 && r[j] >= 128)
5312                     grows = 1;
5313                 tbl[t[i]] = r[j];
5314             }
5315         }
5316     }
5317
5318   warnins:
5319     if(del && rlen == tlen) {
5320         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
5321     } else if(rlen > tlen && !complement) {
5322         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
5323     }
5324
5325     if (grows)
5326         o->op_private |= OPpTRANS_GROWS;
5327     op_free(expr);
5328     op_free(repl);
5329
5330     return o;
5331 }
5332
5333 /*
5334 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
5335
5336 Constructs, checks, and returns an op of any pattern matching type.
5337 I<type> is the opcode.  I<flags> gives the eight bits of C<op_flags>
5338 and, shifted up eight bits, the eight bits of C<op_private>.
5339
5340 =cut
5341 */
5342
5343 OP *
5344 Perl_newPMOP(pTHX_ I32 type, I32 flags)
5345 {
5346     dVAR;
5347     PMOP *pmop;
5348
5349     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
5350         || type == OP_CUSTOM);
5351
5352     NewOp(1101, pmop, 1, PMOP);
5353     OpTYPE_set(pmop, type);
5354     pmop->op_flags = (U8)flags;
5355     pmop->op_private = (U8)(0 | (flags >> 8));
5356     if (PL_opargs[type] & OA_RETSCALAR)
5357         scalar((OP *)pmop);
5358
5359     if (PL_hints & HINT_RE_TAINT)
5360         pmop->op_pmflags |= PMf_RETAINT;
5361 #ifdef USE_LOCALE_CTYPE
5362     if (IN_LC_COMPILETIME(LC_CTYPE)) {
5363         set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
5364     }
5365     else
5366 #endif
5367          if (IN_UNI_8_BIT) {
5368         set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
5369     }
5370     if (PL_hints & HINT_RE_FLAGS) {
5371         SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5372          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
5373         );
5374         if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
5375         reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5376          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
5377         );
5378         if (reflags && SvOK(reflags)) {
5379             set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
5380         }
5381     }
5382
5383
5384 #ifdef USE_ITHREADS
5385     assert(SvPOK(PL_regex_pad[0]));
5386     if (SvCUR(PL_regex_pad[0])) {
5387         /* Pop off the "packed" IV from the end.  */
5388         SV *const repointer_list = PL_regex_pad[0];
5389         const char *p = SvEND(repointer_list) - sizeof(IV);
5390         const IV offset = *((IV*)p);
5391
5392         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
5393
5394         SvEND_set(repointer_list, p);
5395
5396         pmop->op_pmoffset = offset;
5397         /* This slot should be free, so assert this:  */
5398         assert(PL_regex_pad[offset] == &PL_sv_undef);
5399     } else {
5400         SV * const repointer = &PL_sv_undef;
5401         av_push(PL_regex_padav, repointer);
5402         pmop->op_pmoffset = av_tindex(PL_regex_padav);
5403         PL_regex_pad = AvARRAY(PL_regex_padav);
5404     }
5405 #endif
5406
5407     return CHECKOP(type, pmop);
5408 }
5409
5410 static void
5411 S_set_haseval(pTHX)
5412 {
5413     PADOFFSET i = 1;
5414     PL_cv_has_eval = 1;
5415     /* Any pad names in scope are potentially lvalues.  */
5416     for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
5417         PADNAME *pn = PAD_COMPNAME_SV(i);
5418         if (!pn || !PadnameLEN(pn))
5419             continue;
5420         if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
5421             S_mark_padname_lvalue(aTHX_ pn);
5422     }
5423 }
5424
5425 /* Given some sort of match op o, and an expression expr containing a
5426  * pattern, either compile expr into a regex and attach it to o (if it's
5427  * constant), or convert expr into a runtime regcomp op sequence (if it's
5428  * not)
5429  *
5430  * isreg indicates that the pattern is part of a regex construct, eg
5431  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
5432  * split "pattern", which aren't. In the former case, expr will be a list
5433  * if the pattern contains more than one term (eg /a$b/).
5434  *
5435  * When the pattern has been compiled within a new anon CV (for
5436  * qr/(?{...})/ ), then floor indicates the savestack level just before
5437  * the new sub was created
5438  */
5439
5440 OP *
5441 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, bool isreg, I32 floor)
5442 {
5443     PMOP *pm;
5444     LOGOP *rcop;
5445     I32 repl_has_vars = 0;
5446     bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
5447     bool is_compiletime;
5448     bool has_code;
5449
5450     PERL_ARGS_ASSERT_PMRUNTIME;
5451
5452     if (is_trans) {
5453         return pmtrans(o, expr, repl);
5454     }
5455
5456     /* find whether we have any runtime or code elements;
5457      * at the same time, temporarily set the op_next of each DO block;
5458      * then when we LINKLIST, this will cause the DO blocks to be excluded
5459      * from the op_next chain (and from having LINKLIST recursively
5460      * applied to them). We fix up the DOs specially later */
5461
5462     is_compiletime = 1;
5463     has_code = 0;
5464     if (expr->op_type == OP_LIST) {
5465         OP *o;
5466         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
5467             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
5468                 has_code = 1;
5469                 assert(!o->op_next);
5470                 if (UNLIKELY(!OpHAS_SIBLING(o))) {
5471                     assert(PL_parser && PL_parser->error_count);
5472                     /* This can happen with qr/ (?{(^{})/.  Just fake up
5473                        the op we were expecting to see, to avoid crashing
5474                        elsewhere.  */
5475                     op_sibling_splice(expr, o, 0,
5476                                       newSVOP(OP_CONST, 0, &PL_sv_no));
5477                 }
5478                 o->op_next = OpSIBLING(o);
5479             }
5480             else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
5481                 is_compiletime = 0;
5482         }
5483     }
5484     else if (expr->op_type != OP_CONST)
5485         is_compiletime = 0;
5486
5487     LINKLIST(expr);
5488
5489     /* fix up DO blocks; treat each one as a separate little sub;
5490      * also, mark any arrays as LIST/REF */
5491
5492     if (expr->op_type == OP_LIST) {
5493         OP *o;
5494         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
5495
5496             if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
5497                 assert( !(o->op_flags  & OPf_WANT));
5498                 /* push the array rather than its contents. The regex
5499                  * engine will retrieve and join the elements later */
5500                 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
5501                 continue;
5502             }
5503
5504             if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
5505                 continue;
5506             o->op_next = NULL; /* undo temporary hack from above */
5507             scalar(o);
5508             LINKLIST(o);
5509             if (cLISTOPo->op_first->op_type == OP_LEAVE) {
5510                 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
5511                 /* skip ENTER */
5512                 assert(leaveop->op_first->op_type == OP_ENTER);
5513                 assert(OpHAS_SIBLING(leaveop->op_first));
5514                 o->op_next = OpSIBLING(leaveop->op_first);
5515                 /* skip leave */
5516                 assert(leaveop->op_flags & OPf_KIDS);
5517                 assert(leaveop->op_last->op_next == (OP*)leaveop);
5518                 leaveop->op_next = NULL; /* stop on last op */
5519                 op_null((OP*)leaveop);
5520             }
5521             else {
5522                 /* skip SCOPE */
5523                 OP *scope = cLISTOPo->op_first;
5524                 assert(scope->op_type == OP_SCOPE);
5525                 assert(scope->op_flags & OPf_KIDS);
5526                 scope->op_next = NULL; /* stop on last op */
5527                 op_null(scope);
5528             }
5529             /* have to peep the DOs individually as we've removed it from
5530              * the op_next chain */
5531             CALL_PEEP(o);
5532             S_prune_chain_head(&(o->op_next));
5533             if (is_compiletime)
5534                 /* runtime finalizes as part of finalizing whole tree */
5535                 finalize_optree(o);
5536         }
5537     }
5538     else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
5539         assert( !(expr->op_flags  & OPf_WANT));
5540         /* push the array rather than its contents. The regex
5541          * engine will retrieve and join the elements later */
5542         expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
5543     }
5544
5545     PL_hints |= HINT_BLOCK_SCOPE;
5546     pm = (PMOP*)o;
5547     assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
5548
5549     if (is_compiletime) {
5550         U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
5551         regexp_engine const *eng = current_re_engine();
5552
5553         if (o->op_flags & OPf_SPECIAL)
5554             rx_flags |= RXf_SPLIT;
5555
5556         if (!has_code || !eng->op_comp) {
5557             /* compile-time simple constant pattern */
5558
5559             if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
5560                 /* whoops! we guessed that a qr// had a code block, but we
5561                  * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
5562                  * that isn't required now. Note that we have to be pretty
5563                  * confident that nothing used that CV's pad while the
5564                  * regex was parsed, except maybe op targets for \Q etc.
5565                  * If there were any op targets, though, they should have
5566                  * been stolen by constant folding.
5567                  */
5568 #ifdef DEBUGGING
5569                 SSize_t i = 0;
5570                 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
5571                 while (++i <= AvFILLp(PL_comppad)) {
5572                     assert(!PL_curpad[i]);
5573                 }
5574 #endif
5575                 /* But we know that one op is using this CV's slab. */
5576                 cv_forget_slab(PL_compcv);
5577                 LEAVE_SCOPE(floor);
5578                 pm->op_pmflags &= ~PMf_HAS_CV;
5579             }
5580
5581             PM_SETRE(pm,
5582                 eng->op_comp
5583                     ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5584                                         rx_flags, pm->op_pmflags)
5585                     : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5586                                         rx_flags, pm->op_pmflags)
5587             );
5588             op_free(expr);
5589         }
5590         else {
5591             /* compile-time pattern that includes literal code blocks */
5592             REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5593                         rx_flags,
5594                         (pm->op_pmflags |
5595                             ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
5596                     );
5597             PM_SETRE(pm, re);
5598             if (pm->op_pmflags & PMf_HAS_CV) {
5599                 CV *cv;
5600                 /* this QR op (and the anon sub we embed it in) is never
5601                  * actually executed. It's just a placeholder where we can
5602                  * squirrel away expr in op_code_list without the peephole
5603                  * optimiser etc processing it for a second time */
5604                 OP *qr = newPMOP(OP_QR, 0);
5605                 ((PMOP*)qr)->op_code_list = expr;
5606
5607                 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
5608                 SvREFCNT_inc_simple_void(PL_compcv);
5609                 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
5610                 ReANY(re)->qr_anoncv = cv;
5611
5612                 /* attach the anon CV to the pad so that
5613                  * pad_fixup_inner_anons() can find it */
5614                 (void)pad_add_anon(cv, o->op_type);
5615                 SvREFCNT_inc_simple_void(cv);
5616             }
5617             else {
5618                 pm->op_code_list = expr;
5619             }
5620         }
5621     }
5622     else {
5623         /* runtime pattern: build chain of regcomp etc ops */
5624         bool reglist;
5625         PADOFFSET cv_targ = 0;
5626
5627         reglist = isreg && expr->op_type == OP_LIST;
5628         if (reglist)
5629             op_null(expr);
5630
5631         if (has_code) {
5632             pm->op_code_list = expr;
5633             /* don't free op_code_list; its ops are embedded elsewhere too */
5634             pm->op_pmflags |= PMf_CODELIST_PRIVATE;
5635         }
5636
5637         if (o->op_flags & OPf_SPECIAL)
5638             pm->op_pmflags |= PMf_SPLIT;
5639
5640         /* the OP_REGCMAYBE is a placeholder in the non-threaded case
5641          * to allow its op_next to be pointed past the regcomp and
5642          * preceding stacking ops;
5643          * OP_REGCRESET is there to reset taint before executing the
5644          * stacking ops */
5645         if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
5646             expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
5647
5648         if (pm->op_pmflags & PMf_HAS_CV) {
5649             /* we have a runtime qr with literal code. This means
5650              * that the qr// has been wrapped in a new CV, which
5651              * means that runtime consts, vars etc will have been compiled
5652              * against a new pad. So... we need to execute those ops
5653              * within the environment of the new CV. So wrap them in a call
5654              * to a new anon sub. i.e. for
5655              *
5656              *     qr/a$b(?{...})/,
5657              *
5658              * we build an anon sub that looks like
5659              *
5660              *     sub { "a", $b, '(?{...})' }
5661              *
5662              * and call it, passing the returned list to regcomp.
5663              * Or to put it another way, the list of ops that get executed
5664              * are:
5665              *
5666              *     normal              PMf_HAS_CV
5667              *     ------              -------------------
5668              *                         pushmark (for regcomp)
5669              *                         pushmark (for entersub)
5670              *                         anoncode
5671              *                         srefgen
5672              *                         entersub
5673              *     regcreset                  regcreset
5674              *     pushmark                   pushmark
5675              *     const("a")                 const("a")
5676              *     gvsv(b)                    gvsv(b)
5677              *     const("(?{...})")          const("(?{...})")
5678              *                                leavesub
5679              *     regcomp             regcomp
5680              */
5681
5682             SvREFCNT_inc_simple_void(PL_compcv);
5683             CvLVALUE_on(PL_compcv);
5684             /* these lines are just an unrolled newANONATTRSUB */
5685             expr = newSVOP(OP_ANONCODE, 0,
5686                     MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
5687             cv_targ = expr->op_targ;
5688             expr = newUNOP(OP_REFGEN, 0, expr);
5689
5690             expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
5691         }
5692
5693         rcop = S_alloc_LOGOP(aTHX_ OP_REGCOMP, scalar(expr), o);
5694         rcop->op_flags |=  ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
5695                            | (reglist ? OPf_STACKED : 0);
5696         rcop->op_targ = cv_targ;
5697
5698         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
5699         if (PL_hints & HINT_RE_EVAL)
5700             S_set_haseval(aTHX);
5701
5702         /* establish postfix order */
5703         if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
5704             LINKLIST(expr);
5705             rcop->op_next = expr;
5706             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
5707         }
5708         else {
5709             rcop->op_next = LINKLIST(expr);
5710             expr->op_next = (OP*)rcop;
5711         }
5712
5713         op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
5714     }
5715
5716     if (repl) {
5717         OP *curop = repl;
5718         bool konst;
5719         /* If we are looking at s//.../e with a single statement, get past
5720            the implicit do{}. */
5721         if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
5722              && cUNOPx(curop)->op_first->op_type == OP_SCOPE
5723              && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
5724          {
5725             OP *sib;
5726             OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
5727             if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
5728              && !OpHAS_SIBLING(sib))
5729                 curop = sib;
5730         }
5731         if (curop->op_type == OP_CONST)
5732             konst = TRUE;
5733         else if (( (curop->op_type == OP_RV2SV ||
5734                     curop->op_type == OP_RV2AV ||
5735                     curop->op_type == OP_RV2HV ||
5736                     curop->op_type == OP_RV2GV)
5737                    && cUNOPx(curop)->op_first
5738                    && cUNOPx(curop)->op_first->op_type == OP_GV )
5739                 || curop->op_type == OP_PADSV
5740                 || curop->op_type == OP_PADAV
5741                 || curop->op_type == OP_PADHV
5742                 || curop->op_type == OP_PADANY) {
5743             repl_has_vars = 1;
5744             konst = TRUE;
5745         }
5746         else konst = FALSE;
5747         if (konst
5748             && !(repl_has_vars
5749                  && (!PM_GETRE(pm)
5750                      || !RX_PRELEN(PM_GETRE(pm))
5751                      || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
5752         {
5753             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
5754             op_prepend_elem(o->op_type, scalar(repl), o);
5755         }
5756         else {
5757             rcop = S_alloc_LOGOP(aTHX_ OP_SUBSTCONT, scalar(repl), o);
5758             rcop->op_private = 1;
5759
5760             /* establish postfix order */
5761             rcop->op_next = LINKLIST(repl);
5762             repl->op_next = (OP*)rcop;
5763
5764             pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
5765             assert(!(pm->op_pmflags & PMf_ONCE));
5766             pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
5767             rcop->op_next = 0;
5768         }
5769     }
5770
5771     return (OP*)pm;
5772 }
5773
5774 /*
5775 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
5776
5777 Constructs, checks, and returns an op of any type that involves an
5778 embedded SV.  I<type> is the opcode.  I<flags> gives the eight bits
5779 of C<op_flags>.  I<sv> gives the SV to embed in the op; this function
5780 takes ownership of one reference to it.
5781
5782 =cut
5783 */
5784
5785 OP *
5786 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
5787 {
5788     dVAR;
5789     SVOP *svop;
5790
5791     PERL_ARGS_ASSERT_NEWSVOP;
5792
5793     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5794         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5795         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5796         || type == OP_CUSTOM);
5797
5798     NewOp(1101, svop, 1, SVOP);
5799     OpTYPE_set(svop, type);
5800     svop->op_sv = sv;
5801     svop->op_next = (OP*)svop;
5802     svop->op_flags = (U8)flags;
5803     svop->op_private = (U8)(0 | (flags >> 8));
5804     if (PL_opargs[type] & OA_RETSCALAR)
5805         scalar((OP*)svop);
5806     if (PL_opargs[type] & OA_TARGET)
5807         svop->op_targ = pad_alloc(type, SVs_PADTMP);
5808     return CHECKOP(type, svop);
5809 }
5810
5811 /*
5812 =for apidoc Am|OP *|newDEFSVOP|
5813
5814 Constructs and returns an op to access C<$_>, either as a lexical
5815 variable (if declared as C<my $_>) in the current scope, or the
5816 global C<$_>.
5817
5818 =cut
5819 */
5820
5821 OP *
5822 Perl_newDEFSVOP(pTHX)
5823 {
5824     const PADOFFSET offset = pad_findmy_pvs("$_", 0);
5825     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5826         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
5827     }
5828     else {
5829         OP * const o = newOP(OP_PADSV, 0);
5830         o->op_targ = offset;
5831         return o;
5832     }
5833 }
5834
5835 #ifdef USE_ITHREADS
5836
5837 /*
5838 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
5839
5840 Constructs, checks, and returns an op of any type that involves a
5841 reference to a pad element.  I<type> is the opcode.  I<flags> gives the
5842 eight bits of C<op_flags>.  A pad slot is automatically allocated, and
5843 is populated with I<sv>; this function takes ownership of one reference
5844 to it.
5845
5846 This function only exists if Perl has been compiled to use ithreads.
5847
5848 =cut
5849 */
5850
5851 OP *
5852 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
5853 {
5854     dVAR;
5855     PADOP *padop;
5856
5857     PERL_ARGS_ASSERT_NEWPADOP;
5858
5859     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5860         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5861         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5862         || type == OP_CUSTOM);
5863
5864     NewOp(1101, padop, 1, PADOP);
5865     OpTYPE_set(padop, type);
5866     padop->op_padix =
5867         pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
5868     SvREFCNT_dec(PAD_SVl(padop->op_padix));
5869     PAD_SETSV(padop->op_padix, sv);
5870     assert(sv);
5871     padop->op_next = (OP*)padop;
5872     padop->op_flags = (U8)flags;
5873     if (PL_opargs[type] & OA_RETSCALAR)
5874         scalar((OP*)padop);
5875     if (PL_opargs[type] & OA_TARGET)
5876         padop->op_targ = pad_alloc(type, SVs_PADTMP);
5877     return CHECKOP(type, padop);
5878 }
5879
5880 #endif /* USE_ITHREADS */
5881
5882 /*
5883 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
5884
5885 Constructs, checks, and returns an op of any type that involves an
5886 embedded reference to a GV.  I<type> is the opcode.  I<flags> gives the
5887 eight bits of C<op_flags>.  I<gv> identifies the GV that the op should
5888 reference; calling this function does not transfer ownership of any
5889 reference to it.
5890
5891 =cut
5892 */
5893
5894 OP *
5895 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
5896 {
5897     PERL_ARGS_ASSERT_NEWGVOP;
5898
5899 #ifdef USE_ITHREADS
5900     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5901 #else
5902     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5903 #endif
5904 }
5905
5906 /*
5907 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
5908
5909 Constructs, checks, and returns an op of any type that involves an
5910 embedded C-level pointer (PV).  I<type> is the opcode.  I<flags> gives
5911 the eight bits of C<op_flags>.  I<pv> supplies the C-level pointer, which
5912 must have been allocated using C<PerlMemShared_malloc>; the memory will
5913 be freed when the op is destroyed.
5914
5915 =cut
5916 */
5917
5918 OP *
5919 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
5920 {
5921     dVAR;
5922     const bool utf8 = cBOOL(flags & SVf_UTF8);
5923     PVOP *pvop;
5924
5925     flags &= ~SVf_UTF8;
5926
5927     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5928         || type == OP_RUNCV || type == OP_CUSTOM
5929         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5930
5931     NewOp(1101, pvop, 1, PVOP);
5932     OpTYPE_set(pvop, type);
5933     pvop->op_pv = pv;
5934     pvop->op_next = (OP*)pvop;
5935     pvop->op_flags = (U8)flags;
5936     pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
5937     if (PL_opargs[type] & OA_RETSCALAR)
5938         scalar((OP*)pvop);
5939     if (PL_opargs[type] & OA_TARGET)
5940         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
5941     return CHECKOP(type, pvop);
5942 }
5943
5944 void
5945 Perl_package(pTHX_ OP *o)
5946 {
5947     SV *const sv = cSVOPo->op_sv;
5948
5949     PERL_ARGS_ASSERT_PACKAGE;
5950
5951     SAVEGENERICSV(PL_curstash);
5952     save_item(PL_curstname);
5953
5954     PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
5955
5956     sv_setsv(PL_curstname, sv);
5957
5958     PL_hints |= HINT_BLOCK_SCOPE;
5959     PL_parser->copline = NOLINE;
5960
5961     op_free(o);
5962 }
5963
5964 void
5965 Perl_package_version( pTHX_ OP *v )
5966 {
5967     U32 savehints = PL_hints;
5968     PERL_ARGS_ASSERT_PACKAGE_VERSION;
5969     PL_hints &= ~HINT_STRICT_VARS;
5970     sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
5971     PL_hints = savehints;
5972     op_free(v);
5973 }
5974
5975 void
5976 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
5977 {
5978     OP *pack;
5979     OP *imop;
5980     OP *veop;
5981     SV *use_version = NULL;
5982
5983     PERL_ARGS_ASSERT_UTILIZE;
5984
5985     if (idop->op_type != OP_CONST)
5986         Perl_croak(aTHX_ "Module name must be constant");
5987
5988     veop = NULL;
5989
5990     if (version) {
5991         SV * const vesv = ((SVOP*)version)->op_sv;
5992
5993         if (!arg && !SvNIOKp(vesv)) {
5994             arg = version;
5995         }
5996         else {
5997             OP *pack;
5998             SV *meth;
5999
6000             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
6001                 Perl_croak(aTHX_ "Version number must be a constant number");
6002
6003             /* Make copy of idop so we don't free it twice */
6004             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
6005
6006             /* Fake up a method call to VERSION */
6007             meth = newSVpvs_share("VERSION");
6008             veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
6009                             op_append_elem(OP_LIST,
6010                                         op_prepend_elem(OP_LIST, pack, version),
6011                                         newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
6012         }
6013     }
6014
6015     /* Fake up an import/unimport */
6016     if (arg && arg->op_type == OP_STUB) {
6017         imop = arg;             /* no import on explicit () */
6018     }
6019     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
6020         imop = NULL;            /* use 5.0; */
6021         if (aver)
6022             use_version = ((SVOP*)idop)->op_sv;
6023         else
6024             idop->op_private |= OPpCONST_NOVER;
6025     }
6026     else {
6027         SV *meth;
6028
6029         /* Make copy of idop so we don't free it twice */
6030         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
6031
6032         /* Fake up a method call to import/unimport */
6033         meth = aver
6034             ? newSVpvs_share("import") : newSVpvs_share("unimport");
6035         imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
6036                        op_append_elem(OP_LIST,
6037                                    op_prepend_elem(OP_LIST, pack, arg),
6038                                    newMETHOP_named(OP_METHOD_NAMED, 0, meth)
6039                        ));
6040     }
6041
6042     /* Fake up the BEGIN {}, which does its thing immediately. */
6043     newATTRSUB(floor,
6044         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
6045         NULL,
6046         NULL,
6047         op_append_elem(OP_LINESEQ,
6048             op_append_elem(OP_LINESEQ,
6049                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
6050                 newSTATEOP(0, NULL, veop)),
6051             newSTATEOP(0, NULL, imop) ));
6052
6053     if (use_version) {
6054         /* Enable the
6055          * feature bundle that corresponds to the required version. */
6056         use_version = sv_2mortal(new_version(use_version));
6057         S_enable_feature_bundle(aTHX_ use_version);
6058
6059         /* If a version >= 5.11.0 is requested, strictures are on by default! */
6060         if (vcmp(use_version,
6061                  sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
6062             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
6063                 PL_hints |= HINT_STRICT_REFS;
6064             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
6065                 PL_hints |= HINT_STRICT_SUBS;
6066             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
6067                 PL_hints |= HINT_STRICT_VARS;
6068         }
6069         /* otherwise they are off */
6070         else {
6071             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
6072                 PL_hints &= ~HINT_STRICT_REFS;
6073             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
6074                 PL_hints &= ~HINT_STRICT_SUBS;
6075             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
6076                 PL_hints &= ~HINT_STRICT_VARS;
6077         }
6078     }
6079
6080     /* The "did you use incorrect case?" warning used to be here.
6081      * The problem is that on case-insensitive filesystems one
6082      * might get false positives for "use" (and "require"):
6083      * "use Strict" or "require CARP" will work.  This causes
6084      * portability problems for the script: in case-strict
6085      * filesystems the script will stop working.
6086      *
6087      * The "incorrect case" warning checked whether "use Foo"
6088      * imported "Foo" to your namespace, but that is wrong, too:
6089      * there is no requirement nor promise in the language that
6090      * a Foo.pm should or would contain anything in package "Foo".
6091      *
6092      * There is very little Configure-wise that can be done, either:
6093      * the case-sensitivity of the build filesystem of Perl does not
6094      * help in guessing the case-sensitivity of the runtime environment.
6095      */
6096
6097     PL_hints |= HINT_BLOCK_SCOPE;
6098     PL_parser->copline = NOLINE;
6099     COP_SEQMAX_INC; /* Purely for B::*'s benefit */
6100 }
6101
6102 /*
6103 =head1 Embedding Functions
6104
6105 =for apidoc load_module
6106
6107 Loads the module whose name is pointed to by the string part of name.
6108 Note that the actual module name, not its filename, should be given.
6109 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
6110 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
6111 (or 0 for no flags).  ver, if specified
6112 and not NULL, provides version semantics
6113 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
6114 arguments can be used to specify arguments to the module's import()
6115 method, similar to C<use Foo::Bar VERSION LIST>.  They must be
6116 terminated with a final NULL pointer.  Note that this list can only
6117 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
6118 Otherwise at least a single NULL pointer to designate the default
6119 import list is required.
6120
6121 The reference count for each specified C<SV*> parameter is decremented.
6122
6123 =cut */
6124
6125 void
6126 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
6127 {
6128     va_list args;
6129
6130     PERL_ARGS_ASSERT_LOAD_MODULE;
6131
6132     va_start(args, ver);
6133     vload_module(flags, name, ver, &args);
6134     va_end(args);
6135 }
6136
6137 #ifdef PERL_IMPLICIT_CONTEXT
6138 void
6139 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
6140 {
6141     dTHX;
6142     va_list args;
6143     PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
6144     va_start(args, ver);
6145     vload_module(flags, name, ver, &args);
6146     va_end(args);
6147 }
6148 #endif
6149
6150 void
6151 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
6152 {
6153     OP *veop, *imop;
6154     OP * const modname = newSVOP(OP_CONST, 0, name);
6155
6156     PERL_ARGS_ASSERT_VLOAD_MODULE;
6157
6158     modname->op_private |= OPpCONST_BARE;
6159     if (ver) {
6160         veop = newSVOP(OP_CONST, 0, ver);
6161     }
6162     else
6163         veop = NULL;
6164     if (flags & PERL_LOADMOD_NOIMPORT) {
6165         imop = sawparens(newNULLLIST());
6166     }
6167     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
6168         imop = va_arg(*args, OP*);
6169     }
6170     else {
6171         SV *sv;
6172         imop = NULL;
6173         sv = va_arg(*args, SV*);
6174         while (sv) {
6175             imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
6176             sv = va_arg(*args, SV*);
6177         }
6178     }
6179
6180     /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
6181      * that it has a PL_parser to play with while doing that, and also
6182      * that it doesn't mess with any existing parser, by creating a tmp
6183      * new parser with lex_start(). This won't actually be used for much,
6184      * since pp_require() will create another parser for the real work.
6185      * The ENTER/LEAVE pair protect callers from any side effects of use.  */
6186
6187     ENTER;
6188     SAVEVPTR(PL_curcop);
6189     lex_start(NULL, NULL, LEX_START_SAME_FILTER);
6190     utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
6191             veop, modname, imop);
6192     LEAVE;
6193 }
6194
6195 PERL_STATIC_INLINE OP *
6196 S_new_entersubop(pTHX_ GV *gv, OP *arg)
6197 {
6198     return newUNOP(OP_ENTERSUB, OPf_STACKED,
6199                    newLISTOP(OP_LIST, 0, arg,
6200                              newUNOP(OP_RV2CV, 0,
6201                                      newGVOP(OP_GV, 0, gv))));
6202 }
6203
6204 OP *
6205 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
6206 {
6207     OP *doop;
6208     GV *gv;
6209
6210     PERL_ARGS_ASSERT_DOFILE;
6211
6212     if (!force_builtin && (gv = gv_override("do", 2))) {
6213         doop = S_new_entersubop(aTHX_ gv, term);
6214     }
6215     else {
6216         doop = newUNOP(OP_DOFILE, 0, scalar(term));
6217     }
6218     return doop;
6219 }
6220
6221 /*
6222 =head1 Optree construction
6223
6224 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
6225
6226 Constructs, checks, and returns an C<lslice> (list slice) op.  I<flags>
6227 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
6228 be set automatically, and, shifted up eight bits, the eight bits of
6229 C<op_private>, except that the bit with value 1 or 2 is automatically
6230 set as required.  I<listval> and I<subscript> supply the parameters of
6231 the slice; they are consumed by this function and become part of the
6232 constructed op tree.
6233
6234 =cut
6235 */
6236
6237 OP *
6238 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
6239 {
6240     return newBINOP(OP_LSLICE, flags,
6241             list(force_list(subscript, 1)),
6242             list(force_list(listval,   1)) );
6243 }
6244
6245 #define ASSIGN_LIST   1
6246 #define ASSIGN_REF    2
6247
6248 STATIC I32
6249 S_assignment_type(pTHX_ const OP *o)
6250 {
6251     unsigned type;
6252     U8 flags;
6253     U8 ret;
6254
6255     if (!o)
6256         return TRUE;
6257
6258     if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
6259         o = cUNOPo->op_first;
6260
6261     flags = o->op_flags;
6262     type = o->op_type;
6263     if (type == OP_COND_EXPR) {
6264         OP * const sib = OpSIBLING(cLOGOPo->op_first);
6265         const I32 t = assignment_type(sib);
6266         const I32 f = assignment_type(OpSIBLING(sib));
6267
6268         if (t == ASSIGN_LIST && f == ASSIGN_LIST)
6269             return ASSIGN_LIST;
6270         if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
6271             yyerror("Assignment to both a list and a scalar");
6272         return FALSE;
6273     }
6274
6275     if (type == OP_SREFGEN)
6276     {
6277         OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
6278         type = kid->op_type;
6279         flags |= kid->op_flags;
6280         if (!(flags & OPf_PARENS)
6281           && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
6282               kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
6283             return ASSIGN_REF;
6284         ret = ASSIGN_REF;
6285     }
6286     else ret = 0;
6287
6288     if (type == OP_LIST &&
6289         (flags & OPf_WANT) == OPf_WANT_SCALAR &&
6290         o->op_private & OPpLVAL_INTRO)
6291         return ret;
6292
6293     if (type == OP_LIST || flags & OPf_PARENS ||
6294         type == OP_RV2AV || type == OP_RV2HV ||
6295         type == OP_ASLICE || type == OP_HSLICE ||
6296         type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
6297         return TRUE;
6298
6299     if (type == OP_PADAV || type == OP_PADHV)
6300         return TRUE;
6301
6302     if (type == OP_RV2SV)
6303         return ret;
6304
6305     return ret;
6306 }
6307
6308 /*
6309   Helper function for newASSIGNOP to detect commonality between the
6310   lhs and the rhs.  (It is actually called very indirectly.  newASSIGNOP
6311   flags the op and the peephole optimizer calls this helper function
6312   if the flag is set.)  Marks all variables with PL_generation.  If it
6313   returns TRUE the assignment must be able to handle common variables.
6314
6315   PL_generation sorcery:
6316   An assignment like ($a,$b) = ($c,$d) is easier than
6317   ($a,$b) = ($c,$a), since there is no need for temporary vars.
6318   To detect whether there are common vars, the global var
6319   PL_generation is incremented for each assign op we compile.
6320   Then, while compiling the assign op, we run through all the
6321   variables on both sides of the assignment, setting a spare slot
6322   in each of them to PL_generation.  If any of them already have
6323   that value, we know we've got commonality.  Also, if the
6324   generation number is already set to PERL_INT_MAX, then
6325   the variable is involved in aliasing, so we also have
6326   potential commonality in that case.  We could use a
6327   single bit marker, but then we'd have to make 2 passes, first
6328   to clear the flag, then to test and set it.  And that
6329   wouldn't help with aliasing, either.  To find somewhere
6330   to store these values, evil chicanery is done with SvUVX().
6331 */
6332 PERL_STATIC_INLINE bool
6333 S_aassign_common_vars(pTHX_ OP* o)
6334 {
6335     OP *curop;
6336     for (curop = cUNOPo->op_first; curop; curop = OpSIBLING(curop)) {
6337         if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
6338             if (curop->op_type == OP_GV || curop->op_type == OP_GVSV
6339              || curop->op_type == OP_AELEMFAST) {
6340                 GV *gv = cGVOPx_gv(curop);
6341                 if (gv == PL_defgv
6342                     || (int)GvASSIGN_GENERATION(gv) == PL_generation)
6343                     return TRUE;
6344                 GvASSIGN_GENERATION_set(gv, PL_generation);
6345             }
6346             else if (curop->op_type == OP_PADSV ||
6347                 curop->op_type == OP_PADAV ||
6348                 curop->op_type == OP_PADHV ||
6349                 curop->op_type == OP_AELEMFAST_LEX ||
6350                 curop->op_type == OP_PADANY)
6351                 {
6352                   padcheck:
6353                     if (PAD_COMPNAME_GEN(curop->op_targ)
6354                         == (STRLEN)PL_generation
6355                      || PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX)
6356                         return TRUE;
6357                     PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
6358
6359                 }
6360             else if (curop->op_type == OP_RV2CV)
6361                 return TRUE;
6362             else if (curop->op_type == OP_RV2SV ||
6363                 curop->op_type == OP_RV2AV ||
6364                 curop->op_type == OP_RV2HV ||
6365                 curop->op_type == OP_RV2GV) {
6366                 if (cUNOPx(curop)->op_first->op_type != OP_GV)  /* funny deref? */
6367                     return TRUE;
6368             }
6369             else if (curop->op_type == OP_PUSHRE) {
6370                 GV *const gv =
6371 #ifdef USE_ITHREADS
6372                     ((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff
6373                         ? MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff))
6374                         : NULL;
6375 #else
6376                     ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
6377 #endif
6378                 if (gv) {
6379                     if (gv == PL_defgv
6380                         || (int)GvASSIGN_GENERATION(gv) == PL_generation)
6381                         return TRUE;
6382                     GvASSIGN_GENERATION_set(gv, PL_generation);
6383                 }
6384                 else if (curop->op_targ)
6385                     goto padcheck;
6386             }
6387             else if (curop->op_type == OP_PADRANGE)
6388                 /* Ignore padrange; checking its siblings is sufficient. */
6389                 continue;
6390             else
6391                 return TRUE;
6392         }
6393         else if (PL_opargs[curop->op_type] & OA_TARGLEX
6394               && curop->op_private & OPpTARGET_MY)
6395             goto padcheck;
6396
6397         if (curop->op_flags & OPf_KIDS) {
6398             if (aassign_common_vars(curop))
6399                 return TRUE;
6400         }
6401     }
6402     return FALSE;
6403 }
6404
6405 /* This variant only handles lexical aliases.  It is called when
6406    newASSIGNOP decides that we don’t have any common vars, as lexical ali-
6407    ases trump that decision.  */
6408 PERL_STATIC_INLINE bool
6409 S_aassign_common_vars_aliases_only(pTHX_ OP *o)
6410 {
6411     OP *curop;
6412     for (curop = cUNOPo->op_first; curop; curop = OpSIBLING(curop)) {
6413         if ((curop->op_type == OP_PADSV ||
6414              curop->op_type == OP_PADAV ||
6415              curop->op_type == OP_PADHV ||
6416              curop->op_type == OP_AELEMFAST_LEX ||
6417              curop->op_type == OP_PADANY ||
6418              (  PL_opargs[curop->op_type] & OA_TARGLEX
6419              && curop->op_private & OPpTARGET_MY  ))
6420            && PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX)
6421             return TRUE;
6422
6423         if (curop->op_type == OP_PUSHRE && curop->op_targ
6424          && PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX)
6425             return TRUE;
6426
6427         if (curop->op_flags & OPf_KIDS) {
6428             if (S_aassign_common_vars_aliases_only(aTHX_ curop))
6429                 return TRUE;
6430         }
6431     }
6432     return FALSE;
6433 }
6434
6435 /*
6436 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
6437
6438 Constructs, checks, and returns an assignment op.  I<left> and I<right>
6439 supply the parameters of the assignment; they are consumed by this
6440 function and become part of the constructed op tree.
6441
6442 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
6443 a suitable conditional optree is constructed.  If I<optype> is the opcode
6444 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
6445 performs the binary operation and assigns the result to the left argument.
6446 Either way, if I<optype> is non-zero then I<flags> has no effect.
6447
6448 If I<optype> is zero, then a plain scalar or list assignment is
6449 constructed.  Which type of assignment it is is automatically determined.
6450 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6451 will be set automatically, and, shifted up eight bits, the eight bits
6452 of C<op_private>, except that the bit with value 1 or 2 is automatically
6453 set as required.
6454
6455 =cut
6456 */
6457
6458 OP *
6459 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
6460 {
6461     OP *o;
6462     I32 assign_type;
6463
6464     if (optype) {
6465         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
6466             return newLOGOP(optype, 0,
6467                 op_lvalue(scalar(left), optype),
6468                 newUNOP(OP_SASSIGN, 0, scalar(right)));
6469         }
6470         else {
6471             return newBINOP(optype, OPf_STACKED,
6472                 op_lvalue(scalar(left), optype), scalar(right));
6473         }
6474     }
6475
6476     if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
6477         static const char no_list_state[] = "Initialization of state variables"
6478             " in list context currently forbidden";
6479         OP *curop;
6480         bool maybe_common_vars = TRUE;
6481
6482         if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
6483             left->op_private &= ~ OPpSLICEWARNING;
6484
6485         PL_modcount = 0;
6486         left = op_lvalue(left, OP_AASSIGN);
6487         curop = list(force_list(left, 1));
6488         o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
6489         o->op_private = (U8)(0 | (flags >> 8));
6490
6491         if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
6492         {
6493             OP* lop = ((LISTOP*)left)->op_first;
6494             maybe_common_vars = FALSE;
6495             while (lop) {
6496                 if (lop->op_type == OP_PADSV ||
6497                     lop->op_type == OP_PADAV ||
6498                     lop->op_type == OP_PADHV ||
6499                     lop->op_type == OP_PADANY) {
6500                     if (!(lop->op_private & OPpLVAL_INTRO))
6501                         maybe_common_vars = TRUE;
6502
6503                     if (lop->op_private & OPpPAD_STATE) {
6504                         if (left->op_private & OPpLVAL_INTRO) {
6505                             /* Each variable in state($a, $b, $c) = ... */
6506                         }
6507                         else {
6508                             /* Each state variable in
6509                                (state $a, my $b, our $c, $d, undef) = ... */
6510                         }
6511                         yyerror(no_list_state);
6512                     } else {
6513                         /* Each my variable in
6514                            (state $a, my $b, our $c, $d, undef) = ... */
6515                     }
6516                 } else if (lop->op_type == OP_UNDEF ||
6517                            OP_TYPE_IS_OR_WAS(lop, OP_PUSHMARK)) {
6518                     /* undef may be interesting in
6519                        (state $a, undef, state $c) */
6520                 } else {
6521                     /* Other ops in the list. */
6522                     maybe_common_vars = TRUE;
6523                 }
6524                 lop = OpSIBLING(lop);
6525             }
6526         }
6527         else if ((left->op_private & OPpLVAL_INTRO)
6528                 && (   left->op_type == OP_PADSV
6529                     || left->op_type == OP_PADAV
6530                     || left->op_type == OP_PADHV
6531                     || left->op_type == OP_PADANY))
6532         {
6533             if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
6534             if (left->op_private & OPpPAD_STATE) {
6535                 /* All single variable list context state assignments, hence
6536                    state ($a) = ...
6537                    (state $a) = ...
6538                    state @a = ...
6539                    state (@a) = ...
6540                    (state @a) = ...
6541                    state %a = ...
6542                    state (%a) = ...
6543                    (state %a) = ...
6544                 */
6545                 yyerror(no_list_state);
6546             }
6547         }
6548
6549         if (maybe_common_vars) {
6550                 /* The peephole optimizer will do the full check and pos-
6551                    sibly turn this off.  */
6552                 o->op_private |= OPpASSIGN_COMMON;
6553         }
6554
6555         if (right && right->op_type == OP_SPLIT
6556          && !(right->op_flags & OPf_STACKED)) {
6557             OP* tmpop = ((LISTOP*)right)->op_first;
6558             PMOP * const pm = (PMOP*)tmpop;
6559             assert (tmpop && (tmpop->op_type == OP_PUSHRE));
6560             if (
6561 #ifdef USE_ITHREADS
6562                     !pm->op_pmreplrootu.op_pmtargetoff
6563 #else
6564                     !pm->op_pmreplrootu.op_pmtargetgv
6565 #endif
6566                  && !pm->op_targ
6567                 ) {
6568                     if (!(left->op_private & OPpLVAL_INTRO) &&
6569                         ( (left->op_type == OP_RV2AV &&
6570                           (tmpop=((UNOP*)left)->op_first)->op_type==OP_GV)
6571                         || left->op_type == OP_PADAV )
6572                         ) {
6573                         if (tmpop != (OP *)pm) {
6574 #ifdef USE_ITHREADS
6575                           pm->op_pmreplrootu.op_pmtargetoff
6576                             = cPADOPx(tmpop)->op_padix;
6577                           cPADOPx(tmpop)->op_padix = 0; /* steal it */
6578 #else
6579                           pm->op_pmreplrootu.op_pmtargetgv
6580                             = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
6581                           cSVOPx(tmpop)->op_sv = NULL;  /* steal it */
6582 #endif
6583                           right->op_private |=
6584                             left->op_private & OPpOUR_INTRO;
6585                         }
6586                         else {
6587                             pm->op_targ = left->op_targ;
6588                             left->op_targ = 0; /* filch it */
6589                         }
6590                       detach_split:
6591                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
6592                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
6593                         /* detach rest of siblings from o subtree,
6594                          * and free subtree */
6595                         op_sibling_splice(cUNOPo->op_first, tmpop, -1, NULL);
6596                         op_free(o);                     /* blow off assign */
6597                         right->op_flags &= ~OPf_WANT;
6598                                 /* "I don't know and I don't care." */
6599                         return right;
6600                     }
6601                     else if (left->op_type == OP_RV2AV
6602                           || left->op_type == OP_PADAV)
6603                     {
6604                         /* Detach the array.  */
6605 #ifdef DEBUGGING
6606                         OP * const ary =
6607 #endif
6608                         op_sibling_splice(cBINOPo->op_last,
6609                                           cUNOPx(cBINOPo->op_last)
6610                                                 ->op_first, 1, NULL);
6611                         assert(ary == left);
6612                         /* Attach it to the split.  */
6613                         op_sibling_splice(right, cLISTOPx(right)->op_last,
6614                                           0, left);
6615                         right->op_flags |= OPf_STACKED;
6616                         /* Detach split and expunge aassign as above.  */
6617                         goto detach_split;
6618                     }
6619                     else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
6620                             ((LISTOP*)right)->op_last->op_type == OP_CONST)
6621                     {
6622                         SV ** const svp =
6623                             &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
6624                         SV * const sv = *svp;
6625                         if (SvIOK(sv) && SvIVX(sv) == 0)
6626                         {
6627                           if (right->op_private & OPpSPLIT_IMPLIM) {
6628                             /* our own SV, created in ck_split */
6629                             SvREADONLY_off(sv);
6630                             sv_setiv(sv, PL_modcount+1);
6631                           }
6632                           else {
6633                             /* SV may belong to someone else */
6634                             SvREFCNT_dec(sv);
6635                             *svp = newSViv(PL_modcount+1);
6636                           }
6637                         }
6638                     }
6639             }
6640         }
6641         return o;
6642     }
6643     if (assign_type == ASSIGN_REF)
6644         return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
6645     if (!right)
6646         right = newOP(OP_UNDEF, 0);
6647     if (right->op_type == OP_READLINE) {
6648         right->op_flags |= OPf_STACKED;
6649         return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
6650                 scalar(right));
6651     }
6652     else {
6653         o = newBINOP(OP_SASSIGN, flags,
6654             scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
6655     }
6656     return o;
6657 }
6658
6659 /*
6660 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
6661
6662 Constructs a state op (COP).  The state op is normally a C<nextstate> op,
6663 but will be a C<dbstate> op if debugging is enabled for currently-compiled
6664 code.  The state op is populated from C<PL_curcop> (or C<PL_compiling>).
6665 If I<label> is non-null, it supplies the name of a label to attach to
6666 the state op; this function takes ownership of the memory pointed at by
6667 I<label>, and will free it.  I<flags> gives the eight bits of C<op_flags>
6668 for the state op.
6669
6670 If I<o> is null, the state op is returned.  Otherwise the state op is
6671 combined with I<o> into a C<lineseq> list op, which is returned.  I<o>
6672 is consumed by this function and becomes part of the returned op tree.
6673
6674 =cut
6675 */
6676
6677 OP *
6678 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
6679 {
6680     dVAR;
6681     const U32 seq = intro_my();
6682     const U32 utf8 = flags & SVf_UTF8;
6683     COP *cop;
6684
6685     PL_parser->parsed_sub = 0;
6686
6687     flags &= ~SVf_UTF8;
6688
6689     NewOp(1101, cop, 1, COP);
6690     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
6691         OpTYPE_set(cop, OP_DBSTATE);
6692     }
6693     else {
6694         OpTYPE_set(cop, OP_NEXTSTATE);
6695     }
6696     cop->op_flags = (U8)flags;
6697     CopHINTS_set(cop, PL_hints);
6698 #ifdef VMS
6699     if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
6700 #endif
6701     cop->op_next = (OP*)cop;
6702
6703     cop->cop_seq = seq;
6704     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
6705     CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
6706     if (label) {
6707         Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
6708
6709         PL_hints |= HINT_BLOCK_SCOPE;
6710         /* It seems that we need to defer freeing this pointer, as other parts
6711            of the grammar end up wanting to copy it after this op has been
6712            created. */
6713         SAVEFREEPV(label);
6714     }
6715
6716     if (PL_parser->preambling != NOLINE) {
6717         CopLINE_set(cop, PL_parser->preambling);
6718         PL_parser->copline = NOLINE;
6719     }
6720     else if (PL_parser->copline == NOLINE)
6721         CopLINE_set(cop, CopLINE(PL_curcop));
6722     else {
6723         CopLINE_set(cop, PL_parser->copline);
6724         PL_parser->copline = NOLINE;
6725     }
6726 #ifdef USE_ITHREADS
6727     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
6728 #else
6729     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
6730 #endif
6731     CopSTASH_set(cop, PL_curstash);
6732
6733     if (cop->op_type == OP_DBSTATE) {
6734         /* this line can have a breakpoint - store the cop in IV */
6735         AV *av = CopFILEAVx(PL_curcop);
6736         if (av) {
6737             SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
6738             if (svp && *svp != &PL_sv_undef ) {
6739                 (void)SvIOK_on(*svp);
6740                 SvIV_set(*svp, PTR2IV(cop));
6741             }
6742         }
6743     }
6744
6745     if (flags & OPf_SPECIAL)
6746         op_null((OP*)cop);
6747     return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
6748 }
6749
6750 /*
6751 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
6752
6753 Constructs, checks, and returns a logical (flow control) op.  I<type>
6754 is the opcode.  I<flags> gives the eight bits of C<op_flags>, except
6755 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6756 the eight bits of C<op_private>, except that the bit with value 1 is
6757 automatically set.  I<first> supplies the expression controlling the
6758 flow, and I<other> supplies the side (alternate) chain of ops; they are
6759 consumed by this function and become part of the constructed op tree.
6760
6761 =cut
6762 */
6763
6764 OP *
6765 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
6766 {
6767     PERL_ARGS_ASSERT_NEWLOGOP;
6768
6769     return new_logop(type, flags, &first, &other);
6770 }
6771
6772 STATIC OP *
6773 S_search_const(pTHX_ OP *o)
6774 {
6775     PERL_ARGS_ASSERT_SEARCH_CONST;
6776
6777     switch (o->op_type) {
6778         case OP_CONST:
6779             return o;
6780         case OP_NULL:
6781             if (o->op_flags & OPf_KIDS)
6782                 return search_const(cUNOPo->op_first);
6783             break;
6784         case OP_LEAVE:
6785         case OP_SCOPE:
6786         case OP_LINESEQ:
6787         {
6788             OP *kid;
6789             if (!(o->op_flags & OPf_KIDS))
6790                 return NULL;
6791             kid = cLISTOPo->op_first;
6792             do {
6793                 switch (kid->op_type) {
6794                     case OP_ENTER:
6795                     case OP_NULL:
6796                     case OP_NEXTSTATE:
6797                         kid = OpSIBLING(kid);
6798                         break;
6799                     default:
6800                         if (kid != cLISTOPo->op_last)
6801                             return NULL;
6802                         goto last;
6803                 }
6804             } while (kid);
6805             if (!kid)
6806                 kid = cLISTOPo->op_last;
6807           last:
6808             return search_const(kid);
6809         }
6810     }
6811
6812     return NULL;
6813 }
6814
6815 STATIC OP *
6816 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
6817 {
6818     dVAR;
6819     LOGOP *logop;
6820     OP *o;
6821     OP *first;
6822     OP *other;
6823     OP *cstop = NULL;
6824     int prepend_not = 0;
6825
6826     PERL_ARGS_ASSERT_NEW_LOGOP;
6827
6828     first = *firstp;
6829     other = *otherp;
6830
6831     /* [perl #59802]: Warn about things like "return $a or $b", which
6832        is parsed as "(return $a) or $b" rather than "return ($a or
6833        $b)".  NB: This also applies to xor, which is why we do it
6834        here.
6835      */
6836     switch (first->op_type) {
6837     case OP_NEXT:
6838     case OP_LAST:
6839     case OP_REDO:
6840         /* XXX: Perhaps we should emit a stronger warning for these.
6841            Even with the high-precedence operator they don't seem to do
6842            anything sensible.
6843
6844            But until we do, fall through here.
6845          */
6846     case OP_RETURN:
6847     case OP_EXIT:
6848     case OP_DIE:
6849     case OP_GOTO:
6850         /* XXX: Currently we allow people to "shoot themselves in the
6851            foot" by explicitly writing "(return $a) or $b".
6852
6853            Warn unless we are looking at the result from folding or if
6854            the programmer explicitly grouped the operators like this.
6855            The former can occur with e.g.
6856
6857                 use constant FEATURE => ( $] >= ... );
6858                 sub { not FEATURE and return or do_stuff(); }
6859          */
6860         if (!first->op_folded && !(first->op_flags & OPf_PARENS))
6861             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6862                            "Possible precedence issue with control flow operator");
6863         /* XXX: Should we optimze this to "return $a;" (i.e. remove
6864            the "or $b" part)?
6865         */
6866         break;
6867     }
6868
6869     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
6870         return newBINOP(type, flags, scalar(first), scalar(other));
6871
6872     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
6873         || type == OP_CUSTOM);
6874
6875     scalarboolean(first);
6876     /* optimize AND and OR ops that have NOTs as children */
6877     if (first->op_type == OP_NOT
6878         && (first->op_flags & OPf_KIDS)
6879         && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
6880             || (other->op_type == OP_NOT))  /* if (!$x && !$y) { } */
6881         ) {
6882         if (type == OP_AND || type == OP_OR) {
6883             if (type == OP_AND)
6884                 type = OP_OR;
6885             else
6886                 type = OP_AND;
6887             op_null(first);
6888             if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
6889                 op_null(other);
6890                 prepend_not = 1; /* prepend a NOT op later */
6891             }
6892         }
6893     }
6894     /* search for a constant op that could let us fold the test */
6895     if ((cstop = search_const(first))) {
6896         if (cstop->op_private & OPpCONST_STRICT)
6897             no_bareword_allowed(cstop);
6898         else if ((cstop->op_private & OPpCONST_BARE))
6899                 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
6900         if ((type == OP_AND &&  SvTRUE(((SVOP*)cstop)->op_sv)) ||
6901             (type == OP_OR  && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
6902             (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
6903             *firstp = NULL;
6904             if (other->op_type == OP_CONST)
6905                 other->op_private |= OPpCONST_SHORTCIRCUIT;
6906             op_free(first);
6907             if (other->op_type == OP_LEAVE)
6908                 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
6909             else if (other->op_type == OP_MATCH
6910                   || other->op_type == OP_SUBST
6911                   || other->op_type == OP_TRANSR
6912                   || other->op_type == OP_TRANS)
6913                 /* Mark the op as being unbindable with =~ */
6914                 other->op_flags |= OPf_SPECIAL;
6915
6916             other->op_folded = 1;
6917             return other;
6918         }
6919         else {
6920             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
6921             const OP *o2 = other;
6922             if ( ! (o2->op_type == OP_LIST
6923                     && (( o2 = cUNOPx(o2)->op_first))
6924                     && o2->op_type == OP_PUSHMARK
6925                     && (( o2 = OpSIBLING(o2))) )
6926             )
6927                 o2 = other;
6928             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
6929                         || o2->op_type == OP_PADHV)
6930                 && o2->op_private & OPpLVAL_INTRO
6931                 && !(o2->op_private & OPpPAD_STATE))
6932             {
6933                 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6934                                  "Deprecated use of my() in false conditional");
6935             }
6936
6937             *otherp = NULL;
6938             if (cstop->op_type == OP_CONST)
6939                 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
6940                 op_free(other);
6941             return first;
6942         }
6943     }
6944     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
6945         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
6946     {
6947         const OP * const k1 = ((UNOP*)first)->op_first;
6948         const OP * const k2 = OpSIBLING(k1);
6949         OPCODE warnop = 0;
6950         switch (first->op_type)
6951         {
6952         case OP_NULL:
6953             if (k2 && k2->op_type == OP_READLINE
6954                   && (k2->op_flags & OPf_STACKED)
6955                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6956             {
6957                 warnop = k2->op_type;
6958             }
6959             break;
6960
6961         case OP_SASSIGN:
6962             if (k1->op_type == OP_READDIR
6963                   || k1->op_type == OP_GLOB
6964                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6965                  || k1->op_type == OP_EACH
6966                  || k1->op_type == OP_AEACH)
6967             {
6968                 warnop = ((k1->op_type == OP_NULL)
6969                           ? (OPCODE)k1->op_targ : k1->op_type);
6970             }
6971             break;
6972         }
6973         if (warnop) {
6974             const line_t oldline = CopLINE(PL_curcop);
6975             /* This ensures that warnings are reported at the first line
6976                of the construction, not the last.  */
6977             CopLINE_set(PL_curcop, PL_parser->copline);
6978             Perl_warner(aTHX_ packWARN(WARN_MISC),
6979                  "Value of %s%s can be \"0\"; test with defined()",
6980                  PL_op_desc[warnop],
6981                  ((warnop == OP_READLINE || warnop == OP_GLOB)
6982                   ? " construct" : "() operator"));
6983             CopLINE_set(PL_curcop, oldline);
6984         }
6985     }
6986
6987     if (!other)
6988         return first;
6989
6990     if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
6991         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
6992
6993     logop = S_alloc_LOGOP(aTHX_ type, first, LINKLIST(other));
6994     logop->op_flags |= (U8)flags;
6995     logop->op_private = (U8)(1 | (flags >> 8));
6996
6997     /* establish postfix order */
6998     logop->op_next = LINKLIST(first);
6999     first->op_next = (OP*)logop;
7000     assert(!OpHAS_SIBLING(first));
7001     op_sibling_splice((OP*)logop, first, 0, other);
7002
7003     CHECKOP(type,logop);
7004
7005     o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
7006                 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
7007                 (OP*)logop);
7008     other->op_next = o;
7009
7010     return o;
7011 }
7012
7013 /*
7014 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
7015
7016 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
7017 op.  I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
7018 will be set automatically, and, shifted up eight bits, the eight bits of
7019 C<op_private>, except that the bit with value 1 is automatically set.
7020 I<first> supplies the expression selecting between the two branches,
7021 and I<trueop> and I<falseop> supply the branches; they are consumed by
7022 this function and become part of the constructed op tree.
7023
7024 =cut
7025 */
7026
7027 OP *
7028 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
7029 {
7030     dVAR;
7031     LOGOP *logop;
7032     OP *start;
7033     OP *o;
7034     OP *cstop;
7035
7036     PERL_ARGS_ASSERT_NEWCONDOP;
7037
7038     if (!falseop)
7039         return newLOGOP(OP_AND, 0, first, trueop);
7040     if (!trueop)
7041         return newLOGOP(OP_OR, 0, first, falseop);
7042
7043     scalarboolean(first);
7044     if ((cstop = search_const(first))) {
7045         /* Left or right arm of the conditional?  */
7046         const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
7047         OP *live = left ? trueop : falseop;
7048         OP *const dead = left ? falseop : trueop;
7049         if (cstop->op_private & OPpCONST_BARE &&
7050             cstop->op_private & OPpCONST_STRICT) {
7051             no_bareword_allowed(cstop);
7052         }
7053         op_free(first);
7054         op_free(dead);
7055         if (live->op_type == OP_LEAVE)
7056             live = newUNOP(OP_NULL, OPf_SPECIAL, live);
7057         else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
7058               || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
7059             /* Mark the op as being unbindable with =~ */
7060             live->op_flags |= OPf_SPECIAL;
7061         live->op_folded = 1;
7062         return live;
7063     }
7064     logop = S_alloc_LOGOP(aTHX_ OP_COND_EXPR, first, LINKLIST(trueop));
7065     logop->op_flags |= (U8)flags;
7066     logop->op_private = (U8)(1 | (flags >> 8));
7067     logop->op_next = LINKLIST(falseop);
7068
7069     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
7070             logop);
7071
7072     /* establish postfix order */
7073     start = LINKLIST(first);
7074     first->op_next = (OP*)logop;
7075
7076     /* make first, trueop, falseop siblings */
7077     op_sibling_splice((OP*)logop, first,  0, trueop);
7078     op_sibling_splice((OP*)logop, trueop, 0, falseop);
7079
7080     o = newUNOP(OP_NULL, 0, (OP*)logop);
7081
7082     trueop->op_next = falseop->op_next = o;
7083
7084     o->op_next = start;
7085     return o;
7086 }
7087
7088 /*
7089 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
7090
7091 Constructs and returns a C<range> op, with subordinate C<flip> and
7092 C<flop> ops.  I<flags> gives the eight bits of C<op_flags> for the
7093 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
7094 for both the C<flip> and C<range> ops, except that the bit with value
7095 1 is automatically set.  I<left> and I<right> supply the expressions
7096 controlling the endpoints of the range; they are consumed by this function
7097 and become part of the constructed op tree.
7098
7099 =cut
7100 */
7101
7102 OP *
7103 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
7104 {
7105     LOGOP *range;
7106     OP *flip;
7107     OP *flop;
7108     OP *leftstart;
7109     OP *o;
7110
7111     PERL_ARGS_ASSERT_NEWRANGE;
7112
7113     range = S_alloc_LOGOP(aTHX_ OP_RANGE, left, LINKLIST(right));
7114     range->op_flags = OPf_KIDS;
7115     leftstart = LINKLIST(left);
7116     range->op_private = (U8)(1 | (flags >> 8));
7117
7118     /* make left and right siblings */
7119     op_sibling_splice((OP*)range, left, 0, right);
7120
7121     range->op_next = (OP*)range;
7122     flip = newUNOP(OP_FLIP, flags, (OP*)range);
7123     flop = newUNOP(OP_FLOP, 0, flip);
7124     o = newUNOP(OP_NULL, 0, flop);
7125     LINKLIST(flop);
7126     range->op_next = leftstart;
7127
7128     left->op_next = flip;
7129     right->op_next = flop;
7130
7131     range->op_targ =
7132         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
7133     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
7134     flip->op_targ =
7135         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
7136     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
7137     SvPADTMP_on(PAD_SV(flip->op_targ));
7138
7139     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
7140     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
7141
7142     /* check barewords before they might be optimized aways */
7143     if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
7144         no_bareword_allowed(left);
7145     if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
7146         no_bareword_allowed(right);
7147
7148     flip->op_next = o;
7149     if (!flip->op_private || !flop->op_private)
7150         LINKLIST(o);            /* blow off optimizer unless constant */
7151
7152     return o;
7153 }
7154
7155 /*
7156 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
7157
7158 Constructs, checks, and returns an op tree expressing a loop.  This is
7159 only a loop in the control flow through the op tree; it does not have
7160 the heavyweight loop structure that allows exiting the loop by C<last>
7161 and suchlike.  I<flags> gives the eight bits of C<op_flags> for the
7162 top-level op, except that some bits will be set automatically as required.
7163 I<expr> supplies the expression controlling loop iteration, and I<block>
7164 supplies the body of the loop; they are consumed by this function and
7165 become part of the constructed op tree.  I<debuggable> is currently
7166 unused and should always be 1.
7167
7168 =cut
7169 */
7170
7171 OP *
7172 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
7173 {
7174     OP* listop;
7175     OP* o;
7176     const bool once = block && block->op_flags & OPf_SPECIAL &&
7177                       block->op_type == OP_NULL;
7178
7179     PERL_UNUSED_ARG(debuggable);
7180
7181     if (expr) {
7182         if (once && (
7183               (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
7184            || (  expr->op_type == OP_NOT
7185               && cUNOPx(expr)->op_first->op_type == OP_CONST
7186               && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
7187               )
7188            ))
7189             /* Return the block now, so that S_new_logop does not try to
7190                fold it away. */
7191             return block;       /* do {} while 0 does once */
7192         if (expr->op_type == OP_READLINE
7193             || expr->op_type == OP_READDIR
7194             || expr->op_type == OP_GLOB
7195             || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
7196             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
7197             expr = newUNOP(OP_DEFINED, 0,
7198                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
7199         } else if (expr->op_flags & OPf_KIDS) {
7200             const OP * const k1 = ((UNOP*)expr)->op_first;
7201             const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
7202             switch (expr->op_type) {
7203               case OP_NULL:
7204                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
7205                       && (k2->op_flags & OPf_STACKED)
7206                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7207                     expr = newUNOP(OP_DEFINED, 0, expr);
7208                 break;
7209
7210               case OP_SASSIGN:
7211                 if (k1 && (k1->op_type == OP_READDIR
7212                       || k1->op_type == OP_GLOB
7213                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7214                      || k1->op_type == OP_EACH
7215                      || k1->op_type == OP_AEACH))
7216                     expr = newUNOP(OP_DEFINED, 0, expr);
7217                 break;
7218             }
7219         }
7220     }
7221
7222     /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
7223      * op, in listop. This is wrong. [perl #27024] */
7224     if (!block)
7225         block = newOP(OP_NULL, 0);
7226     listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
7227     o = new_logop(OP_AND, 0, &expr, &listop);
7228
7229     if (once) {
7230         ASSUME(listop);
7231     }
7232
7233     if (listop)
7234         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
7235
7236     if (once && o != listop)
7237     {
7238         assert(cUNOPo->op_first->op_type == OP_AND
7239             || cUNOPo->op_first->op_type == OP_OR);
7240         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
7241     }
7242
7243     if (o == listop)
7244         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
7245
7246     o->op_flags |= flags;
7247     o = op_scope(o);
7248     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
7249     return o;
7250 }
7251
7252 /*
7253 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
7254
7255 Constructs, checks, and returns an op tree expressing a C<while> loop.
7256 This is a heavyweight loop, with structure that allows exiting the loop
7257 by C<last> and suchlike.
7258
7259 I<loop> is an optional preconstructed C<enterloop> op to use in the
7260 loop; if it is null then a suitable op will be constructed automatically.
7261 I<expr> supplies the loop's controlling expression.  I<block> supplies the
7262 main body of the loop, and I<cont> optionally supplies a C<continue> block
7263 that operates as a second half of the body.  All of these optree inputs
7264 are consumed by this function and become part of the constructed op tree.
7265
7266 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7267 op and, shifted up eight bits, the eight bits of C<op_private> for
7268 the C<leaveloop> op, except that (in both cases) some bits will be set
7269 automatically.  I<debuggable> is currently unused and should always be 1.
7270 I<has_my> can be supplied as true to force the
7271 loop body to be enclosed in its own scope.
7272
7273 =cut
7274 */
7275
7276 OP *
7277 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
7278         OP *expr, OP *block, OP *cont, I32 has_my)
7279 {
7280     dVAR;
7281     OP *redo;
7282     OP *next = NULL;
7283     OP *listop;
7284     OP *o;
7285     U8 loopflags = 0;
7286
7287     PERL_UNUSED_ARG(debuggable);
7288
7289     if (expr) {
7290         if (expr->op_type == OP_READLINE
7291          || expr->op_type == OP_READDIR
7292          || expr->op_type == OP_GLOB
7293          || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
7294                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
7295             expr = newUNOP(OP_DEFINED, 0,
7296                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
7297         } else if (expr->op_flags & OPf_KIDS) {
7298             const OP * const k1 = ((UNOP*)expr)->op_first;
7299             const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
7300             switch (expr->op_type) {
7301               case OP_NULL:
7302                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
7303                       && (k2->op_flags & OPf_STACKED)
7304                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7305                     expr = newUNOP(OP_DEFINED, 0, expr);
7306                 break;
7307
7308               case OP_SASSIGN:
7309                 if (k1 && (k1->op_type == OP_READDIR
7310                       || k1->op_type == OP_GLOB
7311                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7312                      || k1->op_type == OP_EACH
7313                      || k1->op_type == OP_AEACH))
7314                     expr = newUNOP(OP_DEFINED, 0, expr);
7315                 break;
7316             }
7317         }
7318     }
7319
7320     if (!block)
7321         block = newOP(OP_NULL, 0);
7322     else if (cont || has_my) {
7323         block = op_scope(block);
7324     }
7325
7326     if (cont) {
7327         next = LINKLIST(cont);
7328     }
7329     if (expr) {
7330         OP * const unstack = newOP(OP_UNSTACK, 0);
7331         if (!next)
7332             next = unstack;
7333         cont = op_append_elem(OP_LINESEQ, cont, unstack);
7334     }
7335
7336     assert(block);
7337     listop = op_append_list(OP_LINESEQ, block, cont);
7338     assert(listop);
7339     redo = LINKLIST(listop);
7340
7341     if (expr) {
7342         scalar(listop);
7343         o = new_logop(OP_AND, 0, &expr, &listop);
7344         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
7345             op_free((OP*)loop);
7346             return expr;                /* listop already freed by new_logop */
7347         }
7348         if (listop)
7349             ((LISTOP*)listop)->op_last->op_next =
7350                 (o == listop ? redo : LINKLIST(o));
7351     }
7352     else
7353         o = listop;
7354
7355     if (!loop) {
7356         NewOp(1101,loop,1,LOOP);
7357         OpTYPE_set(loop, OP_ENTERLOOP);
7358         loop->op_private = 0;
7359         loop->op_next = (OP*)loop;
7360     }
7361
7362     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
7363
7364     loop->op_redoop = redo;
7365     loop->op_lastop = o;
7366     o->op_private |= loopflags;
7367
7368     if (next)
7369         loop->op_nextop = next;
7370     else
7371         loop->op_nextop = o;
7372
7373     o->op_flags |= flags;
7374     o->op_private |= (flags >> 8);
7375     return o;
7376 }
7377
7378 /*
7379 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
7380
7381 Constructs, checks, and returns an op tree expressing a C<foreach>
7382 loop (iteration through a list of values).  This is a heavyweight loop,
7383 with structure that allows exiting the loop by C<last> and suchlike.
7384
7385 I<sv> optionally supplies the variable that will be aliased to each
7386 item in turn; if null, it defaults to C<$_> (either lexical or global).
7387 I<expr> supplies the list of values to iterate over.  I<block> supplies
7388 the main body of the loop, and I<cont> optionally supplies a C<continue>
7389 block that operates as a second half of the body.  All of these optree
7390 inputs are consumed by this function and become part of the constructed
7391 op tree.
7392
7393 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7394 op and, shifted up eight bits, the eight bits of C<op_private> for
7395 the C<leaveloop> op, except that (in both cases) some bits will be set
7396 automatically.
7397
7398 =cut
7399 */
7400
7401 OP *
7402 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
7403 {
7404     dVAR;
7405     LOOP *loop;
7406     OP *wop;
7407     PADOFFSET padoff = 0;
7408     I32 iterflags = 0;
7409     I32 iterpflags = 0;
7410
7411     PERL_ARGS_ASSERT_NEWFOROP;
7412
7413     if (sv) {
7414         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
7415             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
7416             OpTYPE_set(sv, OP_RV2GV);
7417
7418             /* The op_type check is needed to prevent a possible segfault
7419              * if the loop variable is undeclared and 'strict vars' is in
7420              * effect. This is illegal but is nonetheless parsed, so we
7421              * may reach this point with an OP_CONST where we're expecting
7422              * an OP_GV.
7423              */
7424             if (cUNOPx(sv)->op_first->op_type == OP_GV
7425              && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
7426                 iterpflags |= OPpITER_DEF;
7427         }
7428         else if (sv->op_type == OP_PADSV) { /* private variable */
7429             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
7430             padoff = sv->op_targ;
7431             sv->op_targ = 0;
7432             op_free(sv);
7433             sv = NULL;
7434             PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
7435         }
7436         else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
7437             NOOP;
7438         else
7439             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
7440         if (padoff) {
7441             PADNAME * const pn = PAD_COMPNAME(padoff);
7442             const char * const name = PadnamePV(pn);
7443
7444             if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
7445                 iterpflags |= OPpITER_DEF;
7446         }
7447     }
7448     else {
7449         const PADOFFSET offset = pad_findmy_pvs("$_", 0);
7450         if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7451             sv = newGVOP(OP_GV, 0, PL_defgv);
7452         }
7453         else {
7454             padoff = offset;
7455         }
7456         iterpflags |= OPpITER_DEF;
7457     }
7458
7459     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
7460         expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
7461         iterflags |= OPf_STACKED;
7462     }
7463     else if (expr->op_type == OP_NULL &&
7464              (expr->op_flags & OPf_KIDS) &&
7465              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
7466     {
7467         /* Basically turn for($x..$y) into the same as for($x,$y), but we
7468          * set the STACKED flag to indicate that these values are to be
7469          * treated as min/max values by 'pp_enteriter'.
7470          */
7471         const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
7472         LOGOP* const range = (LOGOP*) flip->op_first;
7473         OP* const left  = range->op_first;
7474         OP* const right = OpSIBLING(left);
7475         LISTOP* listop;
7476
7477         range->op_flags &= ~OPf_KIDS;
7478         /* detach range's children */
7479         op_sibling_splice((OP*)range, NULL, -1, NULL);
7480
7481         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
7482         listop->op_first->op_next = range->op_next;
7483         left->op_next = range->op_other;
7484         right->op_next = (OP*)listop;
7485         listop->op_next = listop->op_first;
7486
7487         op_free(expr);
7488         expr = (OP*)(listop);
7489         op_null(expr);
7490         iterflags |= OPf_STACKED;
7491     }
7492     else {
7493         expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
7494     }
7495
7496     loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
7497                                   op_append_elem(OP_LIST, list(expr),
7498                                                  scalar(sv)));
7499     assert(!loop->op_next);
7500     /* for my  $x () sets OPpLVAL_INTRO;
7501      * for our $x () sets OPpOUR_INTRO */
7502     loop->op_private = (U8)iterpflags;
7503     if (loop->op_slabbed
7504      && DIFF(loop, OpSLOT(loop)->opslot_next)
7505          < SIZE_TO_PSIZE(sizeof(LOOP)))
7506     {
7507         LOOP *tmp;
7508         NewOp(1234,tmp,1,LOOP);
7509         Copy(loop,tmp,1,LISTOP);
7510 #ifdef PERL_OP_PARENT
7511         assert(loop->op_last->op_sibparent == (OP*)loop);
7512         OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
7513 #endif
7514         S_op_destroy(aTHX_ (OP*)loop);
7515         loop = tmp;
7516     }
7517     else if (!loop->op_slabbed)
7518     {
7519         loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
7520 #ifdef PERL_OP_PARENT
7521         OpLASTSIB_set(loop->op_last, (OP*)loop);
7522 #endif
7523     }
7524     loop->op_targ = padoff;
7525     wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
7526     return wop;
7527 }
7528
7529 /*
7530 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
7531
7532 Constructs, checks, and returns a loop-exiting op (such as C<goto>
7533 or C<last>).  I<type> is the opcode.  I<label> supplies the parameter
7534 determining the target of the op; it is consumed by this function and
7535 becomes part of the constructed op tree.
7536
7537 =cut
7538 */
7539
7540 OP*
7541 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
7542 {
7543     OP *o = NULL;
7544
7545     PERL_ARGS_ASSERT_NEWLOOPEX;
7546
7547     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
7548         || type == OP_CUSTOM);
7549
7550     if (type != OP_GOTO) {
7551         /* "last()" means "last" */
7552         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
7553             o = newOP(type, OPf_SPECIAL);
7554         }
7555     }
7556     else {
7557         /* Check whether it's going to be a goto &function */
7558         if (label->op_type == OP_ENTERSUB
7559                 && !(label->op_flags & OPf_STACKED))
7560             label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
7561     }
7562
7563     /* Check for a constant argument */
7564     if (label->op_type == OP_CONST) {
7565             SV * const sv = ((SVOP *)label)->op_sv;
7566             STRLEN l;
7567             const char *s = SvPV_const(sv,l);
7568             if (l == strlen(s)) {
7569                 o = newPVOP(type,
7570                             SvUTF8(((SVOP*)label)->op_sv),
7571                             savesharedpv(
7572                                 SvPV_nolen_const(((SVOP*)label)->op_sv)));
7573             }
7574     }
7575
7576     /* If we have already created an op, we do not need the label. */
7577     if (o)
7578                 op_free(label);
7579     else o = newUNOP(type, OPf_STACKED, label);
7580
7581     PL_hints |= HINT_BLOCK_SCOPE;
7582     return o;
7583 }
7584
7585 /* if the condition is a literal array or hash
7586    (or @{ ... } etc), make a reference to it.
7587  */
7588 STATIC OP *
7589 S_ref_array_or_hash(pTHX_ OP *cond)
7590 {
7591     if (cond
7592     && (cond->op_type == OP_RV2AV
7593     ||  cond->op_type == OP_PADAV
7594     ||  cond->op_type == OP_RV2HV
7595     ||  cond->op_type == OP_PADHV))
7596
7597         return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
7598
7599     else if(cond
7600     && (cond->op_type == OP_ASLICE
7601     ||  cond->op_type == OP_KVASLICE
7602     ||  cond->op_type == OP_HSLICE
7603     ||  cond->op_type == OP_KVHSLICE)) {
7604
7605         /* anonlist now needs a list from this op, was previously used in
7606          * scalar context */
7607         cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
7608         cond->op_flags |= OPf_WANT_LIST;
7609
7610         return newANONLIST(op_lvalue(cond, OP_ANONLIST));
7611     }
7612
7613     else
7614         return cond;
7615 }
7616
7617 /* These construct the optree fragments representing given()
7618    and when() blocks.
7619
7620    entergiven and enterwhen are LOGOPs; the op_other pointer
7621    points up to the associated leave op. We need this so we
7622    can put it in the context and make break/continue work.
7623    (Also, of course, pp_enterwhen will jump straight to
7624    op_other if the match fails.)
7625  */
7626
7627 STATIC OP *
7628 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
7629                    I32 enter_opcode, I32 leave_opcode,
7630                    PADOFFSET entertarg)
7631 {
7632     dVAR;
7633     LOGOP *enterop;
7634     OP *o;
7635
7636     PERL_ARGS_ASSERT_NEWGIVWHENOP;
7637
7638     enterop = S_alloc_LOGOP(aTHX_ enter_opcode, block, NULL);
7639     enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
7640     enterop->op_private = 0;
7641
7642     o = newUNOP(leave_opcode, 0, (OP *) enterop);
7643
7644     if (cond) {
7645         /* prepend cond if we have one */
7646         op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
7647
7648         o->op_next = LINKLIST(cond);
7649         cond->op_next = (OP *) enterop;
7650     }
7651     else {
7652         /* This is a default {} block */
7653         enterop->op_flags |= OPf_SPECIAL;
7654         o      ->op_flags |= OPf_SPECIAL;
7655
7656         o->op_next = (OP *) enterop;
7657     }
7658
7659     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
7660                                        entergiven and enterwhen both
7661                                        use ck_null() */
7662
7663     enterop->op_next = LINKLIST(block);
7664     block->op_next = enterop->op_other = o;
7665
7666     return o;
7667 }
7668
7669 /* Does this look like a boolean operation? For these purposes
7670    a boolean operation is:
7671      - a subroutine call [*]
7672      - a logical connective
7673      - a comparison operator
7674      - a filetest operator, with the exception of -s -M -A -C
7675      - defined(), exists() or eof()
7676      - /$re/ or $foo =~ /$re/
7677
7678    [*] possibly surprising
7679  */
7680 STATIC bool
7681 S_looks_like_bool(pTHX_ const OP *o)
7682 {
7683     PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
7684
7685     switch(o->op_type) {
7686         case OP_OR:
7687         case OP_DOR:
7688             return looks_like_bool(cLOGOPo->op_first);
7689
7690         case OP_AND:
7691         {
7692             OP* sibl = OpSIBLING(cLOGOPo->op_first);
7693             ASSUME(sibl);
7694             return (
7695                 looks_like_bool(cLOGOPo->op_first)
7696              && looks_like_bool(sibl));
7697         }
7698
7699         case OP_NULL:
7700         case OP_SCALAR:
7701             return (
7702                 o->op_flags & OPf_KIDS
7703             && looks_like_bool(cUNOPo->op_first));
7704
7705         case OP_ENTERSUB:
7706
7707         case OP_NOT:    case OP_XOR:
7708
7709         case OP_EQ:     case OP_NE:     case OP_LT:
7710         case OP_GT:     case OP_LE:     case OP_GE:
7711
7712         case OP_I_EQ:   case OP_I_NE:   case OP_I_LT:
7713         case OP_I_GT:   case OP_I_LE:   case OP_I_GE:
7714
7715         case OP_SEQ:    case OP_SNE:    case OP_SLT:
7716         case OP_SGT:    case OP_SLE:    case OP_SGE:
7717
7718         case OP_SMARTMATCH:
7719
7720         case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
7721         case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
7722         case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
7723         case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
7724         case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
7725         case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
7726         case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
7727         case OP_FTTEXT:   case OP_FTBINARY:
7728
7729         case OP_DEFINED: case OP_EXISTS:
7730         case OP_MATCH:   case OP_EOF:
7731
7732         case OP_FLOP:
7733
7734             return TRUE;
7735
7736         case OP_CONST:
7737             /* Detect comparisons that have been optimized away */
7738             if (cSVOPo->op_sv == &PL_sv_yes
7739             ||  cSVOPo->op_sv == &PL_sv_no)
7740
7741                 return TRUE;
7742             else
7743                 return FALSE;
7744
7745         /* FALLTHROUGH */
7746         default:
7747             return FALSE;
7748     }
7749 }
7750
7751 /*
7752 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
7753
7754 Constructs, checks, and returns an op tree expressing a C<given> block.
7755 I<cond> supplies the expression that will be locally assigned to a lexical
7756 variable, and I<block> supplies the body of the C<given> construct; they
7757 are consumed by this function and become part of the constructed op tree.
7758 I<defsv_off> is the pad offset of the scalar lexical variable that will
7759 be affected.  If it is 0, the global $_ will be used.
7760
7761 =cut
7762 */
7763
7764 OP *
7765 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
7766 {
7767     PERL_ARGS_ASSERT_NEWGIVENOP;
7768     return newGIVWHENOP(
7769         ref_array_or_hash(cond),
7770         block,
7771         OP_ENTERGIVEN, OP_LEAVEGIVEN,
7772         defsv_off);
7773 }
7774
7775 /*
7776 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
7777
7778 Constructs, checks, and returns an op tree expressing a C<when> block.
7779 I<cond> supplies the test expression, and I<block> supplies the block
7780 that will be executed if the test evaluates to true; they are consumed
7781 by this function and become part of the constructed op tree.  I<cond>
7782 will be interpreted DWIMically, often as a comparison against C<$_>,
7783 and may be null to generate a C<default> block.
7784
7785 =cut
7786 */
7787
7788 OP *
7789 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
7790 {
7791     const bool cond_llb = (!cond || looks_like_bool(cond));
7792     OP *cond_op;
7793
7794     PERL_ARGS_ASSERT_NEWWHENOP;
7795
7796     if (cond_llb)
7797         cond_op = cond;
7798     else {
7799         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
7800                 newDEFSVOP(),
7801                 scalar(ref_array_or_hash(cond)));
7802     }
7803
7804     return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
7805 }
7806
7807 /* must not conflict with SVf_UTF8 */
7808 #define CV_CKPROTO_CURSTASH     0x1
7809
7810 void
7811 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
7812                     const STRLEN len, const U32 flags)
7813 {
7814     SV *name = NULL, *msg;
7815     const char * cvp = SvROK(cv)
7816                         ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
7817                            ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
7818                            : ""
7819                         : CvPROTO(cv);
7820     STRLEN clen = CvPROTOLEN(cv), plen = len;
7821
7822     PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
7823
7824     if (p == NULL && cvp == NULL)
7825         return;
7826
7827     if (!ckWARN_d(WARN_PROTOTYPE))
7828         return;
7829
7830     if (p && cvp) {
7831         p = S_strip_spaces(aTHX_ p, &plen);
7832         cvp = S_strip_spaces(aTHX_ cvp, &clen);
7833         if ((flags & SVf_UTF8) == SvUTF8(cv)) {
7834             if (plen == clen && memEQ(cvp, p, plen))
7835                 return;
7836         } else {
7837             if (flags & SVf_UTF8) {
7838                 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
7839                     return;
7840             }
7841             else {
7842                 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
7843                     return;
7844             }
7845         }
7846     }
7847
7848     msg = sv_newmortal();
7849
7850     if (gv)
7851     {
7852         if (isGV(gv))
7853             gv_efullname3(name = sv_newmortal(), gv, NULL);
7854         else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
7855             name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
7856         else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
7857             name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
7858             sv_catpvs(name, "::");
7859             if (SvROK(gv)) {
7860                 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
7861                 assert (CvNAMED(SvRV_const(gv)));
7862                 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
7863             }
7864             else sv_catsv(name, (SV *)gv);
7865         }
7866         else name = (SV *)gv;
7867     }
7868     sv_setpvs(msg, "Prototype mismatch:");
7869     if (name)
7870         Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
7871     if (cvp)
7872         Perl_sv_catpvf(aTHX_ msg, " (%"UTF8f")",
7873             UTF8fARG(SvUTF8(cv),clen,cvp)
7874         );
7875     else
7876         sv_catpvs(msg, ": none");
7877     sv_catpvs(msg, " vs ");
7878     if (p)
7879         Perl_sv_catpvf(aTHX_ msg, "(%"UTF8f")", UTF8fARG(flags & SVf_UTF8,len,p));
7880     else
7881         sv_catpvs(msg, "none");
7882     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
7883 }
7884
7885 static void const_sv_xsub(pTHX_ CV* cv);
7886 static void const_av_xsub(pTHX_ CV* cv);
7887
7888 /*
7889
7890 =head1 Optree Manipulation Functions
7891
7892 =for apidoc cv_const_sv
7893
7894 If C<cv> is a constant sub eligible for inlining, returns the constant
7895 value returned by the sub.  Otherwise, returns NULL.
7896
7897 Constant subs can be created with C<newCONSTSUB> or as described in
7898 L<perlsub/"Constant Functions">.
7899
7900 =cut
7901 */
7902 SV *
7903 Perl_cv_const_sv(const CV *const cv)
7904 {
7905     SV *sv;
7906     if (!cv)
7907         return NULL;
7908     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
7909         return NULL;
7910     sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7911     if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
7912     return sv;
7913 }
7914
7915 SV *
7916 Perl_cv_const_sv_or_av(const CV * const cv)
7917 {
7918     if (!cv)
7919         return NULL;
7920     if (SvROK(cv)) return SvRV((SV *)cv);
7921     assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
7922     return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7923 }
7924
7925 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
7926  * Can be called in 2 ways:
7927  *
7928  * !allow_lex
7929  *      look for a single OP_CONST with attached value: return the value
7930  *
7931  * allow_lex && !CvCONST(cv);
7932  *
7933  *      examine the clone prototype, and if contains only a single
7934  *      OP_CONST, return the value; or if it contains a single PADSV ref-
7935  *      erencing an outer lexical, turn on CvCONST to indicate the CV is
7936  *      a candidate for "constizing" at clone time, and return NULL.
7937  */
7938
7939 static SV *
7940 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
7941 {
7942     SV *sv = NULL;
7943     bool padsv = FALSE;
7944
7945     assert(o);
7946     assert(cv);
7947
7948     for (; o; o = o->op_next) {
7949         const OPCODE type = o->op_type;
7950
7951         if (type == OP_NEXTSTATE || type == OP_LINESEQ
7952              || type == OP_NULL
7953              || type == OP_PUSHMARK)
7954                 continue;
7955         if (type == OP_DBSTATE)
7956                 continue;
7957         if (type == OP_LEAVESUB)
7958             break;
7959         if (sv)
7960             return NULL;
7961         if (type == OP_CONST && cSVOPo->op_sv)
7962             sv = cSVOPo->op_sv;
7963         else if (type == OP_UNDEF && !o->op_private) {
7964             sv = newSV(0);
7965             SAVEFREESV(sv);
7966         }
7967         else if (allow_lex && type == OP_PADSV) {
7968                 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
7969                 {
7970                     sv = &PL_sv_undef; /* an arbitrary non-null value */
7971                     padsv = TRUE;
7972                 }
7973                 else
7974                     return NULL;
7975         }
7976         else {
7977             return NULL;
7978         }
7979     }
7980     if (padsv) {
7981         CvCONST_on(cv);
7982         return NULL;
7983     }
7984     return sv;
7985 }
7986
7987 static bool
7988 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
7989                         PADNAME * const name, SV ** const const_svp)
7990 {
7991     assert (cv);
7992     assert (o || name);
7993     assert (const_svp);
7994     if ((!block
7995          )) {
7996         if (CvFLAGS(PL_compcv)) {
7997             /* might have had built-in attrs applied */
7998             const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
7999             if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
8000              && ckWARN(WARN_MISC))
8001             {
8002                 /* protect against fatal warnings leaking compcv */
8003                 SAVEFREESV(PL_compcv);
8004                 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
8005                 SvREFCNT_inc_simple_void_NN(PL_compcv);
8006             }
8007             CvFLAGS(cv) |=
8008                 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
8009                   & ~(CVf_LVALUE * pureperl));
8010         }
8011         return FALSE;
8012     }
8013
8014     /* redundant check for speed: */
8015     if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
8016         const line_t oldline = CopLINE(PL_curcop);
8017         SV *namesv = o
8018             ? cSVOPo->op_sv
8019             : sv_2mortal(newSVpvn_utf8(
8020                 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
8021               ));
8022         if (PL_parser && PL_parser->copline != NOLINE)
8023             /* This ensures that warnings are reported at the first
8024                line of a redefinition, not the last.  */
8025             CopLINE_set(PL_curcop, PL_parser->copline);
8026         /* protect against fatal warnings leaking compcv */
8027         SAVEFREESV(PL_compcv);
8028         report_redefined_cv(namesv, cv, const_svp);
8029         SvREFCNT_inc_simple_void_NN(PL_compcv);
8030         CopLINE_set(PL_curcop, oldline);
8031     }
8032     SAVEFREESV(cv);
8033     return TRUE;
8034 }
8035
8036 CV *
8037 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
8038 {
8039     CV **spot;
8040     SV **svspot;
8041     const char *ps;
8042     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
8043     U32 ps_utf8 = 0;
8044     CV *cv = NULL;
8045     CV *compcv = PL_compcv;
8046     SV *const_sv;
8047     PADNAME *name;
8048     PADOFFSET pax = o->op_targ;
8049     CV *outcv = CvOUTSIDE(PL_compcv);
8050     CV *clonee = NULL;
8051     HEK *hek = NULL;
8052     bool reusable = FALSE;
8053     OP *start = NULL;
8054 #ifdef PERL_DEBUG_READONLY_OPS
8055     OPSLAB *slab = NULL;
8056 #endif
8057
8058     PERL_ARGS_ASSERT_NEWMYSUB;
8059
8060     /* Find the pad slot for storing the new sub.
8061        We cannot use PL_comppad, as it is the pad owned by the new sub.  We
8062        need to look in CvOUTSIDE and find the pad belonging to the enclos-
8063        ing sub.  And then we need to dig deeper if this is a lexical from
8064        outside, as in:
8065            my sub foo; sub { sub foo { } }
8066      */
8067    redo:
8068     name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
8069     if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
8070         pax = PARENT_PAD_INDEX(name);
8071         outcv = CvOUTSIDE(outcv);
8072         assert(outcv);
8073         goto redo;
8074     }
8075     svspot =
8076         &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
8077                         [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
8078     spot = (CV **)svspot;
8079
8080     if (!(PL_parser && PL_parser->error_count))
8081         move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name));
8082
8083     if (proto) {
8084         assert(proto->op_type == OP_CONST);
8085         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
8086         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
8087     }
8088     else
8089         ps = NULL;
8090
8091     if (proto)
8092         SAVEFREEOP(proto);
8093     if (attrs)
8094         SAVEFREEOP(attrs);
8095
8096     if (PL_parser && PL_parser->error_count) {
8097         op_free(block);
8098         SvREFCNT_dec(PL_compcv);
8099         PL_compcv = 0;
8100         goto done;
8101     }
8102
8103     if (CvDEPTH(outcv) && CvCLONE(compcv)) {
8104         cv = *spot;
8105         svspot = (SV **)(spot = &clonee);
8106     }
8107     else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
8108         cv = *spot;
8109     else {
8110         assert (SvTYPE(*spot) == SVt_PVCV);
8111         if (CvNAMED(*spot))
8112             hek = CvNAME_HEK(*spot);
8113         else {
8114             dVAR;
8115             U32 hash;
8116             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
8117             CvNAME_HEK_set(*spot, hek =
8118                 share_hek(
8119                     PadnamePV(name)+1,
8120                     (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
8121                     hash
8122                 )
8123             );
8124             CvLEXICAL_on(*spot);
8125         }
8126         cv = PadnamePROTOCV(name);
8127         svspot = (SV **)(spot = &PadnamePROTOCV(name));
8128     }
8129
8130     if (block) {
8131         /* This makes sub {}; work as expected.  */
8132         if (block->op_type == OP_STUB) {
8133             const line_t l = PL_parser->copline;
8134             op_free(block);
8135             block = newSTATEOP(0, NULL, 0);
8136             PL_parser->copline = l;
8137         }
8138         block = CvLVALUE(compcv)
8139              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
8140                    ? newUNOP(OP_LEAVESUBLV, 0,
8141                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
8142                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
8143         start = LINKLIST(block);
8144         block->op_next = 0;
8145     }
8146
8147     if (!block || !ps || *ps || attrs
8148         || CvLVALUE(compcv)
8149         )
8150         const_sv = NULL;
8151     else
8152         const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
8153
8154     if (cv) {
8155         const bool exists = CvROOT(cv) || CvXSUB(cv);
8156
8157         /* if the subroutine doesn't exist and wasn't pre-declared
8158          * with a prototype, assume it will be AUTOLOADed,
8159          * skipping the prototype check
8160          */
8161         if (exists || SvPOK(cv))
8162             cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
8163                                  ps_utf8);
8164         /* already defined? */
8165         if (exists) {
8166             if (S_already_defined(aTHX_ cv,block,NULL,name,&const_sv))
8167                 cv = NULL;
8168             else {
8169                 if (attrs) goto attrs;
8170                 /* just a "sub foo;" when &foo is already defined */
8171                 SAVEFREESV(compcv);
8172                 goto done;
8173             }
8174         }
8175         else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
8176             cv = NULL;
8177             reusable = TRUE;
8178         }
8179     }
8180     if (const_sv) {
8181         SvREFCNT_inc_simple_void_NN(const_sv);
8182         SvFLAGS(const_sv) |= SVs_PADTMP;
8183         if (cv) {
8184             assert(!CvROOT(cv) && !CvCONST(cv));
8185             cv_forget_slab(cv);
8186         }
8187         else {
8188             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8189             CvFILE_set_from_cop(cv, PL_curcop);
8190             CvSTASH_set(cv, PL_curstash);
8191             *spot = cv;
8192         }
8193         sv_setpvs(MUTABLE_SV(cv), "");  /* prototype is "" */
8194         CvXSUBANY(cv).any_ptr = const_sv;
8195         CvXSUB(cv) = const_sv_xsub;
8196         CvCONST_on(cv);
8197         CvISXSUB_on(cv);
8198         PoisonPADLIST(cv);
8199         CvFLAGS(cv) |= CvMETHOD(compcv);
8200         op_free(block);
8201         SvREFCNT_dec(compcv);
8202         PL_compcv = NULL;
8203         goto setname;
8204     }
8205     /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
8206        determine whether this sub definition is in the same scope as its
8207        declaration.  If this sub definition is inside an inner named pack-
8208        age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
8209        the package sub.  So check PadnameOUTER(name) too.
8210      */
8211     if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
8212         assert(!CvWEAKOUTSIDE(compcv));
8213         SvREFCNT_dec(CvOUTSIDE(compcv));
8214         CvWEAKOUTSIDE_on(compcv);
8215     }
8216     /* XXX else do we have a circular reference? */
8217     if (cv) {   /* must reuse cv in case stub is referenced elsewhere */
8218         /* transfer PL_compcv to cv */
8219         if (block
8220         ) {
8221             cv_flags_t preserved_flags =
8222                 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
8223             PADLIST *const temp_padl = CvPADLIST(cv);
8224             CV *const temp_cv = CvOUTSIDE(cv);
8225             const cv_flags_t other_flags =
8226                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8227             OP * const cvstart = CvSTART(cv);
8228
8229             SvPOK_off(cv);
8230             CvFLAGS(cv) =
8231                 CvFLAGS(compcv) | preserved_flags;
8232             CvOUTSIDE(cv) = CvOUTSIDE(compcv);
8233             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
8234             CvPADLIST_set(cv, CvPADLIST(compcv));
8235             CvOUTSIDE(compcv) = temp_cv;
8236             CvPADLIST_set(compcv, temp_padl);
8237             CvSTART(cv) = CvSTART(compcv);
8238             CvSTART(compcv) = cvstart;
8239             CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8240             CvFLAGS(compcv) |= other_flags;
8241
8242             if (CvFILE(cv) && CvDYNFILE(cv)) {
8243                 Safefree(CvFILE(cv));
8244             }
8245
8246             /* inner references to compcv must be fixed up ... */
8247             pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
8248             if (PERLDB_INTER)/* Advice debugger on the new sub. */
8249               ++PL_sub_generation;
8250         }
8251         else {
8252             /* Might have had built-in attributes applied -- propagate them. */
8253             CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
8254         }
8255         /* ... before we throw it away */
8256         SvREFCNT_dec(compcv);
8257         PL_compcv = compcv = cv;
8258     }
8259     else {
8260         cv = compcv;
8261         *spot = cv;
8262     }
8263    setname:
8264     CvLEXICAL_on(cv);
8265     if (!CvNAME_HEK(cv)) {
8266         if (hek) (void)share_hek_hek(hek);
8267         else {
8268             dVAR;
8269             U32 hash;
8270             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
8271             hek = share_hek(PadnamePV(name)+1,
8272                       (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
8273                       hash);
8274         }
8275         CvNAME_HEK_set(cv, hek);
8276     }
8277     if (const_sv) goto clone;
8278
8279     CvFILE_set_from_cop(cv, PL_curcop);
8280     CvSTASH_set(cv, PL_curstash);
8281
8282     if (ps) {
8283         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8284         if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
8285     }
8286
8287     if (!block)
8288         goto attrs;
8289
8290     /* If we assign an optree to a PVCV, then we've defined a subroutine that
8291        the debugger could be able to set a breakpoint in, so signal to
8292        pp_entereval that it should not throw away any saved lines at scope
8293        exit.  */
8294
8295     PL_breakable_sub_gen++;
8296     CvROOT(cv) = block;
8297     CvROOT(cv)->op_private |= OPpREFCOUNTED;
8298     OpREFCNT_set(CvROOT(cv), 1);
8299     /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8300        itself has a refcount. */
8301     CvSLABBED_off(cv);
8302     OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8303 #ifdef PERL_DEBUG_READONLY_OPS
8304     slab = (OPSLAB *)CvSTART(cv);
8305 #endif
8306     CvSTART(cv) = start;
8307     CALL_PEEP(start);
8308     finalize_optree(CvROOT(cv));
8309     S_prune_chain_head(&CvSTART(cv));
8310
8311     /* now that optimizer has done its work, adjust pad values */
8312
8313     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8314
8315   attrs:
8316     if (attrs) {
8317         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8318         apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
8319     }
8320
8321     if (block) {
8322         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8323             SV * const tmpstr = sv_newmortal();
8324             GV * const db_postponed = gv_fetchpvs("DB::postponed",
8325                                                   GV_ADDMULTI, SVt_PVHV);
8326             HV *hv;
8327             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8328                                           CopFILE(PL_curcop),
8329                                           (long)PL_subline,
8330                                           (long)CopLINE(PL_curcop));
8331             if (HvNAME_HEK(PL_curstash)) {
8332                 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
8333                 sv_catpvs(tmpstr, "::");
8334             }
8335             else sv_setpvs(tmpstr, "__ANON__::");
8336             sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
8337                             PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
8338             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8339                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8340             hv = GvHVn(db_postponed);
8341             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8342                 CV * const pcv = GvCV(db_postponed);
8343                 if (pcv) {
8344                     dSP;
8345                     PUSHMARK(SP);
8346                     XPUSHs(tmpstr);
8347                     PUTBACK;
8348                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
8349                 }
8350             }
8351         }
8352     }
8353
8354   clone:
8355     if (clonee) {
8356         assert(CvDEPTH(outcv));
8357         spot = (CV **)
8358             &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
8359         if (reusable) cv_clone_into(clonee, *spot);
8360         else *spot = cv_clone(clonee);
8361         SvREFCNT_dec_NN(clonee);
8362         cv = *spot;
8363     }
8364     if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
8365         PADOFFSET depth = CvDEPTH(outcv);
8366         while (--depth) {
8367             SV *oldcv;
8368             svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
8369             oldcv = *svspot;
8370             *svspot = SvREFCNT_inc_simple_NN(cv);
8371             SvREFCNT_dec(oldcv);
8372         }
8373     }
8374
8375   done:
8376     if (PL_parser)
8377         PL_parser->copline = NOLINE;
8378     LEAVE_SCOPE(floor);
8379 #ifdef PERL_DEBUG_READONLY_OPS
8380     if (slab)
8381         Slab_to_ro(slab);
8382 #endif
8383     op_free(o);
8384     return cv;
8385 }
8386
8387 /* _x = extended */
8388 CV *
8389 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
8390                             OP *block, bool o_is_gv)
8391 {
8392     GV *gv;
8393     const char *ps;
8394     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
8395     U32 ps_utf8 = 0;
8396     CV *cv = NULL;
8397     SV *const_sv;
8398     const bool ec = PL_parser && PL_parser->error_count;
8399     /* If the subroutine has no body, no attributes, and no builtin attributes
8400        then it's just a sub declaration, and we may be able to get away with
8401        storing with a placeholder scalar in the symbol table, rather than a
8402        full CV.  If anything is present then it will take a full CV to
8403        store it.  */
8404     const I32 gv_fetch_flags
8405         = ec ? GV_NOADD_NOINIT :
8406         (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
8407         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
8408     STRLEN namlen = 0;
8409     const char * const name =
8410          o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
8411     bool has_name;
8412     bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
8413     bool evanescent = FALSE;
8414     OP *start = NULL;
8415 #ifdef PERL_DEBUG_READONLY_OPS
8416     OPSLAB *slab = NULL;
8417 #endif
8418
8419     if (o_is_gv) {
8420         gv = (GV*)o;
8421         o = NULL;
8422         has_name = TRUE;
8423     } else if (name) {
8424         /* Try to optimise and avoid creating a GV.  Instead, the CV’s name
8425            hek and CvSTASH pointer together can imply the GV.  If the name
8426            contains a package name, then GvSTASH(CvGV(cv)) may differ from
8427            CvSTASH, so forego the optimisation if we find any.
8428            Also, we may be called from load_module at run time, so
8429            PL_curstash (which sets CvSTASH) may not point to the stash the
8430            sub is stored in.  */
8431         const I32 flags =
8432            ec ? GV_NOADD_NOINIT
8433               :   PL_curstash != CopSTASH(PL_curcop)
8434                || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
8435                     ? gv_fetch_flags
8436                     : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
8437         gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
8438         has_name = TRUE;
8439     } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
8440         SV * const sv = sv_newmortal();
8441         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
8442                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
8443                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
8444         gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
8445         has_name = TRUE;
8446     } else if (PL_curstash) {
8447         gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
8448         has_name = FALSE;
8449     } else {
8450         gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
8451         has_name = FALSE;
8452     }
8453     if (!ec)
8454         move_proto_attr(&proto, &attrs,
8455                         isGV(gv) ? gv : (GV *)cSVOPo->op_sv);
8456
8457     if (proto) {
8458         assert(proto->op_type == OP_CONST);
8459         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
8460         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
8461     }
8462     else
8463         ps = NULL;
8464
8465     if (o)
8466         SAVEFREEOP(o);
8467     if (proto)
8468         SAVEFREEOP(proto);
8469     if (attrs)
8470         SAVEFREEOP(attrs);
8471
8472     if (ec) {
8473         op_free(block);
8474         if (name) SvREFCNT_dec(PL_compcv);
8475         else cv = PL_compcv;
8476         PL_compcv = 0;
8477         if (name && block) {
8478             const char *s = strrchr(name, ':');
8479             s = s ? s+1 : name;
8480             if (strEQ(s, "BEGIN")) {
8481                 if (PL_in_eval & EVAL_KEEPERR)
8482                     Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
8483                 else {
8484                     SV * const errsv = ERRSV;
8485                     /* force display of errors found but not reported */
8486                     sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
8487                     Perl_croak_nocontext("%"SVf, SVfARG(errsv));
8488                 }
8489             }
8490         }
8491         goto done;
8492     }
8493
8494     if (!block && SvTYPE(gv) != SVt_PVGV) {
8495       /* If we are not defining a new sub and the existing one is not a
8496          full GV + CV... */
8497       if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
8498         /* We are applying attributes to an existing sub, so we need it
8499            upgraded if it is a constant.  */
8500         if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
8501             gv_init_pvn(gv, PL_curstash, name, namlen,
8502                         SVf_UTF8 * name_is_utf8);
8503       }
8504       else {                    /* Maybe prototype now, and had at maximum
8505                                    a prototype or const/sub ref before.  */
8506         if (SvTYPE(gv) > SVt_NULL) {
8507             cv_ckproto_len_flags((const CV *)gv,
8508                                  o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8509                                  ps_len, ps_utf8);
8510         }
8511         if (!SvROK(gv)) {
8512           if (ps) {
8513             sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
8514             if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
8515           }
8516           else
8517             sv_setiv(MUTABLE_SV(gv), -1);
8518         }
8519
8520         SvREFCNT_dec(PL_compcv);
8521         cv = PL_compcv = NULL;
8522         goto done;
8523       }
8524     }
8525
8526     cv = (!name || (isGV(gv) && GvCVGEN(gv)))
8527         ? NULL
8528         : isGV(gv)
8529             ? GvCV(gv)
8530             : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
8531                 ? (CV *)SvRV(gv)
8532                 : NULL;
8533
8534     if (block) {
8535         /* This makes sub {}; work as expected.  */
8536         if (block->op_type == OP_STUB) {
8537             const line_t l = PL_parser->copline;
8538             op_free(block);
8539             block = newSTATEOP(0, NULL, 0);
8540             PL_parser->copline = l;
8541         }
8542         block = CvLVALUE(PL_compcv)
8543              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
8544                     && (!isGV(gv) || !GvASSUMECV(gv)))
8545                    ? newUNOP(OP_LEAVESUBLV, 0,
8546                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
8547                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
8548         start = LINKLIST(block);
8549         block->op_next = 0;
8550     }
8551
8552     if (!block || !ps || *ps || attrs
8553         || CvLVALUE(PL_compcv)
8554         )
8555         const_sv = NULL;
8556     else
8557         const_sv =
8558             S_op_const_sv(aTHX_ start, PL_compcv, cBOOL(CvCLONE(PL_compcv)));
8559
8560     if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
8561         assert (block);
8562         cv_ckproto_len_flags((const CV *)gv,
8563                              o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8564                              ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
8565         if (SvROK(gv)) {
8566             /* All the other code for sub redefinition warnings expects the
8567                clobbered sub to be a CV.  Instead of making all those code
8568                paths more complex, just inline the RV version here.  */
8569             const line_t oldline = CopLINE(PL_curcop);
8570             assert(IN_PERL_COMPILETIME);
8571             if (PL_parser && PL_parser->copline != NOLINE)
8572                 /* This ensures that warnings are reported at the first
8573                    line of a redefinition, not the last.  */
8574                 CopLINE_set(PL_curcop, PL_parser->copline);
8575             /* protect against fatal warnings leaking compcv */
8576             SAVEFREESV(PL_compcv);
8577
8578             if (ckWARN(WARN_REDEFINE)
8579              || (  ckWARN_d(WARN_REDEFINE)
8580                 && (  !const_sv || SvRV(gv) == const_sv
8581                    || sv_cmp(SvRV(gv), const_sv)  )))
8582                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8583                           "Constant subroutine %"SVf" redefined",
8584                           SVfARG(cSVOPo->op_sv));
8585
8586             SvREFCNT_inc_simple_void_NN(PL_compcv);
8587             CopLINE_set(PL_curcop, oldline);
8588             SvREFCNT_dec(SvRV(gv));
8589         }
8590     }
8591
8592     if (cv) {
8593         const bool exists = CvROOT(cv) || CvXSUB(cv);
8594
8595         /* if the subroutine doesn't exist and wasn't pre-declared
8596          * with a prototype, assume it will be AUTOLOADed,
8597          * skipping the prototype check
8598          */
8599         if (exists || SvPOK(cv))
8600             cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
8601         /* already defined (or promised)? */
8602         if (exists || (isGV(gv) && GvASSUMECV(gv))) {
8603             if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv))
8604                 cv = NULL;
8605             else {
8606                 if (attrs) goto attrs;
8607                 /* just a "sub foo;" when &foo is already defined */
8608                 SAVEFREESV(PL_compcv);
8609                 goto done;
8610             }
8611         }
8612     }
8613     if (const_sv) {
8614         SvREFCNT_inc_simple_void_NN(const_sv);
8615         SvFLAGS(const_sv) |= SVs_PADTMP;
8616         if (cv) {
8617             assert(!CvROOT(cv) && !CvCONST(cv));
8618             cv_forget_slab(cv);
8619             sv_setpvs(MUTABLE_SV(cv), "");  /* prototype is "" */
8620             CvXSUBANY(cv).any_ptr = const_sv;
8621             CvXSUB(cv) = const_sv_xsub;
8622             CvCONST_on(cv);
8623             CvISXSUB_on(cv);
8624             PoisonPADLIST(cv);
8625             CvFLAGS(cv) |= CvMETHOD(PL_compcv);
8626         }
8627         else {
8628             if (isGV(gv) || CvMETHOD(PL_compcv)) {
8629                 if (name && isGV(gv))
8630                     GvCV_set(gv, NULL);
8631                 cv = newCONSTSUB_flags(
8632                     NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
8633                     const_sv
8634                 );
8635                 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
8636             }
8637             else {
8638                 if (!SvROK(gv)) {
8639                     SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8640                     prepare_SV_for_RV((SV *)gv);
8641                     SvOK_off((SV *)gv);
8642                     SvROK_on(gv);
8643                 }
8644                 SvRV_set(gv, const_sv);
8645             }
8646         }
8647         op_free(block);
8648         SvREFCNT_dec(PL_compcv);
8649         PL_compcv = NULL;
8650         goto done;
8651     }
8652     if (cv) {                           /* must reuse cv if autoloaded */
8653         /* transfer PL_compcv to cv */
8654         if (block
8655         ) {
8656             cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
8657             PADLIST *const temp_av = CvPADLIST(cv);
8658             CV *const temp_cv = CvOUTSIDE(cv);
8659             const cv_flags_t other_flags =
8660                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8661             OP * const cvstart = CvSTART(cv);
8662
8663             if (isGV(gv)) {
8664                 CvGV_set(cv,gv);
8665                 assert(!CvCVGV_RC(cv));
8666                 assert(CvGV(cv) == gv);
8667             }
8668             else {
8669                 dVAR;
8670                 U32 hash;
8671                 PERL_HASH(hash, name, namlen);
8672                 CvNAME_HEK_set(cv,
8673                                share_hek(name,
8674                                          name_is_utf8
8675                                             ? -(SSize_t)namlen
8676                                             :  (SSize_t)namlen,
8677                                          hash));
8678             }
8679
8680             SvPOK_off(cv);
8681             CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
8682                                              | CvNAMED(cv);
8683             CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
8684             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
8685             CvPADLIST_set(cv,CvPADLIST(PL_compcv));
8686             CvOUTSIDE(PL_compcv) = temp_cv;
8687             CvPADLIST_set(PL_compcv, temp_av);
8688             CvSTART(cv) = CvSTART(PL_compcv);
8689             CvSTART(PL_compcv) = cvstart;
8690             CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8691             CvFLAGS(PL_compcv) |= other_flags;
8692
8693             if (CvFILE(cv) && CvDYNFILE(cv)) {
8694                 Safefree(CvFILE(cv));
8695     }
8696             CvFILE_set_from_cop(cv, PL_curcop);
8697             CvSTASH_set(cv, PL_curstash);
8698
8699             /* inner references to PL_compcv must be fixed up ... */
8700             pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
8701             if (PERLDB_INTER)/* Advice debugger on the new sub. */
8702               ++PL_sub_generation;
8703         }
8704         else {
8705             /* Might have had built-in attributes applied -- propagate them. */
8706             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
8707         }
8708         /* ... before we throw it away */
8709         SvREFCNT_dec(PL_compcv);
8710         PL_compcv = cv;
8711     }
8712     else {
8713         cv = PL_compcv;
8714         if (name && isGV(gv)) {
8715             GvCV_set(gv, cv);
8716             GvCVGEN(gv) = 0;
8717             if (HvENAME_HEK(GvSTASH(gv)))
8718                 /* sub Foo::bar { (shift)+1 } */
8719                 gv_method_changed(gv);
8720         }
8721         else if (name) {
8722             if (!SvROK(gv)) {
8723                 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8724                 prepare_SV_for_RV((SV *)gv);
8725                 SvOK_off((SV *)gv);
8726                 SvROK_on(gv);
8727             }
8728             SvRV_set(gv, (SV *)cv);
8729         }
8730     }
8731     if (!CvHASGV(cv)) {
8732         if (isGV(gv)) CvGV_set(cv, gv);
8733         else {
8734             dVAR;
8735             U32 hash;
8736             PERL_HASH(hash, name, namlen);
8737             CvNAME_HEK_set(cv, share_hek(name,
8738                                          name_is_utf8
8739                                             ? -(SSize_t)namlen
8740                                             :  (SSize_t)namlen,
8741                                          hash));
8742         }
8743         CvFILE_set_from_cop(cv, PL_curcop);
8744         CvSTASH_set(cv, PL_curstash);
8745     }
8746
8747     if (ps) {
8748         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8749         if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
8750     }
8751
8752     if (!block)
8753         goto attrs;
8754
8755     /* If we assign an optree to a PVCV, then we've defined a subroutine that
8756        the debugger could be able to set a breakpoint in, so signal to
8757        pp_entereval that it should not throw away any saved lines at scope
8758        exit.  */
8759
8760     PL_breakable_sub_gen++;
8761     CvROOT(cv) = block;
8762     CvROOT(cv)->op_private |= OPpREFCOUNTED;
8763     OpREFCNT_set(CvROOT(cv), 1);
8764     /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8765        itself has a refcount. */
8766     CvSLABBED_off(cv);
8767     OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8768 #ifdef PERL_DEBUG_READONLY_OPS
8769     slab = (OPSLAB *)CvSTART(cv);
8770 #endif
8771     CvSTART(cv) = start;
8772     CALL_PEEP(start);
8773     finalize_optree(CvROOT(cv));
8774     S_prune_chain_head(&CvSTART(cv));
8775
8776     /* now that optimizer has done its work, adjust pad values */
8777
8778     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8779
8780   attrs:
8781     if (attrs) {
8782         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8783         HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
8784                         ? GvSTASH(CvGV(cv))
8785                         : PL_curstash;
8786         if (!name) SAVEFREESV(cv);
8787         apply_attrs(stash, MUTABLE_SV(cv), attrs);
8788         if (!name) SvREFCNT_inc_simple_void_NN(cv);
8789     }
8790
8791     if (block && has_name) {
8792         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8793             SV * const tmpstr = cv_name(cv,NULL,0);
8794             GV * const db_postponed = gv_fetchpvs("DB::postponed",
8795                                                   GV_ADDMULTI, SVt_PVHV);
8796             HV *hv;
8797             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8798                                           CopFILE(PL_curcop),
8799                                           (long)PL_subline,
8800                                           (long)CopLINE(PL_curcop));
8801             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8802                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8803             hv = GvHVn(db_postponed);
8804             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8805                 CV * const pcv = GvCV(db_postponed);
8806                 if (pcv) {
8807                     dSP;
8808                     PUSHMARK(SP);
8809                     XPUSHs(tmpstr);
8810                     PUTBACK;
8811                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
8812                 }
8813             }
8814         }
8815
8816         if (name) {
8817             if (PL_parser && PL_parser->error_count)
8818                 clear_special_blocks(name, gv, cv);
8819             else
8820                 evanescent =
8821                     process_special_blocks(floor, name, gv, cv);
8822         }
8823     }
8824
8825   done:
8826     if (PL_parser)
8827         PL_parser->copline = NOLINE;
8828     LEAVE_SCOPE(floor);
8829     if (!evanescent) {
8830 #ifdef PERL_DEBUG_READONLY_OPS
8831       if (slab)
8832         Slab_to_ro(slab);
8833 #endif
8834       if (cv && name && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
8835         pad_add_weakref(cv);
8836     }
8837     return cv;
8838 }
8839
8840 STATIC void
8841 S_clear_special_blocks(pTHX_ const char *const fullname,
8842                        GV *const gv, CV *const cv) {
8843     const char *colon;
8844     const char *name;
8845
8846     PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
8847
8848     colon = strrchr(fullname,':');
8849     name = colon ? colon + 1 : fullname;
8850
8851     if ((*name == 'B' && strEQ(name, "BEGIN"))
8852         || (*name == 'E' && strEQ(name, "END"))
8853         || (*name == 'U' && strEQ(name, "UNITCHECK"))
8854         || (*name == 'C' && strEQ(name, "CHECK"))
8855         || (*name == 'I' && strEQ(name, "INIT"))) {
8856         if (!isGV(gv)) {
8857             (void)CvGV(cv);
8858             assert(isGV(gv));
8859         }
8860         GvCV_set(gv, NULL);
8861         SvREFCNT_dec_NN(MUTABLE_SV(cv));
8862     }
8863 }
8864
8865 /* Returns true if the sub has been freed.  */
8866 STATIC bool
8867 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
8868                          GV *const gv,
8869                          CV *const cv)
8870 {
8871     const char *const colon = strrchr(fullname,':');
8872     const char *const name = colon ? colon + 1 : fullname;
8873
8874     PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
8875
8876     if (*name == 'B') {
8877         if (strEQ(name, "BEGIN")) {
8878             const I32 oldscope = PL_scopestack_ix;
8879             dSP;
8880             (void)CvGV(cv);
8881             if (floor) LEAVE_SCOPE(floor);
8882             ENTER;
8883             PUSHSTACKi(PERLSI_REQUIRE);
8884             SAVECOPFILE(&PL_compiling);
8885             SAVECOPLINE(&PL_compiling);
8886             SAVEVPTR(PL_curcop);
8887
8888             DEBUG_x( dump_sub(gv) );
8889             Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
8890             GvCV_set(gv,0);             /* cv has been hijacked */
8891             call_list(oldscope, PL_beginav);
8892
8893             POPSTACK;
8894             LEAVE;
8895             return !PL_savebegin;
8896         }
8897         else
8898             return FALSE;
8899     } else {
8900         if (*name == 'E') {
8901             if strEQ(name, "END") {
8902                 DEBUG_x( dump_sub(gv) );
8903                 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
8904             } else
8905                 return FALSE;
8906         } else if (*name == 'U') {
8907             if (strEQ(name, "UNITCHECK")) {
8908                 /* It's never too late to run a unitcheck block */
8909                 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
8910             }
8911             else
8912                 return FALSE;
8913         } else if (*name == 'C') {
8914             if (strEQ(name, "CHECK")) {
8915                 if (PL_main_start)
8916                     /* diag_listed_as: Too late to run %s block */
8917                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8918                                    "Too late to run CHECK block");
8919                 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
8920             }
8921             else
8922                 return FALSE;
8923         } else if (*name == 'I') {
8924             if (strEQ(name, "INIT")) {
8925                 if (PL_main_start)
8926                     /* diag_listed_as: Too late to run %s block */
8927                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8928                                    "Too late to run INIT block");
8929                 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
8930             }
8931             else
8932                 return FALSE;
8933         } else
8934             return FALSE;
8935         DEBUG_x( dump_sub(gv) );
8936         (void)CvGV(cv);
8937         GvCV_set(gv,0);         /* cv has been hijacked */
8938         return FALSE;
8939     }
8940 }
8941
8942 /*
8943 =for apidoc newCONSTSUB
8944
8945 See L</newCONSTSUB_flags>.
8946
8947 =cut
8948 */
8949
8950 CV *
8951 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
8952 {
8953     return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
8954 }
8955
8956 /*
8957 =for apidoc newCONSTSUB_flags
8958
8959 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
8960 eligible for inlining at compile-time.
8961
8962 Currently, the only useful value for C<flags> is SVf_UTF8.
8963
8964 The newly created subroutine takes ownership of a reference to the passed in
8965 SV.
8966
8967 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
8968 which won't be called if used as a destructor, but will suppress the overhead
8969 of a call to C<AUTOLOAD>.  (This form, however, isn't eligible for inlining at
8970 compile time.)
8971
8972 =cut
8973 */
8974
8975 CV *
8976 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
8977                              U32 flags, SV *sv)
8978 {
8979     CV* cv;
8980     const char *const file = CopFILE(PL_curcop);
8981
8982     ENTER;
8983
8984     if (IN_PERL_RUNTIME) {
8985         /* at runtime, it's not safe to manipulate PL_curcop: it may be
8986          * an op shared between threads. Use a non-shared COP for our
8987          * dirty work */
8988          SAVEVPTR(PL_curcop);
8989          SAVECOMPILEWARNINGS();
8990          PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
8991          PL_curcop = &PL_compiling;
8992     }
8993     SAVECOPLINE(PL_curcop);
8994     CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
8995
8996     SAVEHINTS();
8997     PL_hints &= ~HINT_BLOCK_SCOPE;
8998
8999     if (stash) {
9000         SAVEGENERICSV(PL_curstash);
9001         PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
9002     }
9003
9004     /* Protect sv against leakage caused by fatal warnings. */
9005     if (sv) SAVEFREESV(sv);
9006
9007     /* file becomes the CvFILE. For an XS, it's usually static storage,
9008        and so doesn't get free()d.  (It's expected to be from the C pre-
9009        processor __FILE__ directive). But we need a dynamically allocated one,
9010        and we need it to get freed.  */
9011     cv = newXS_len_flags(name, len,
9012                          sv && SvTYPE(sv) == SVt_PVAV
9013                              ? const_av_xsub
9014                              : const_sv_xsub,
9015                          file ? file : "", "",
9016                          &sv, XS_DYNAMIC_FILENAME | flags);
9017     CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
9018     CvCONST_on(cv);
9019
9020     LEAVE;
9021
9022     return cv;
9023 }
9024
9025 /*
9026 =for apidoc U||newXS
9027
9028 Used by C<xsubpp> to hook up XSUBs as Perl subs.  I<filename> needs to be
9029 static storage, as it is used directly as CvFILE(), without a copy being made.
9030
9031 =cut
9032 */
9033
9034 CV *
9035 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
9036 {
9037     PERL_ARGS_ASSERT_NEWXS;
9038     return newXS_len_flags(
9039         name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
9040     );
9041 }
9042
9043 CV *
9044 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
9045                  const char *const filename, const char *const proto,
9046                  U32 flags)
9047 {
9048     PERL_ARGS_ASSERT_NEWXS_FLAGS;
9049     return newXS_len_flags(
9050        name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
9051     );
9052 }
9053
9054 CV *
9055 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
9056 {
9057     PERL_ARGS_ASSERT_NEWXS_DEFFILE;
9058     return newXS_len_flags(
9059         name, name ? strlen(name) : 0, subaddr, NULL, NULL, NULL, 0
9060     );
9061 }
9062
9063 CV *
9064 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
9065                            XSUBADDR_t subaddr, const char *const filename,
9066                            const char *const proto, SV **const_svp,
9067                            U32 flags)
9068 {
9069     CV *cv;
9070     bool interleave = FALSE;
9071
9072     PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
9073
9074     {
9075         GV * const gv = gv_fetchpvn(
9076                             name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
9077                             name ? len : PL_curstash ? sizeof("__ANON__") - 1:
9078                                 sizeof("__ANON__::__ANON__") - 1,
9079                             GV_ADDMULTI | flags, SVt_PVCV);
9080
9081         if ((cv = (name ? GvCV(gv) : NULL))) {
9082             if (GvCVGEN(gv)) {
9083                 /* just a cached method */
9084                 SvREFCNT_dec(cv);
9085                 cv = NULL;
9086             }
9087             else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
9088                 /* already defined (or promised) */
9089                 /* Redundant check that allows us to avoid creating an SV
9090                    most of the time: */
9091                 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
9092                     report_redefined_cv(newSVpvn_flags(
9093                                          name,len,(flags&SVf_UTF8)|SVs_TEMP
9094                                         ),
9095                                         cv, const_svp);
9096                 }
9097                 interleave = TRUE;
9098                 ENTER;
9099                 SAVEFREESV(cv);
9100                 cv = NULL;
9101             }
9102         }
9103
9104         if (cv)                         /* must reuse cv if autoloaded */
9105             cv_undef(cv);
9106         else {
9107             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9108             if (name) {
9109                 GvCV_set(gv,cv);
9110                 GvCVGEN(gv) = 0;
9111                 if (HvENAME_HEK(GvSTASH(gv)))
9112                     gv_method_changed(gv); /* newXS */
9113             }
9114         }
9115
9116         CvGV_set(cv, gv);
9117         if(filename) {
9118             (void)gv_fetchfile(filename);
9119             assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
9120             if (flags & XS_DYNAMIC_FILENAME) {
9121                 CvDYNFILE_on(cv);
9122                 CvFILE(cv) = savepv(filename);
9123             } else {
9124             /* NOTE: not copied, as it is expected to be an external constant string */
9125                 CvFILE(cv) = (char *)filename;
9126             }
9127         } else {
9128             assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
9129             CvFILE(cv) = (char*)PL_xsubfilename;
9130         }
9131         CvISXSUB_on(cv);
9132         CvXSUB(cv) = subaddr;
9133 #ifndef PERL_IMPLICIT_CONTEXT
9134         CvHSCXT(cv) = &PL_stack_sp;
9135 #else
9136         PoisonPADLIST(cv);
9137 #endif
9138
9139         if (name)
9140             process_special_blocks(0, name, gv, cv);
9141         else
9142             CvANON_on(cv);
9143     } /* <- not a conditional branch */
9144
9145
9146     sv_setpv(MUTABLE_SV(cv), proto);
9147     if (interleave) LEAVE;
9148     return cv;
9149 }
9150
9151 CV *
9152 Perl_newSTUB(pTHX_ GV *gv, bool fake)
9153 {
9154     CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9155     GV *cvgv;
9156     PERL_ARGS_ASSERT_NEWSTUB;
9157     assert(!GvCVu(gv));
9158     GvCV_set(gv, cv);
9159     GvCVGEN(gv) = 0;
9160     if (!fake && HvENAME_HEK(GvSTASH(gv)))
9161         gv_method_changed(gv);
9162     if (SvFAKE(gv)) {
9163         cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
9164         SvFAKE_off(cvgv);
9165     }
9166     else cvgv = gv;
9167     CvGV_set(cv, cvgv);
9168     CvFILE_set_from_cop(cv, PL_curcop);
9169     CvSTASH_set(cv, PL_curstash);
9170     GvMULTI_on(gv);
9171     return cv;
9172 }
9173
9174 void
9175 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
9176 {
9177     CV *cv;
9178
9179     GV *gv;
9180
9181     if (PL_parser && PL_parser->error_count) {
9182         op_free(block);
9183         goto finish;
9184     }
9185
9186     gv = o
9187         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
9188         : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
9189
9190     GvMULTI_on(gv);
9191     if ((cv = GvFORM(gv))) {
9192         if (ckWARN(WARN_REDEFINE)) {
9193             const line_t oldline = CopLINE(PL_curcop);
9194             if (PL_parser && PL_parser->copline != NOLINE)
9195                 CopLINE_set(PL_curcop, PL_parser->copline);
9196             if (o) {
9197                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9198                             "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
9199             } else {
9200                 /* diag_listed_as: Format %s redefined */
9201                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9202                             "Format STDOUT redefined");
9203             }
9204             CopLINE_set(PL_curcop, oldline);
9205         }
9206         SvREFCNT_dec(cv);
9207     }
9208     cv = PL_compcv;
9209     GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
9210     CvGV_set(cv, gv);
9211     CvFILE_set_from_cop(cv, PL_curcop);
9212
9213
9214     pad_tidy(padtidy_FORMAT);
9215     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
9216     CvROOT(cv)->op_private |= OPpREFCOUNTED;
9217     OpREFCNT_set(CvROOT(cv), 1);
9218     CvSTART(cv) = LINKLIST(CvROOT(cv));
9219     CvROOT(cv)->op_next = 0;
9220     CALL_PEEP(CvSTART(cv));
9221     finalize_optree(CvROOT(cv));
9222     S_prune_chain_head(&CvSTART(cv));
9223     cv_forget_slab(cv);
9224
9225   finish:
9226     op_free(o);
9227     if (PL_parser)
9228         PL_parser->copline = NOLINE;
9229     LEAVE_SCOPE(floor);
9230     PL_compiling.cop_seq = 0;
9231 }
9232
9233 OP *
9234 Perl_newANONLIST(pTHX_ OP *o)
9235 {
9236     return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
9237 }
9238
9239 OP *
9240 Perl_newANONHASH(pTHX_ OP *o)
9241 {
9242     return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
9243 }
9244
9245 OP *
9246 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
9247 {
9248     return newANONATTRSUB(floor, proto, NULL, block);
9249 }
9250
9251 OP *
9252 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
9253 {
9254     SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
9255     OP * anoncode =
9256         newSVOP(OP_ANONCODE, 0,
9257                 cv);
9258     if (CvANONCONST(cv))
9259         anoncode = newUNOP(OP_ANONCONST, 0,
9260                            op_convert_list(OP_ENTERSUB,
9261                                            OPf_STACKED|OPf_WANT_SCALAR,
9262                                            anoncode));
9263     return newUNOP(OP_REFGEN, 0, anoncode);
9264 }
9265
9266 OP *
9267 Perl_oopsAV(pTHX_ OP *o)
9268 {
9269     dVAR;
9270
9271     PERL_ARGS_ASSERT_OOPSAV;
9272
9273     switch (o->op_type) {
9274     case OP_PADSV:
9275     case OP_PADHV:
9276         OpTYPE_set(o, OP_PADAV);
9277         return ref(o, OP_RV2AV);
9278
9279     case OP_RV2SV:
9280     case OP_RV2HV:
9281         OpTYPE_set(o, OP_RV2AV);
9282         ref(o, OP_RV2AV);
9283         break;
9284
9285     default:
9286         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
9287         break;
9288     }
9289     return o;
9290 }
9291
9292 OP *
9293 Perl_oopsHV(pTHX_ OP *o)
9294 {
9295     dVAR;
9296
9297     PERL_ARGS_ASSERT_OOPSHV;
9298
9299     switch (o->op_type) {
9300     case OP_PADSV:
9301     case OP_PADAV:
9302         OpTYPE_set(o, OP_PADHV);
9303         return ref(o, OP_RV2HV);
9304
9305     case OP_RV2SV:
9306     case OP_RV2AV:
9307         OpTYPE_set(o, OP_RV2HV);
9308         ref(o, OP_RV2HV);
9309         break;
9310
9311     default:
9312         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
9313         break;
9314     }
9315     return o;
9316 }
9317
9318 OP *
9319 Perl_newAVREF(pTHX_ OP *o)
9320 {
9321     dVAR;
9322
9323     PERL_ARGS_ASSERT_NEWAVREF;
9324
9325     if (o->op_type == OP_PADANY) {
9326         OpTYPE_set(o, OP_PADAV);
9327         return o;
9328     }
9329     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
9330         Perl_croak(aTHX_ "Can't use an array as a reference");
9331     }
9332     return newUNOP(OP_RV2AV, 0, scalar(o));
9333 }
9334
9335 OP *
9336 Perl_newGVREF(pTHX_ I32 type, OP *o)
9337 {
9338     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
9339         return newUNOP(OP_NULL, 0, o);
9340     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
9341 }
9342
9343 OP *
9344 Perl_newHVREF(pTHX_ OP *o)
9345 {
9346     dVAR;
9347
9348     PERL_ARGS_ASSERT_NEWHVREF;
9349
9350     if (o->op_type == OP_PADANY) {
9351         OpTYPE_set(o, OP_PADHV);
9352         return o;
9353     }
9354     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
9355         Perl_croak(aTHX_ "Can't use a hash as a reference");
9356     }
9357     return newUNOP(OP_RV2HV, 0, scalar(o));
9358 }
9359
9360 OP *
9361 Perl_newCVREF(pTHX_ I32 flags, OP *o)
9362 {
9363     if (o->op_type == OP_PADANY) {
9364         dVAR;
9365         OpTYPE_set(o, OP_PADCV);
9366     }
9367     return newUNOP(OP_RV2CV, flags, scalar(o));
9368 }
9369
9370 OP *
9371 Perl_newSVREF(pTHX_ OP *o)
9372 {
9373     dVAR;
9374
9375     PERL_ARGS_ASSERT_NEWSVREF;
9376
9377     if (o->op_type == OP_PADANY) {
9378         OpTYPE_set(o, OP_PADSV);
9379         scalar(o);
9380         return o;
9381     }
9382     return newUNOP(OP_RV2SV, 0, scalar(o));
9383 }
9384
9385 /* Check routines. See the comments at the top of this file for details
9386  * on when these are called */
9387
9388 OP *
9389 Perl_ck_anoncode(pTHX_ OP *o)
9390 {
9391     PERL_ARGS_ASSERT_CK_ANONCODE;
9392
9393     cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
9394     cSVOPo->op_sv = NULL;
9395     return o;
9396 }
9397
9398 static void
9399 S_io_hints(pTHX_ OP *o)
9400 {
9401 #if O_BINARY != 0 || O_TEXT != 0
9402     HV * const table =
9403         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
9404     if (table) {
9405         SV **svp = hv_fetchs(table, "open_IN", FALSE);
9406         if (svp && *svp) {
9407             STRLEN len = 0;
9408             const char *d = SvPV_const(*svp, len);
9409             const I32 mode = mode_from_discipline(d, len);
9410             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9411 #  if O_BINARY != 0
9412             if (mode & O_BINARY)
9413                 o->op_private |= OPpOPEN_IN_RAW;
9414 #  endif
9415 #  if O_TEXT != 0
9416             if (mode & O_TEXT)
9417                 o->op_private |= OPpOPEN_IN_CRLF;
9418 #  endif
9419         }
9420
9421         svp = hv_fetchs(table, "open_OUT", FALSE);
9422         if (svp && *svp) {
9423             STRLEN len = 0;
9424             const char *d = SvPV_const(*svp, len);
9425             const I32 mode = mode_from_discipline(d, len);
9426             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9427 #  if O_BINARY != 0
9428             if (mode & O_BINARY)
9429                 o->op_private |= OPpOPEN_OUT_RAW;
9430 #  endif
9431 #  if O_TEXT != 0
9432             if (mode & O_TEXT)
9433                 o->op_private |= OPpOPEN_OUT_CRLF;
9434 #  endif
9435         }
9436     }
9437 #else
9438     PERL_UNUSED_CONTEXT;
9439     PERL_UNUSED_ARG(o);
9440 #endif
9441 }
9442
9443 OP *
9444 Perl_ck_backtick(pTHX_ OP *o)
9445 {
9446     GV *gv;
9447     OP *newop = NULL;
9448     OP *sibl;
9449     PERL_ARGS_ASSERT_CK_BACKTICK;
9450     /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
9451     if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
9452      && (gv = gv_override("readpipe",8)))
9453     {
9454         /* detach rest of siblings from o and its first child */
9455         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
9456         newop = S_new_entersubop(aTHX_ gv, sibl);
9457     }
9458     else if (!(o->op_flags & OPf_KIDS))
9459         newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
9460     if (newop) {
9461         op_free(o);
9462         return newop;
9463     }
9464     S_io_hints(aTHX_ o);
9465     return o;
9466 }
9467
9468 OP *
9469 Perl_ck_bitop(pTHX_ OP *o)
9470 {
9471     PERL_ARGS_ASSERT_CK_BITOP;
9472
9473     o->op_private = (U8)(PL_hints & HINT_INTEGER);
9474
9475     if (o->op_type == OP_NBIT_OR     || o->op_type == OP_SBIT_OR
9476      || o->op_type == OP_NBIT_XOR    || o->op_type == OP_SBIT_XOR
9477      || o->op_type == OP_NBIT_AND    || o->op_type == OP_SBIT_AND
9478      || o->op_type == OP_NCOMPLEMENT || o->op_type == OP_SCOMPLEMENT)
9479         Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__BITWISE),
9480                               "The bitwise feature is experimental");
9481     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
9482             && OP_IS_INFIX_BIT(o->op_type))
9483     {
9484         const OP * const left = cBINOPo->op_first;
9485         const OP * const right = OpSIBLING(left);
9486         if ((OP_IS_NUMCOMPARE(left->op_type) &&
9487                 (left->op_flags & OPf_PARENS) == 0) ||
9488             (OP_IS_NUMCOMPARE(right->op_type) &&
9489                 (right->op_flags & OPf_PARENS) == 0))
9490             Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
9491                           "Possible precedence problem on bitwise %s operator",
9492                            o->op_type ==  OP_BIT_OR
9493                          ||o->op_type == OP_NBIT_OR  ? "|"
9494                         :  o->op_type ==  OP_BIT_AND
9495                          ||o->op_type == OP_NBIT_AND ? "&"
9496                         :  o->op_type ==  OP_BIT_XOR
9497                          ||o->op_type == OP_NBIT_XOR ? "^"
9498                         :  o->op_type == OP_SBIT_OR  ? "|."
9499                         :  o->op_type == OP_SBIT_AND ? "&." : "^."
9500                            );
9501     }
9502     return o;
9503 }
9504
9505 PERL_STATIC_INLINE bool
9506 is_dollar_bracket(pTHX_ const OP * const o)
9507 {
9508     const OP *kid;
9509     PERL_UNUSED_CONTEXT;
9510     return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
9511         && (kid = cUNOPx(o)->op_first)
9512         && kid->op_type == OP_GV
9513         && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
9514 }
9515
9516 OP *
9517 Perl_ck_cmp(pTHX_ OP *o)
9518 {
9519     PERL_ARGS_ASSERT_CK_CMP;
9520     if (ckWARN(WARN_SYNTAX)) {
9521         const OP *kid = cUNOPo->op_first;
9522         if (kid &&
9523             (
9524                 (   is_dollar_bracket(aTHX_ kid)
9525                  && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
9526                 )
9527              || (   kid->op_type == OP_CONST
9528                  && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
9529                 )
9530            )
9531         )
9532             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9533                         "$[ used in %s (did you mean $] ?)", OP_DESC(o));
9534     }
9535     return o;
9536 }
9537
9538 OP *
9539 Perl_ck_concat(pTHX_ OP *o)
9540 {
9541     const OP * const kid = cUNOPo->op_first;
9542
9543     PERL_ARGS_ASSERT_CK_CONCAT;
9544     PERL_UNUSED_CONTEXT;
9545
9546     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
9547             !(kUNOP->op_first->op_flags & OPf_MOD))
9548         o->op_flags |= OPf_STACKED;
9549     return o;
9550 }
9551
9552 OP *
9553 Perl_ck_spair(pTHX_ OP *o)
9554 {
9555     dVAR;
9556
9557     PERL_ARGS_ASSERT_CK_SPAIR;
9558
9559     if (o->op_flags & OPf_KIDS) {
9560         OP* newop;
9561         OP* kid;
9562         OP* kidkid;
9563         const OPCODE type = o->op_type;
9564         o = modkids(ck_fun(o), type);
9565         kid    = cUNOPo->op_first;
9566         kidkid = kUNOP->op_first;
9567         newop = OpSIBLING(kidkid);
9568         if (newop) {
9569             const OPCODE type = newop->op_type;
9570             if (OpHAS_SIBLING(newop))
9571                 return o;
9572             if (o->op_type == OP_REFGEN
9573              && (  type == OP_RV2CV
9574                 || (  !(newop->op_flags & OPf_PARENS)
9575                    && (  type == OP_RV2AV || type == OP_PADAV
9576                       || type == OP_RV2HV || type == OP_PADHV))))
9577                 NOOP; /* OK (allow srefgen for \@a and \%h) */
9578             else if (OP_GIMME(newop,0) != G_SCALAR)
9579                 return o;
9580         }
9581         /* excise first sibling */
9582         op_sibling_splice(kid, NULL, 1, NULL);
9583         op_free(kidkid);
9584     }
9585     /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
9586      * and OP_CHOMP into OP_SCHOMP */
9587     o->op_ppaddr = PL_ppaddr[++o->op_type];
9588     return ck_fun(o);
9589 }
9590
9591 OP *
9592 Perl_ck_delete(pTHX_ OP *o)
9593 {
9594     PERL_ARGS_ASSERT_CK_DELETE;
9595
9596     o = ck_fun(o);
9597     o->op_private = 0;
9598     if (o->op_flags & OPf_KIDS) {
9599         OP * const kid = cUNOPo->op_first;
9600         switch (kid->op_type) {
9601         case OP_ASLICE:
9602             o->op_flags |= OPf_SPECIAL;
9603             /* FALLTHROUGH */
9604         case OP_HSLICE:
9605             o->op_private |= OPpSLICE;
9606             break;
9607         case OP_AELEM:
9608             o->op_flags |= OPf_SPECIAL;
9609             /* FALLTHROUGH */
9610         case OP_HELEM:
9611             break;
9612         case OP_KVASLICE:
9613             Perl_croak(aTHX_ "delete argument is index/value array slice,"
9614                              " use array slice");
9615         case OP_KVHSLICE:
9616             Perl_croak(aTHX_ "delete argument is key/value hash slice, use"
9617                              " hash slice");
9618         default:
9619             Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
9620                              "element or slice");
9621         }
9622         if (kid->op_private & OPpLVAL_INTRO)
9623             o->op_private |= OPpLVAL_INTRO;
9624         op_null(kid);
9625     }
9626     return o;
9627 }
9628
9629 OP *
9630 Perl_ck_eof(pTHX_ OP *o)
9631 {
9632     PERL_ARGS_ASSERT_CK_EOF;
9633
9634     if (o->op_flags & OPf_KIDS) {
9635         OP *kid;
9636         if (cLISTOPo->op_first->op_type == OP_STUB) {
9637             OP * const newop
9638                 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
9639             op_free(o);
9640             o = newop;
9641         }
9642         o = ck_fun(o);
9643         kid = cLISTOPo->op_first;
9644         if (kid->op_type == OP_RV2GV)
9645             kid->op_private |= OPpALLOW_FAKE;
9646     }
9647     return o;
9648 }
9649
9650 OP *
9651 Perl_ck_eval(pTHX_ OP *o)
9652 {
9653     dVAR;
9654
9655     PERL_ARGS_ASSERT_CK_EVAL;
9656
9657     PL_hints |= HINT_BLOCK_SCOPE;
9658     if (o->op_flags & OPf_KIDS) {
9659         SVOP * const kid = (SVOP*)cUNOPo->op_first;
9660         assert(kid);
9661
9662         if (o->op_type == OP_ENTERTRY) {
9663             LOGOP *enter;
9664
9665             /* cut whole sibling chain free from o */
9666             op_sibling_splice(o, NULL, -1, NULL);
9667             op_free(o);
9668
9669             enter = S_alloc_LOGOP(aTHX_ OP_ENTERTRY, NULL, NULL);
9670
9671             /* establish postfix order */
9672             enter->op_next = (OP*)enter;
9673
9674             o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
9675             OpTYPE_set(o, OP_LEAVETRY);
9676             enter->op_other = o;
9677             return o;
9678         }
9679         else {
9680             scalar((OP*)kid);
9681             S_set_haseval(aTHX);
9682         }
9683     }
9684     else {
9685         const U8 priv = o->op_private;
9686         op_free(o);
9687         /* the newUNOP will recursively call ck_eval(), which will handle
9688          * all the stuff at the end of this function, like adding
9689          * OP_HINTSEVAL
9690          */
9691         return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
9692     }
9693     o->op_targ = (PADOFFSET)PL_hints;
9694     if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
9695     if ((PL_hints & HINT_LOCALIZE_HH) != 0
9696      && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
9697         /* Store a copy of %^H that pp_entereval can pick up. */
9698         OP *hhop = newSVOP(OP_HINTSEVAL, 0,
9699                            MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
9700         /* append hhop to only child  */
9701         op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
9702
9703         o->op_private |= OPpEVAL_HAS_HH;
9704     }
9705     if (!(o->op_private & OPpEVAL_BYTES)
9706          && FEATURE_UNIEVAL_IS_ENABLED)
9707             o->op_private |= OPpEVAL_UNICODE;
9708     return o;
9709 }
9710
9711 OP *
9712 Perl_ck_exec(pTHX_ OP *o)
9713 {
9714     PERL_ARGS_ASSERT_CK_EXEC;
9715
9716     if (o->op_flags & OPf_STACKED) {
9717         OP *kid;
9718         o = ck_fun(o);
9719         kid = OpSIBLING(cUNOPo->op_first);
9720         if (kid->op_type == OP_RV2GV)
9721             op_null(kid);
9722     }
9723     else
9724         o = listkids(o);
9725     return o;
9726 }
9727
9728 OP *
9729 Perl_ck_exists(pTHX_ OP *o)
9730 {
9731     PERL_ARGS_ASSERT_CK_EXISTS;
9732
9733     o = ck_fun(o);
9734     if (o->op_flags & OPf_KIDS) {
9735         OP * const kid = cUNOPo->op_first;
9736         if (kid->op_type == OP_ENTERSUB) {
9737             (void) ref(kid, o->op_type);
9738             if (kid->op_type != OP_RV2CV
9739                         && !(PL_parser && PL_parser->error_count))
9740                 Perl_croak(aTHX_
9741                           "exists argument is not a subroutine name");
9742             o->op_private |= OPpEXISTS_SUB;
9743         }
9744         else if (kid->op_type == OP_AELEM)
9745             o->op_flags |= OPf_SPECIAL;
9746         else if (kid->op_type != OP_HELEM)
9747             Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
9748                              "element or a subroutine");
9749         op_null(kid);
9750     }
9751     return o;
9752 }
9753
9754 OP *
9755 Perl_ck_rvconst(pTHX_ OP *o)
9756 {
9757     dVAR;
9758     SVOP * const kid = (SVOP*)cUNOPo->op_first;
9759
9760     PERL_ARGS_ASSERT_CK_RVCONST;
9761
9762     o->op_private |= (PL_hints & HINT_STRICT_REFS);
9763
9764     if (kid->op_type == OP_CONST) {
9765         int iscv;
9766         GV *gv;
9767         SV * const kidsv = kid->op_sv;
9768
9769         /* Is it a constant from cv_const_sv()? */
9770         if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
9771             return o;
9772         }
9773         if (SvTYPE(kidsv) == SVt_PVAV) return o;
9774         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
9775             const char *badthing;
9776             switch (o->op_type) {
9777             case OP_RV2SV:
9778                 badthing = "a SCALAR";
9779                 break;
9780             case OP_RV2AV:
9781                 badthing = "an ARRAY";
9782                 break;
9783             case OP_RV2HV:
9784                 badthing = "a HASH";
9785                 break;
9786             default:
9787                 badthing = NULL;
9788                 break;
9789             }
9790             if (badthing)
9791                 Perl_croak(aTHX_
9792                            "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
9793                            SVfARG(kidsv), badthing);
9794         }
9795         /*
9796          * This is a little tricky.  We only want to add the symbol if we
9797          * didn't add it in the lexer.  Otherwise we get duplicate strict
9798          * warnings.  But if we didn't add it in the lexer, we must at
9799          * least pretend like we wanted to add it even if it existed before,
9800          * or we get possible typo warnings.  OPpCONST_ENTERED says
9801          * whether the lexer already added THIS instance of this symbol.
9802          */
9803         iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
9804         gv = gv_fetchsv(kidsv,
9805                 o->op_type == OP_RV2CV
9806                         && o->op_private & OPpMAY_RETURN_CONSTANT
9807                     ? GV_NOEXPAND
9808                     : iscv | !(kid->op_private & OPpCONST_ENTERED),
9809                 iscv
9810                     ? SVt_PVCV
9811                     : o->op_type == OP_RV2SV
9812                         ? SVt_PV
9813                         : o->op_type == OP_RV2AV
9814                             ? SVt_PVAV
9815                             : o->op_type == OP_RV2HV
9816                                 ? SVt_PVHV
9817                                 : SVt_PVGV);
9818         if (gv) {
9819             if (!isGV(gv)) {
9820                 assert(iscv);
9821                 assert(SvROK(gv));
9822                 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
9823                   && SvTYPE(SvRV(gv)) != SVt_PVCV)
9824                     gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
9825             }
9826             OpTYPE_set(kid, OP_GV);
9827             SvREFCNT_dec(kid->op_sv);
9828 #ifdef USE_ITHREADS
9829             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
9830             STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
9831             kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
9832             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
9833             PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
9834 #else
9835             kid->op_sv = SvREFCNT_inc_simple_NN(gv);
9836 #endif
9837             kid->op_private = 0;
9838             /* FAKE globs in the symbol table cause weird bugs (#77810) */
9839             SvFAKE_off(gv);
9840         }
9841     }
9842     return o;
9843 }
9844
9845 OP *
9846 Perl_ck_ftst(pTHX_ OP *o)
9847 {
9848     dVAR;
9849     const I32 type = o->op_type;
9850
9851     PERL_ARGS_ASSERT_CK_FTST;
9852
9853     if (o->op_flags & OPf_REF) {
9854         NOOP;
9855     }
9856     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
9857         SVOP * const kid = (SVOP*)cUNOPo->op_first;
9858         const OPCODE kidtype = kid->op_type;
9859
9860         if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
9861          && !kid->op_folded) {
9862             OP * const newop = newGVOP(type, OPf_REF,
9863                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
9864             op_free(o);
9865             return newop;
9866         }
9867         if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
9868             o->op_private |= OPpFT_ACCESS;
9869         if (type != OP_STAT && type != OP_LSTAT
9870             && PL_check[kidtype] == Perl_ck_ftst
9871             && kidtype != OP_STAT && kidtype != OP_LSTAT
9872         ) {
9873             o->op_private |= OPpFT_STACKED;
9874             kid->op_private |= OPpFT_STACKING;
9875             if (kidtype == OP_FTTTY && (
9876                    !(kid->op_private & OPpFT_STACKED)
9877                 || kid->op_private & OPpFT_AFTER_t
9878                ))
9879                 o->op_private |= OPpFT_AFTER_t;
9880         }
9881     }
9882     else {
9883         op_free(o);
9884         if (type == OP_FTTTY)
9885             o = newGVOP(type, OPf_REF, PL_stdingv);
9886         else
9887             o = newUNOP(type, 0, newDEFSVOP());
9888     }
9889     return o;
9890 }
9891
9892 OP *
9893 Perl_ck_fun(pTHX_ OP *o)
9894 {
9895     const int type = o->op_type;
9896     I32 oa = PL_opargs[type] >> OASHIFT;
9897
9898     PERL_ARGS_ASSERT_CK_FUN;
9899
9900     if (o->op_flags & OPf_STACKED) {
9901         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
9902             oa &= ~OA_OPTIONAL;
9903         else
9904             return no_fh_allowed(o);
9905     }
9906
9907     if (o->op_flags & OPf_KIDS) {
9908         OP *prev_kid = NULL;
9909         OP *kid = cLISTOPo->op_first;
9910         I32 numargs = 0;
9911         bool seen_optional = FALSE;
9912
9913         if (kid->op_type == OP_PUSHMARK ||
9914             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
9915         {
9916             prev_kid = kid;
9917             kid = OpSIBLING(kid);
9918         }
9919         if (kid && kid->op_type == OP_COREARGS) {
9920             bool optional = FALSE;
9921             while (oa) {
9922                 numargs++;
9923                 if (oa & OA_OPTIONAL) optional = TRUE;
9924                 oa = oa >> 4;
9925             }
9926             if (optional) o->op_private |= numargs;
9927             return o;
9928         }
9929
9930         while (oa) {
9931             if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
9932                 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
9933                     kid = newDEFSVOP();
9934                     /* append kid to chain */
9935                     op_sibling_splice(o, prev_kid, 0, kid);
9936                 }
9937                 seen_optional = TRUE;
9938             }
9939             if (!kid) break;
9940
9941             numargs++;
9942             switch (oa & 7) {
9943             case OA_SCALAR:
9944                 /* list seen where single (scalar) arg expected? */
9945                 if (numargs == 1 && !(oa >> 4)
9946                     && kid->op_type == OP_LIST && type != OP_SCALAR)
9947                 {
9948                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
9949                 }
9950                 if (type != OP_DELETE) scalar(kid);
9951                 break;
9952             case OA_LIST:
9953                 if (oa < 16) {
9954                     kid = 0;
9955                     continue;
9956                 }
9957                 else
9958                     list(kid);
9959                 break;
9960             case OA_AVREF:
9961                 if ((type == OP_PUSH || type == OP_UNSHIFT)
9962                     && !OpHAS_SIBLING(kid))
9963                     Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
9964                                    "Useless use of %s with no values",
9965                                    PL_op_desc[type]);
9966
9967                 if (kid->op_type == OP_CONST
9968                       && (  !SvROK(cSVOPx_sv(kid))
9969                          || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV  )
9970                         )
9971                     bad_type_pv(numargs, "array", o, kid);
9972                 /* Defer checks to run-time if we have a scalar arg */
9973                 if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
9974                     op_lvalue(kid, type);
9975                 else {
9976                     scalar(kid);
9977                     /* diag_listed_as: push on reference is experimental */
9978                     Perl_ck_warner_d(aTHX_
9979                                      packWARN(WARN_EXPERIMENTAL__AUTODEREF),
9980                                     "%s on reference is experimental",
9981                                      PL_op_desc[type]);
9982                 }
9983                 break;
9984             case OA_HVREF:
9985                 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
9986                     bad_type_pv(numargs, "hash", o, kid);
9987                 op_lvalue(kid, type);
9988                 break;
9989             case OA_CVREF:
9990                 {
9991                     /* replace kid with newop in chain */
9992                     OP * const newop =
9993                         S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
9994                     newop->op_next = newop;
9995                     kid = newop;
9996                 }
9997                 break;
9998             case OA_FILEREF:
9999                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
10000                     if (kid->op_type == OP_CONST &&
10001                         (kid->op_private & OPpCONST_BARE))
10002                     {
10003                         OP * const newop = newGVOP(OP_GV, 0,
10004                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
10005                         /* replace kid with newop in chain */
10006                         op_sibling_splice(o, prev_kid, 1, newop);
10007                         op_free(kid);
10008                         kid = newop;
10009                     }
10010                     else if (kid->op_type == OP_READLINE) {
10011                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
10012                         bad_type_pv(numargs, "HANDLE", o, kid);
10013                     }
10014                     else {
10015                         I32 flags = OPf_SPECIAL;
10016                         I32 priv = 0;
10017                         PADOFFSET targ = 0;
10018
10019                         /* is this op a FH constructor? */
10020                         if (is_handle_constructor(o,numargs)) {
10021                             const char *name = NULL;
10022                             STRLEN len = 0;
10023                             U32 name_utf8 = 0;
10024                             bool want_dollar = TRUE;
10025
10026                             flags = 0;
10027                             /* Set a flag to tell rv2gv to vivify
10028                              * need to "prove" flag does not mean something
10029                              * else already - NI-S 1999/05/07
10030                              */
10031                             priv = OPpDEREF;
10032                             if (kid->op_type == OP_PADSV) {
10033                                 PADNAME * const pn
10034                                     = PAD_COMPNAME_SV(kid->op_targ);
10035                                 name = PadnamePV (pn);
10036                                 len  = PadnameLEN(pn);
10037                                 name_utf8 = PadnameUTF8(pn);
10038                             }
10039                             else if (kid->op_type == OP_RV2SV
10040                                      && kUNOP->op_first->op_type == OP_GV)
10041                             {
10042                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
10043                                 name = GvNAME(gv);
10044                                 len = GvNAMELEN(gv);
10045                                 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
10046                             }
10047                             else if (kid->op_type == OP_AELEM
10048                                      || kid->op_type == OP_HELEM)
10049                             {
10050                                  OP *firstop;
10051                                  OP *op = ((BINOP*)kid)->op_first;
10052                                  name = NULL;
10053                                  if (op) {
10054                                       SV *tmpstr = NULL;
10055                                       const char * const a =
10056                                            kid->op_type == OP_AELEM ?
10057                                            "[]" : "{}";
10058                                       if (((op->op_type == OP_RV2AV) ||
10059                                            (op->op_type == OP_RV2HV)) &&
10060                                           (firstop = ((UNOP*)op)->op_first) &&
10061                                           (firstop->op_type == OP_GV)) {
10062                                            /* packagevar $a[] or $h{} */
10063                                            GV * const gv = cGVOPx_gv(firstop);
10064                                            if (gv)
10065                                                 tmpstr =
10066                                                      Perl_newSVpvf(aTHX_
10067                                                                    "%s%c...%c",
10068                                                                    GvNAME(gv),
10069                                                                    a[0], a[1]);
10070                                       }
10071                                       else if (op->op_type == OP_PADAV
10072                                                || op->op_type == OP_PADHV) {
10073                                            /* lexicalvar $a[] or $h{} */
10074                                            const char * const padname =
10075                                                 PAD_COMPNAME_PV(op->op_targ);
10076                                            if (padname)
10077                                                 tmpstr =
10078                                                      Perl_newSVpvf(aTHX_
10079                                                                    "%s%c...%c",
10080                                                                    padname + 1,
10081                                                                    a[0], a[1]);
10082                                       }
10083                                       if (tmpstr) {
10084                                            name = SvPV_const(tmpstr, len);
10085                                            name_utf8 = SvUTF8(tmpstr);
10086                                            sv_2mortal(tmpstr);
10087                                       }
10088                                  }
10089                                  if (!name) {
10090                                       name = "__ANONIO__";
10091                                       len = 10;
10092                                       want_dollar = FALSE;
10093                                  }
10094                                  op_lvalue(kid, type);
10095                             }
10096                             if (name) {
10097                                 SV *namesv;
10098                                 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
10099                                 namesv = PAD_SVl(targ);
10100                                 if (want_dollar && *name != '$')
10101                                     sv_setpvs(namesv, "$");
10102                                 else
10103                                     sv_setpvs(namesv, "");
10104                                 sv_catpvn(namesv, name, len);
10105                                 if ( name_utf8 ) SvUTF8_on(namesv);
10106                             }
10107                         }
10108                         scalar(kid);
10109                         kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
10110                                     OP_RV2GV, flags);
10111                         kid->op_targ = targ;
10112                         kid->op_private |= priv;
10113                     }
10114                 }
10115                 scalar(kid);
10116                 break;
10117             case OA_SCALARREF:
10118                 if ((type == OP_UNDEF || type == OP_POS)
10119                     && numargs == 1 && !(oa >> 4)
10120                     && kid->op_type == OP_LIST)
10121                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
10122                 op_lvalue(scalar(kid), type);
10123                 break;
10124             }
10125             oa >>= 4;
10126             prev_kid = kid;
10127             kid = OpSIBLING(kid);
10128         }
10129         /* FIXME - should the numargs or-ing move after the too many
10130          * arguments check? */
10131         o->op_private |= numargs;
10132         if (kid)
10133             return too_many_arguments_pv(o,OP_DESC(o), 0);
10134         listkids(o);
10135     }
10136     else if (PL_opargs[type] & OA_DEFGV) {
10137         /* Ordering of these two is important to keep f_map.t passing.  */
10138         op_free(o);
10139         return newUNOP(type, 0, newDEFSVOP());
10140     }
10141
10142     if (oa) {
10143         while (oa & OA_OPTIONAL)
10144             oa >>= 4;
10145         if (oa && oa != OA_LIST)
10146             return too_few_arguments_pv(o,OP_DESC(o), 0);
10147     }
10148     return o;
10149 }
10150
10151 OP *
10152 Perl_ck_glob(pTHX_ OP *o)
10153 {
10154     GV *gv;
10155
10156     PERL_ARGS_ASSERT_CK_GLOB;
10157
10158     o = ck_fun(o);
10159     if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
10160         op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
10161
10162     if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
10163     {
10164         /* convert
10165          *     glob
10166          *       \ null - const(wildcard)
10167          * into
10168          *     null
10169          *       \ enter
10170          *            \ list
10171          *                 \ mark - glob - rv2cv
10172          *                             |        \ gv(CORE::GLOBAL::glob)
10173          *                             |
10174          *                              \ null - const(wildcard)
10175          */
10176         o->op_flags |= OPf_SPECIAL;
10177         o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
10178         o = S_new_entersubop(aTHX_ gv, o);
10179         o = newUNOP(OP_NULL, 0, o);
10180         o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
10181         return o;
10182     }
10183     else o->op_flags &= ~OPf_SPECIAL;
10184 #if !defined(PERL_EXTERNAL_GLOB)
10185     if (!PL_globhook) {
10186         ENTER;
10187         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
10188                                newSVpvs("File::Glob"), NULL, NULL, NULL);
10189         LEAVE;
10190     }
10191 #endif /* !PERL_EXTERNAL_GLOB */
10192     gv = (GV *)newSV(0);
10193     gv_init(gv, 0, "", 0, 0);
10194     gv_IOadd(gv);
10195     op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
10196     SvREFCNT_dec_NN(gv); /* newGVOP increased it */
10197     scalarkids(o);
10198     return o;
10199 }
10200
10201 OP *
10202 Perl_ck_grep(pTHX_ OP *o)
10203 {
10204     LOGOP *gwop;
10205     OP *kid;
10206     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
10207     PADOFFSET offset;
10208
10209     PERL_ARGS_ASSERT_CK_GREP;
10210
10211     /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
10212
10213     if (o->op_flags & OPf_STACKED) {
10214         kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
10215         if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
10216             return no_fh_allowed(o);
10217         o->op_flags &= ~OPf_STACKED;
10218     }
10219     kid = OpSIBLING(cLISTOPo->op_first);
10220     if (type == OP_MAPWHILE)
10221         list(kid);
10222     else
10223         scalar(kid);
10224     o = ck_fun(o);
10225     if (PL_parser && PL_parser->error_count)
10226         return o;
10227     kid = OpSIBLING(cLISTOPo->op_first);
10228     if (kid->op_type != OP_NULL)
10229         Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
10230     kid = kUNOP->op_first;
10231
10232     gwop = S_alloc_LOGOP(aTHX_ type, o, LINKLIST(kid));
10233     kid->op_next = (OP*)gwop;
10234     offset = pad_findmy_pvs("$_", 0);
10235     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
10236         o->op_private = gwop->op_private = 0;
10237         gwop->op_targ = pad_alloc(type, SVs_PADTMP);
10238     }
10239     else {
10240         o->op_private = gwop->op_private = OPpGREP_LEX;
10241         gwop->op_targ = o->op_targ = offset;
10242     }
10243
10244     kid = OpSIBLING(cLISTOPo->op_first);
10245     for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
10246         op_lvalue(kid, OP_GREPSTART);
10247
10248     return (OP*)gwop;
10249 }
10250
10251 OP *
10252 Perl_ck_index(pTHX_ OP *o)
10253 {
10254     PERL_ARGS_ASSERT_CK_INDEX;
10255
10256     if (o->op_flags & OPf_KIDS) {
10257         OP *kid = OpSIBLING(cLISTOPo->op_first);        /* get past pushmark */
10258         if (kid)
10259             kid = OpSIBLING(kid);                       /* get past "big" */
10260         if (kid && kid->op_type == OP_CONST) {
10261             const bool save_taint = TAINT_get;
10262             SV *sv = kSVOP->op_sv;
10263             if ((!SvPOK(sv) || SvNIOKp(sv)) && SvOK(sv) && !SvROK(sv)) {
10264                 sv = newSV(0);
10265                 sv_copypv(sv, kSVOP->op_sv);
10266                 SvREFCNT_dec_NN(kSVOP->op_sv);
10267                 kSVOP->op_sv = sv;
10268             }
10269             if (SvOK(sv)) fbm_compile(sv, 0);
10270             TAINT_set(save_taint);
10271 #ifdef NO_TAINT_SUPPORT
10272             PERL_UNUSED_VAR(save_taint);
10273 #endif
10274         }
10275     }
10276     return ck_fun(o);
10277 }
10278
10279 OP *
10280 Perl_ck_lfun(pTHX_ OP *o)
10281 {
10282     const OPCODE type = o->op_type;
10283
10284     PERL_ARGS_ASSERT_CK_LFUN;
10285
10286     return modkids(ck_fun(o), type);
10287 }
10288
10289 OP *
10290 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
10291 {
10292     PERL_ARGS_ASSERT_CK_DEFINED;
10293
10294     if ((o->op_flags & OPf_KIDS)) {
10295         switch (cUNOPo->op_first->op_type) {
10296         case OP_RV2AV:
10297         case OP_PADAV:
10298             Perl_croak(aTHX_ "Can't use 'defined(@array)'"
10299                              " (Maybe you should just omit the defined()?)");
10300         break;
10301         case OP_RV2HV:
10302         case OP_PADHV:
10303             Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
10304                              " (Maybe you should just omit the defined()?)");
10305             break;
10306         default:
10307             /* no warning */
10308             break;
10309         }
10310     }
10311     return ck_rfun(o);
10312 }
10313
10314 OP *
10315 Perl_ck_readline(pTHX_ OP *o)
10316 {
10317     PERL_ARGS_ASSERT_CK_READLINE;
10318
10319     if (o->op_flags & OPf_KIDS) {
10320          OP *kid = cLISTOPo->op_first;
10321          if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
10322     }
10323     else {
10324         OP * const newop
10325             = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
10326         op_free(o);
10327         return newop;
10328     }
10329     return o;
10330 }
10331
10332 OP *
10333 Perl_ck_rfun(pTHX_ OP *o)
10334 {
10335     const OPCODE type = o->op_type;
10336
10337     PERL_ARGS_ASSERT_CK_RFUN;
10338
10339     return refkids(ck_fun(o), type);
10340 }
10341
10342 OP *
10343 Perl_ck_listiob(pTHX_ OP *o)
10344 {
10345     OP *kid;
10346
10347     PERL_ARGS_ASSERT_CK_LISTIOB;
10348
10349     kid = cLISTOPo->op_first;
10350     if (!kid) {
10351         o = force_list(o, 1);
10352         kid = cLISTOPo->op_first;
10353     }
10354     if (kid->op_type == OP_PUSHMARK)
10355         kid = OpSIBLING(kid);
10356     if (kid && o->op_flags & OPf_STACKED)
10357         kid = OpSIBLING(kid);
10358     else if (kid && !OpHAS_SIBLING(kid)) {              /* print HANDLE; */
10359         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
10360          && !kid->op_folded) {
10361             o->op_flags |= OPf_STACKED; /* make it a filehandle */
10362             scalar(kid);
10363             /* replace old const op with new OP_RV2GV parent */
10364             kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
10365                                         OP_RV2GV, OPf_REF);
10366             kid = OpSIBLING(kid);
10367         }
10368     }
10369
10370     if (!kid)
10371         op_append_elem(o->op_type, o, newDEFSVOP());
10372
10373     if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
10374     return listkids(o);
10375 }
10376
10377 OP *
10378 Perl_ck_smartmatch(pTHX_ OP *o)
10379 {
10380     dVAR;
10381     PERL_ARGS_ASSERT_CK_SMARTMATCH;
10382     if (0 == (o->op_flags & OPf_SPECIAL)) {
10383         OP *first  = cBINOPo->op_first;
10384         OP *second = OpSIBLING(first);
10385
10386         /* Implicitly take a reference to an array or hash */
10387
10388         /* remove the original two siblings, then add back the
10389          * (possibly different) first and second sibs.
10390          */
10391         op_sibling_splice(o, NULL, 1, NULL);
10392         op_sibling_splice(o, NULL, 1, NULL);
10393         first  = ref_array_or_hash(first);
10394         second = ref_array_or_hash(second);
10395         op_sibling_splice(o, NULL, 0, second);
10396         op_sibling_splice(o, NULL, 0, first);
10397
10398         /* Implicitly take a reference to a regular expression */
10399         if (first->op_type == OP_MATCH) {
10400             OpTYPE_set(first, OP_QR);
10401         }
10402         if (second->op_type == OP_MATCH) {
10403             OpTYPE_set(second, OP_QR);
10404         }
10405     }
10406
10407     return o;
10408 }
10409
10410
10411 static OP *
10412 S_maybe_targlex(pTHX_ OP *o)
10413 {
10414     OP * const kid = cLISTOPo->op_first;
10415     /* has a disposable target? */
10416     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
10417         && !(kid->op_flags & OPf_STACKED)
10418         /* Cannot steal the second time! */
10419         && !(kid->op_private & OPpTARGET_MY)
10420         )
10421     {
10422         OP * const kkid = OpSIBLING(kid);
10423
10424         /* Can just relocate the target. */
10425         if (kkid && kkid->op_type == OP_PADSV
10426             && (!(kkid->op_private & OPpLVAL_INTRO)
10427                || kkid->op_private & OPpPAD_STATE))
10428         {
10429             kid->op_targ = kkid->op_targ;
10430             kkid->op_targ = 0;
10431             /* Now we do not need PADSV and SASSIGN.
10432              * Detach kid and free the rest. */
10433             op_sibling_splice(o, NULL, 1, NULL);
10434             op_free(o);
10435             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
10436             return kid;
10437         }
10438     }
10439     return o;
10440 }
10441
10442 OP *
10443 Perl_ck_sassign(pTHX_ OP *o)
10444 {
10445     dVAR;
10446     OP * const kid = cLISTOPo->op_first;
10447
10448     PERL_ARGS_ASSERT_CK_SASSIGN;
10449
10450     if (OpHAS_SIBLING(kid)) {
10451         OP *kkid = OpSIBLING(kid);
10452         /* For state variable assignment with attributes, kkid is a list op
10453            whose op_last is a padsv. */
10454         if ((kkid->op_type == OP_PADSV ||
10455              (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
10456               (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
10457              )
10458             )
10459                 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
10460                     == (OPpLVAL_INTRO|OPpPAD_STATE)) {
10461             const PADOFFSET target = kkid->op_targ;
10462             OP *const other = newOP(OP_PADSV,
10463                                     kkid->op_flags
10464                                     | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
10465             OP *const first = newOP(OP_NULL, 0);
10466             OP *const nullop =
10467                 newCONDOP(0, first, o, other);
10468             /* XXX targlex disabled for now; see ticket #124160
10469                 newCONDOP(0, first, S_maybe_targlex(aTHX_ o), other);
10470              */
10471             OP *const condop = first->op_next;
10472
10473             OpTYPE_set(condop, OP_ONCE);
10474             other->op_targ = target;
10475             nullop->op_flags |= OPf_WANT_SCALAR;
10476
10477             /* Store the initializedness of state vars in a separate
10478                pad entry.  */
10479             condop->op_targ =
10480               pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
10481             /* hijacking PADSTALE for uninitialized state variables */
10482             SvPADSTALE_on(PAD_SVl(condop->op_targ));
10483
10484             return nullop;
10485         }
10486     }
10487     return S_maybe_targlex(aTHX_ o);
10488 }
10489
10490 OP *
10491 Perl_ck_match(pTHX_ OP *o)
10492 {
10493     PERL_ARGS_ASSERT_CK_MATCH;
10494
10495     if (o->op_type != OP_QR && PL_compcv) {
10496         const PADOFFSET offset = pad_findmy_pvs("$_", 0);
10497         if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
10498             o->op_targ = offset;
10499             o->op_private |= OPpTARGET_MY;
10500         }
10501     }
10502     if (o->op_type == OP_MATCH || o->op_type == OP_QR)
10503         o->op_private |= OPpRUNTIME;
10504     return o;
10505 }
10506
10507 OP *
10508 Perl_ck_method(pTHX_ OP *o)
10509 {
10510     SV *sv, *methsv, *rclass;
10511     const char* method;
10512     char* compatptr;
10513     int utf8;
10514     STRLEN len, nsplit = 0, i;
10515     OP* new_op;
10516     OP * const kid = cUNOPo->op_first;
10517
10518     PERL_ARGS_ASSERT_CK_METHOD;
10519     if (kid->op_type != OP_CONST) return o;
10520
10521     sv = kSVOP->op_sv;
10522
10523     /* replace ' with :: */
10524     while ((compatptr = strchr(SvPVX(sv), '\''))) {
10525         *compatptr = ':';
10526         sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
10527     }
10528
10529     method = SvPVX_const(sv);
10530     len = SvCUR(sv);
10531     utf8 = SvUTF8(sv) ? -1 : 1;
10532
10533     for (i = len - 1; i > 0; --i) if (method[i] == ':') {
10534         nsplit = i+1;
10535         break;
10536     }
10537
10538     methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
10539
10540     if (!nsplit) { /* $proto->method() */
10541         op_free(o);
10542         return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
10543     }
10544
10545     if (nsplit == 7 && memEQ(method, "SUPER::", nsplit)) { /* $proto->SUPER::method() */
10546         op_free(o);
10547         return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
10548     }
10549
10550     /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
10551     if (nsplit >= 9 && strnEQ(method+nsplit-9, "::SUPER::", 9)) {
10552         rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
10553         new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
10554     } else {
10555         rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
10556         new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
10557     }
10558 #ifdef USE_ITHREADS
10559     op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
10560 #else
10561     cMETHOPx(new_op)->op_rclass_sv = rclass;
10562 #endif
10563     op_free(o);
10564     return new_op;
10565 }
10566
10567 OP *
10568 Perl_ck_null(pTHX_ OP *o)
10569 {
10570     PERL_ARGS_ASSERT_CK_NULL;
10571     PERL_UNUSED_CONTEXT;
10572     return o;
10573 }
10574
10575 OP *
10576 Perl_ck_open(pTHX_ OP *o)
10577 {
10578     PERL_ARGS_ASSERT_CK_OPEN;
10579
10580     S_io_hints(aTHX_ o);
10581     {
10582          /* In case of three-arg dup open remove strictness
10583           * from the last arg if it is a bareword. */
10584          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
10585          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
10586          OP *oa;
10587          const char *mode;
10588
10589          if ((last->op_type == OP_CONST) &&             /* The bareword. */
10590              (last->op_private & OPpCONST_BARE) &&
10591              (last->op_private & OPpCONST_STRICT) &&
10592              (oa = OpSIBLING(first)) &&         /* The fh. */
10593              (oa = OpSIBLING(oa)) &&                    /* The mode. */
10594              (oa->op_type == OP_CONST) &&
10595              SvPOK(((SVOP*)oa)->op_sv) &&
10596              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
10597              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
10598              (last == OpSIBLING(oa)))                   /* The bareword. */
10599               last->op_private &= ~OPpCONST_STRICT;
10600     }
10601     return ck_fun(o);
10602 }
10603
10604 OP *
10605 Perl_ck_prototype(pTHX_ OP *o)
10606 {
10607     PERL_ARGS_ASSERT_CK_PROTOTYPE;
10608     if (!(o->op_flags & OPf_KIDS)) {
10609         op_free(o);
10610         return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
10611     }
10612     return o;
10613 }
10614
10615 OP *
10616 Perl_ck_refassign(pTHX_ OP *o)
10617 {
10618     OP * const right = cLISTOPo->op_first;
10619     OP * const left = OpSIBLING(right);
10620     OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
10621     bool stacked = 0;
10622
10623     PERL_ARGS_ASSERT_CK_REFASSIGN;
10624     assert (left);
10625     assert (left->op_type == OP_SREFGEN);
10626
10627     o->op_private = varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE);
10628
10629     switch (varop->op_type) {
10630     case OP_PADAV:
10631         o->op_private |= OPpLVREF_AV;
10632         goto settarg;
10633     case OP_PADHV:
10634         o->op_private |= OPpLVREF_HV;
10635     case OP_PADSV:
10636       settarg:
10637         o->op_targ = varop->op_targ;
10638         varop->op_targ = 0;
10639         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
10640         break;
10641     case OP_RV2AV:
10642         o->op_private |= OPpLVREF_AV;
10643         goto checkgv;
10644         NOT_REACHED; /* NOTREACHED */
10645     case OP_RV2HV:
10646         o->op_private |= OPpLVREF_HV;
10647         /* FALLTHROUGH */
10648     case OP_RV2SV:
10649       checkgv:
10650         if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
10651       detach_and_stack:
10652         /* Point varop to its GV kid, detached.  */
10653         varop = op_sibling_splice(varop, NULL, -1, NULL);
10654         stacked = TRUE;
10655         break;
10656     case OP_RV2CV: {
10657         OP * const kidparent =
10658             OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
10659         OP * const kid = cUNOPx(kidparent)->op_first;
10660         o->op_private |= OPpLVREF_CV;
10661         if (kid->op_type == OP_GV) {
10662             varop = kidparent;
10663             goto detach_and_stack;
10664         }
10665         if (kid->op_type != OP_PADCV)   goto bad;
10666         o->op_targ = kid->op_targ;
10667         kid->op_targ = 0;
10668         break;
10669     }
10670     case OP_AELEM:
10671     case OP_HELEM:
10672         o->op_private |= OPpLVREF_ELEM;
10673         op_null(varop);
10674         stacked = TRUE;
10675         /* Detach varop.  */
10676         op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
10677         break;
10678     default:
10679       bad:
10680         /* diag_listed_as: Can't modify reference to %s in %s assignment */
10681         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
10682                                 "assignment",
10683                                  OP_DESC(varop)));
10684         return o;
10685     }
10686     if (!FEATURE_REFALIASING_IS_ENABLED)
10687         Perl_croak(aTHX_
10688                   "Experimental aliasing via reference not enabled");
10689     Perl_ck_warner_d(aTHX_
10690                      packWARN(WARN_EXPERIMENTAL__REFALIASING),
10691                     "Aliasing via reference is experimental");
10692     if (stacked) {
10693         o->op_flags |= OPf_STACKED;
10694         op_sibling_splice(o, right, 1, varop);
10695     }
10696     else {
10697         o->op_flags &=~ OPf_STACKED;
10698         op_sibling_splice(o, right, 1, NULL);
10699     }
10700     op_free(left);
10701     return o;
10702 }
10703
10704 OP *
10705 Perl_ck_repeat(pTHX_ OP *o)
10706 {
10707     PERL_ARGS_ASSERT_CK_REPEAT;
10708
10709     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
10710         OP* kids;
10711         o->op_private |= OPpREPEAT_DOLIST;
10712         kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
10713         kids = force_list(kids, 1); /* promote it to a list */
10714         op_sibling_splice(o, NULL, 0, kids); /* and add back */
10715     }
10716     else
10717         scalar(o);
10718     return o;
10719 }
10720
10721 OP *
10722 Perl_ck_require(pTHX_ OP *o)
10723 {
10724     GV* gv;
10725
10726     PERL_ARGS_ASSERT_CK_REQUIRE;
10727
10728     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
10729         SVOP * const kid = (SVOP*)cUNOPo->op_first;
10730         HEK *hek;
10731         U32 hash;
10732         char *s;
10733         STRLEN len;
10734         if (kid->op_type == OP_CONST) {
10735           SV * const sv = kid->op_sv;
10736           U32 const was_readonly = SvREADONLY(sv);
10737           if (kid->op_private & OPpCONST_BARE) {
10738             dVAR;
10739             const char *end;
10740
10741             if (was_readonly) {
10742                     SvREADONLY_off(sv);
10743             }
10744             if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
10745
10746             s = SvPVX(sv);
10747             len = SvCUR(sv);
10748             end = s + len;
10749             for (; s < end; s++) {
10750                 if (*s == ':' && s[1] == ':') {
10751                     *s = '/';
10752                     Move(s+2, s+1, end - s - 1, char);
10753                     --end;
10754                 }
10755             }
10756             SvEND_set(sv, end);
10757             sv_catpvs(sv, ".pm");
10758             PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
10759             hek = share_hek(SvPVX(sv),
10760                             (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
10761                             hash);
10762             sv_sethek(sv, hek);
10763             unshare_hek(hek);
10764             SvFLAGS(sv) |= was_readonly;
10765           }
10766           else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
10767                 && !SvVOK(sv)) {
10768             s = SvPV(sv, len);
10769             if (SvREFCNT(sv) > 1) {
10770                 kid->op_sv = newSVpvn_share(
10771                     s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
10772                 SvREFCNT_dec_NN(sv);
10773             }
10774             else {
10775                 dVAR;
10776                 if (was_readonly) SvREADONLY_off(sv);
10777                 PERL_HASH(hash, s, len);
10778                 hek = share_hek(s,
10779                                 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
10780                                 hash);
10781                 sv_sethek(sv, hek);
10782                 unshare_hek(hek);
10783                 SvFLAGS(sv) |= was_readonly;
10784             }
10785           }
10786         }
10787     }
10788
10789     if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
10790         /* handle override, if any */
10791      && (gv = gv_override("require", 7))) {
10792         OP *kid, *newop;
10793         if (o->op_flags & OPf_KIDS) {
10794             kid = cUNOPo->op_first;
10795             op_sibling_splice(o, NULL, -1, NULL);
10796         }
10797         else {
10798             kid = newDEFSVOP();
10799         }
10800         op_free(o);
10801         newop = S_new_entersubop(aTHX_ gv, kid);
10802         return newop;
10803     }
10804
10805     return ck_fun(o);
10806 }
10807
10808 OP *
10809 Perl_ck_return(pTHX_ OP *o)
10810 {
10811     OP *kid;
10812
10813     PERL_ARGS_ASSERT_CK_RETURN;
10814
10815     kid = OpSIBLING(cLISTOPo->op_first);
10816     if (CvLVALUE(PL_compcv)) {
10817         for (; kid; kid = OpSIBLING(kid))
10818             op_lvalue(kid, OP_LEAVESUBLV);
10819     }
10820
10821     return o;
10822 }
10823
10824 OP *
10825 Perl_ck_select(pTHX_ OP *o)
10826 {
10827     dVAR;
10828     OP* kid;
10829
10830     PERL_ARGS_ASSERT_CK_SELECT;
10831
10832     if (o->op_flags & OPf_KIDS) {
10833         kid = OpSIBLING(cLISTOPo->op_first);     /* get past pushmark */
10834         if (kid && OpHAS_SIBLING(kid)) {
10835             OpTYPE_set(o, OP_SSELECT);
10836             o = ck_fun(o);
10837             return fold_constants(op_integerize(op_std_init(o)));
10838         }
10839     }
10840     o = ck_fun(o);
10841     kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
10842     if (kid && kid->op_type == OP_RV2GV)
10843         kid->op_private &= ~HINT_STRICT_REFS;
10844     return o;
10845 }
10846
10847 OP *
10848 Perl_ck_shift(pTHX_ OP *o)
10849 {
10850     const I32 type = o->op_type;
10851
10852     PERL_ARGS_ASSERT_CK_SHIFT;
10853
10854     if (!(o->op_flags & OPf_KIDS)) {
10855         OP *argop;
10856
10857         if (!CvUNIQUE(PL_compcv)) {
10858             o->op_flags |= OPf_SPECIAL;
10859             return o;
10860         }
10861
10862         argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
10863         op_free(o);
10864         return newUNOP(type, 0, scalar(argop));
10865     }
10866     return scalar(ck_fun(o));
10867 }
10868
10869 OP *
10870 Perl_ck_sort(pTHX_ OP *o)
10871 {
10872     OP *firstkid;
10873     OP *kid;
10874     HV * const hinthv =
10875         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
10876     U8 stacked;
10877
10878     PERL_ARGS_ASSERT_CK_SORT;
10879
10880     if (hinthv) {
10881             SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
10882             if (svp) {
10883                 const I32 sorthints = (I32)SvIV(*svp);
10884                 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
10885                     o->op_private |= OPpSORT_QSORT;
10886                 if ((sorthints & HINT_SORT_STABLE) != 0)
10887                     o->op_private |= OPpSORT_STABLE;
10888             }
10889     }
10890
10891     if (o->op_flags & OPf_STACKED)
10892         simplify_sort(o);
10893     firstkid = OpSIBLING(cLISTOPo->op_first);           /* get past pushmark */
10894
10895     if ((stacked = o->op_flags & OPf_STACKED)) {        /* may have been cleared */
10896         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
10897
10898         /* if the first arg is a code block, process it and mark sort as
10899          * OPf_SPECIAL */
10900         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
10901             LINKLIST(kid);
10902             if (kid->op_type == OP_LEAVE)
10903                     op_null(kid);                       /* wipe out leave */
10904             /* Prevent execution from escaping out of the sort block. */
10905             kid->op_next = 0;
10906
10907             /* provide scalar context for comparison function/block */
10908             kid = scalar(firstkid);
10909             kid->op_next = kid;
10910             o->op_flags |= OPf_SPECIAL;
10911         }
10912         else if (kid->op_type == OP_CONST
10913               && kid->op_private & OPpCONST_BARE) {
10914             char tmpbuf[256];
10915             STRLEN len;
10916             PADOFFSET off;
10917             const char * const name = SvPV(kSVOP_sv, len);
10918             *tmpbuf = '&';
10919             assert (len < 256);
10920             Copy(name, tmpbuf+1, len, char);
10921             off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv));
10922             if (off != NOT_IN_PAD) {
10923                 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
10924                     SV * const fq =
10925                         newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
10926                     sv_catpvs(fq, "::");
10927                     sv_catsv(fq, kSVOP_sv);
10928                     SvREFCNT_dec_NN(kSVOP_sv);
10929                     kSVOP->op_sv = fq;
10930                 }
10931                 else {
10932                     OP * const padop = newOP(OP_PADCV, 0);
10933                     padop->op_targ = off;
10934                     /* replace the const op with the pad op */
10935                     op_sibling_splice(firstkid, NULL, 1, padop);
10936                     op_free(kid);
10937                 }
10938             }
10939         }
10940
10941         firstkid = OpSIBLING(firstkid);
10942     }
10943
10944     for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
10945         /* provide list context for arguments */
10946         list(kid);
10947         if (stacked)
10948             op_lvalue(kid, OP_GREPSTART);
10949     }
10950
10951     return o;
10952 }
10953
10954 /* for sort { X } ..., where X is one of
10955  *   $a <=> $b, $b <= $a, $a cmp $b, $b cmp $a
10956  * elide the second child of the sort (the one containing X),
10957  * and set these flags as appropriate
10958         OPpSORT_NUMERIC;
10959         OPpSORT_INTEGER;
10960         OPpSORT_DESCEND;
10961  * Also, check and warn on lexical $a, $b.
10962  */
10963
10964 STATIC void
10965 S_simplify_sort(pTHX_ OP *o)
10966 {
10967     OP *kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
10968     OP *k;
10969     int descending;
10970     GV *gv;
10971     const char *gvname;
10972     bool have_scopeop;
10973
10974     PERL_ARGS_ASSERT_SIMPLIFY_SORT;
10975
10976     kid = kUNOP->op_first;                              /* get past null */
10977     if (!(have_scopeop = kid->op_type == OP_SCOPE)
10978      && kid->op_type != OP_LEAVE)
10979         return;
10980     kid = kLISTOP->op_last;                             /* get past scope */
10981     switch(kid->op_type) {
10982         case OP_NCMP:
10983         case OP_I_NCMP:
10984         case OP_SCMP:
10985             if (!have_scopeop) goto padkids;
10986             break;
10987         default:
10988             return;
10989     }
10990     k = kid;                                            /* remember this node*/
10991     if (kBINOP->op_first->op_type != OP_RV2SV
10992      || kBINOP->op_last ->op_type != OP_RV2SV)
10993     {
10994         /*
10995            Warn about my($a) or my($b) in a sort block, *if* $a or $b is
10996            then used in a comparison.  This catches most, but not
10997            all cases.  For instance, it catches
10998                sort { my($a); $a <=> $b }
10999            but not
11000                sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
11001            (although why you'd do that is anyone's guess).
11002         */
11003
11004        padkids:
11005         if (!ckWARN(WARN_SYNTAX)) return;
11006         kid = kBINOP->op_first;
11007         do {
11008             if (kid->op_type == OP_PADSV) {
11009                 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
11010                 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
11011                  && (  PadnamePV(name)[1] == 'a'
11012                     || PadnamePV(name)[1] == 'b'  ))
11013                     /* diag_listed_as: "my %s" used in sort comparison */
11014                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11015                                      "\"%s %s\" used in sort comparison",
11016                                       PadnameIsSTATE(name)
11017                                         ? "state"
11018                                         : "my",
11019                                       PadnamePV(name));
11020             }
11021         } while ((kid = OpSIBLING(kid)));
11022         return;
11023     }
11024     kid = kBINOP->op_first;                             /* get past cmp */
11025     if (kUNOP->op_first->op_type != OP_GV)
11026         return;
11027     kid = kUNOP->op_first;                              /* get past rv2sv */
11028     gv = kGVOP_gv;
11029     if (GvSTASH(gv) != PL_curstash)
11030         return;
11031     gvname = GvNAME(gv);
11032     if (*gvname == 'a' && gvname[1] == '\0')
11033         descending = 0;
11034     else if (*gvname == 'b' && gvname[1] == '\0')
11035         descending = 1;
11036     else
11037         return;
11038
11039     kid = k;                                            /* back to cmp */
11040     /* already checked above that it is rv2sv */
11041     kid = kBINOP->op_last;                              /* down to 2nd arg */
11042     if (kUNOP->op_first->op_type != OP_GV)
11043         return;
11044     kid = kUNOP->op_first;                              /* get past rv2sv */
11045     gv = kGVOP_gv;
11046     if (GvSTASH(gv) != PL_curstash)
11047         return;
11048     gvname = GvNAME(gv);
11049     if ( descending
11050          ? !(*gvname == 'a' && gvname[1] == '\0')
11051          : !(*gvname == 'b' && gvname[1] == '\0'))
11052         return;
11053     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
11054     if (descending)
11055         o->op_private |= OPpSORT_DESCEND;
11056     if (k->op_type == OP_NCMP)
11057         o->op_private |= OPpSORT_NUMERIC;
11058     if (k->op_type == OP_I_NCMP)
11059         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
11060     kid = OpSIBLING(cLISTOPo->op_first);
11061     /* cut out and delete old block (second sibling) */
11062     op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
11063     op_free(kid);
11064 }
11065
11066 OP *
11067 Perl_ck_split(pTHX_ OP *o)
11068 {
11069     dVAR;
11070     OP *kid;
11071
11072     PERL_ARGS_ASSERT_CK_SPLIT;
11073
11074     if (o->op_flags & OPf_STACKED)
11075         return no_fh_allowed(o);
11076
11077     kid = cLISTOPo->op_first;
11078     if (kid->op_type != OP_NULL)
11079         Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
11080     /* delete leading NULL node, then add a CONST if no other nodes */
11081     op_sibling_splice(o, NULL, 1,
11082         OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
11083     op_free(kid);
11084     kid = cLISTOPo->op_first;
11085
11086     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
11087         /* remove kid, and replace with new optree */
11088         op_sibling_splice(o, NULL, 1, NULL);
11089         /* OPf_SPECIAL is used to trigger split " " behavior */
11090         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, NULL, 0, 0);
11091         op_sibling_splice(o, NULL, 0, kid);
11092     }
11093     OpTYPE_set(kid, OP_PUSHRE);
11094     /* target implies @ary=..., so wipe it */
11095     kid->op_targ = 0;
11096     scalar(kid);
11097     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
11098       Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
11099                      "Use of /g modifier is meaningless in split");
11100     }
11101
11102     if (!OpHAS_SIBLING(kid))
11103         op_append_elem(OP_SPLIT, o, newDEFSVOP());
11104
11105     kid = OpSIBLING(kid);
11106     assert(kid);
11107     scalar(kid);
11108
11109     if (!OpHAS_SIBLING(kid))
11110     {
11111         op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
11112         o->op_private |= OPpSPLIT_IMPLIM;
11113     }
11114     assert(OpHAS_SIBLING(kid));
11115
11116     kid = OpSIBLING(kid);
11117     scalar(kid);
11118
11119     if (OpHAS_SIBLING(kid))
11120         return too_many_arguments_pv(o,OP_DESC(o), 0);
11121
11122     return o;
11123 }
11124
11125 OP *
11126 Perl_ck_stringify(pTHX_ OP *o)
11127 {
11128     OP * const kid = OpSIBLING(cUNOPo->op_first);
11129     PERL_ARGS_ASSERT_CK_STRINGIFY;
11130     if ((   kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
11131          || kid->op_type == OP_LC   || kid->op_type == OP_LCFIRST
11132          || kid->op_type == OP_UC   || kid->op_type == OP_UCFIRST)
11133         && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
11134     {
11135         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
11136         op_free(o);
11137         return kid;
11138     }
11139     return ck_fun(o);
11140 }
11141
11142 OP *
11143 Perl_ck_join(pTHX_ OP *o)
11144 {
11145     OP * const kid = OpSIBLING(cLISTOPo->op_first);
11146
11147     PERL_ARGS_ASSERT_CK_JOIN;
11148
11149     if (kid && kid->op_type == OP_MATCH) {
11150         if (ckWARN(WARN_SYNTAX)) {
11151             const REGEXP *re = PM_GETRE(kPMOP);
11152             const SV *msg = re
11153                     ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
11154                                             SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
11155                     : newSVpvs_flags( "STRING", SVs_TEMP );
11156             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11157                         "/%"SVf"/ should probably be written as \"%"SVf"\"",
11158                         SVfARG(msg), SVfARG(msg));
11159         }
11160     }
11161     if (kid
11162      && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
11163         || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
11164         || (  kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
11165            && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
11166     {
11167         const OP * const bairn = OpSIBLING(kid); /* the list */
11168         if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
11169          && OP_GIMME(bairn,0) == G_SCALAR)
11170         {
11171             OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
11172                                      op_sibling_splice(o, kid, 1, NULL));
11173             op_free(o);
11174             return ret;
11175         }
11176     }
11177
11178     return ck_fun(o);
11179 }
11180
11181 /*
11182 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
11183
11184 Examines an op, which is expected to identify a subroutine at runtime,
11185 and attempts to determine at compile time which subroutine it identifies.
11186 This is normally used during Perl compilation to determine whether
11187 a prototype can be applied to a function call.  I<cvop> is the op
11188 being considered, normally an C<rv2cv> op.  A pointer to the identified
11189 subroutine is returned, if it could be determined statically, and a null
11190 pointer is returned if it was not possible to determine statically.
11191
11192 Currently, the subroutine can be identified statically if the RV that the
11193 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
11194 A C<gv> op is suitable if the GV's CV slot is populated.  A C<const> op is
11195 suitable if the constant value must be an RV pointing to a CV.  Details of
11196 this process may change in future versions of Perl.  If the C<rv2cv> op
11197 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
11198 the subroutine statically: this flag is used to suppress compile-time
11199 magic on a subroutine call, forcing it to use default runtime behaviour.
11200
11201 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
11202 of a GV reference is modified.  If a GV was examined and its CV slot was
11203 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
11204 If the op is not optimised away, and the CV slot is later populated with
11205 a subroutine having a prototype, that flag eventually triggers the warning
11206 "called too early to check prototype".
11207
11208 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
11209 of returning a pointer to the subroutine it returns a pointer to the
11210 GV giving the most appropriate name for the subroutine in this context.
11211 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
11212 (C<CvANON>) subroutine that is referenced through a GV it will be the
11213 referencing GV.  The resulting C<GV*> is cast to C<CV*> to be returned.
11214 A null pointer is returned as usual if there is no statically-determinable
11215 subroutine.
11216
11217 =cut
11218 */
11219
11220 /* shared by toke.c:yylex */
11221 CV *
11222 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
11223 {
11224     PADNAME *name = PAD_COMPNAME(off);
11225     CV *compcv = PL_compcv;
11226     while (PadnameOUTER(name)) {
11227         assert(PARENT_PAD_INDEX(name));
11228         compcv = CvOUTSIDE(compcv);
11229         name = PadlistNAMESARRAY(CvPADLIST(compcv))
11230                 [off = PARENT_PAD_INDEX(name)];
11231     }
11232     assert(!PadnameIsOUR(name));
11233     if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
11234         return PadnamePROTOCV(name);
11235     }
11236     return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
11237 }
11238
11239 CV *
11240 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
11241 {
11242     OP *rvop;
11243     CV *cv;
11244     GV *gv;
11245     PERL_ARGS_ASSERT_RV2CV_OP_CV;
11246     if (flags & ~RV2CVOPCV_FLAG_MASK)
11247         Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
11248     if (cvop->op_type != OP_RV2CV)
11249         return NULL;
11250     if (cvop->op_private & OPpENTERSUB_AMPER)
11251         return NULL;
11252     if (!(cvop->op_flags & OPf_KIDS))
11253         return NULL;
11254     rvop = cUNOPx(cvop)->op_first;
11255     switch (rvop->op_type) {
11256         case OP_GV: {
11257             gv = cGVOPx_gv(rvop);
11258             if (!isGV(gv)) {
11259                 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
11260                     cv = MUTABLE_CV(SvRV(gv));
11261                     gv = NULL;
11262                     break;
11263                 }
11264                 if (flags & RV2CVOPCV_RETURN_STUB)
11265                     return (CV *)gv;
11266                 else return NULL;
11267             }
11268             cv = GvCVu(gv);
11269             if (!cv) {
11270                 if (flags & RV2CVOPCV_MARK_EARLY)
11271                     rvop->op_private |= OPpEARLY_CV;
11272                 return NULL;
11273             }
11274         } break;
11275         case OP_CONST: {
11276             SV *rv = cSVOPx_sv(rvop);
11277             if (!SvROK(rv))
11278                 return NULL;
11279             cv = (CV*)SvRV(rv);
11280             gv = NULL;
11281         } break;
11282         case OP_PADCV: {
11283             cv = find_lexical_cv(rvop->op_targ);
11284             gv = NULL;
11285         } break;
11286         default: {
11287             return NULL;
11288         } NOT_REACHED; /* NOTREACHED */
11289     }
11290     if (SvTYPE((SV*)cv) != SVt_PVCV)
11291         return NULL;
11292     if (flags & (RV2CVOPCV_RETURN_NAME_GV|RV2CVOPCV_MAYBE_NAME_GV)) {
11293         if ((!CvANON(cv) || !gv) && !CvLEXICAL(cv)
11294          && ((flags & RV2CVOPCV_RETURN_NAME_GV) || !CvNAMED(cv)))
11295             gv = CvGV(cv);
11296         return (CV*)gv;
11297     } else {
11298         return cv;
11299     }
11300 }
11301
11302 /*
11303 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
11304
11305 Performs the default fixup of the arguments part of an C<entersub>
11306 op tree.  This consists of applying list context to each of the
11307 argument ops.  This is the standard treatment used on a call marked
11308 with C<&>, or a method call, or a call through a subroutine reference,
11309 or any other call where the callee can't be identified at compile time,
11310 or a call where the callee has no prototype.
11311
11312 =cut
11313 */
11314
11315 OP *
11316 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
11317 {
11318     OP *aop;
11319     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
11320     aop = cUNOPx(entersubop)->op_first;
11321     if (!OpHAS_SIBLING(aop))
11322         aop = cUNOPx(aop)->op_first;
11323     for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
11324         list(aop);
11325         op_lvalue(aop, OP_ENTERSUB);
11326     }
11327     return entersubop;
11328 }
11329
11330 /*
11331 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
11332
11333 Performs the fixup of the arguments part of an C<entersub> op tree
11334 based on a subroutine prototype.  This makes various modifications to
11335 the argument ops, from applying context up to inserting C<refgen> ops,
11336 and checking the number and syntactic types of arguments, as directed by
11337 the prototype.  This is the standard treatment used on a subroutine call,
11338 not marked with C<&>, where the callee can be identified at compile time
11339 and has a prototype.
11340
11341 I<protosv> supplies the subroutine prototype to be applied to the call.
11342 It may be a normal defined scalar, of which the string value will be used.
11343 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11344 that has been cast to C<SV*>) which has a prototype.  The prototype
11345 supplied, in whichever form, does not need to match the actual callee
11346 referenced by the op tree.
11347
11348 If the argument ops disagree with the prototype, for example by having
11349 an unacceptable number of arguments, a valid op tree is returned anyway.
11350 The error is reflected in the parser state, normally resulting in a single
11351 exception at the top level of parsing which covers all the compilation
11352 errors that occurred.  In the error message, the callee is referred to
11353 by the name defined by the I<namegv> parameter.
11354
11355 =cut
11356 */
11357
11358 OP *
11359 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11360 {
11361     STRLEN proto_len;
11362     const char *proto, *proto_end;
11363     OP *aop, *prev, *cvop, *parent;
11364     int optional = 0;
11365     I32 arg = 0;
11366     I32 contextclass = 0;
11367     const char *e = NULL;
11368     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
11369     if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
11370         Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
11371                    "flags=%lx", (unsigned long) SvFLAGS(protosv));
11372     if (SvTYPE(protosv) == SVt_PVCV)
11373          proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
11374     else proto = SvPV(protosv, proto_len);
11375     proto = S_strip_spaces(aTHX_ proto, &proto_len);
11376     proto_end = proto + proto_len;
11377     parent = entersubop;
11378     aop = cUNOPx(entersubop)->op_first;
11379     if (!OpHAS_SIBLING(aop)) {
11380         parent = aop;
11381         aop = cUNOPx(aop)->op_first;
11382     }
11383     prev = aop;
11384     aop = OpSIBLING(aop);
11385     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11386     while (aop != cvop) {
11387         OP* o3 = aop;
11388
11389         if (proto >= proto_end)
11390         {
11391             SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11392             yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf,
11393                                         SVfARG(namesv)), SvUTF8(namesv));
11394             return entersubop;
11395         }
11396
11397         switch (*proto) {
11398             case ';':
11399                 optional = 1;
11400                 proto++;
11401                 continue;
11402             case '_':
11403                 /* _ must be at the end */
11404                 if (proto[1] && !strchr(";@%", proto[1]))
11405                     goto oops;
11406                 /* FALLTHROUGH */
11407             case '$':
11408                 proto++;
11409                 arg++;
11410                 scalar(aop);
11411                 break;
11412             case '%':
11413             case '@':
11414                 list(aop);
11415                 arg++;
11416                 break;
11417             case '&':
11418                 proto++;
11419                 arg++;
11420                 if (    o3->op_type != OP_UNDEF
11421                     && (o3->op_type != OP_SREFGEN
11422                         || (  cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
11423                                 != OP_ANONCODE
11424                             && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
11425                                 != OP_RV2CV)))
11426                     bad_type_gv(arg, namegv, o3,
11427                             arg == 1 ? "block or sub {}" : "sub {}");
11428                 break;
11429             case '*':
11430                 /* '*' allows any scalar type, including bareword */
11431                 proto++;
11432                 arg++;
11433                 if (o3->op_type == OP_RV2GV)
11434                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
11435                 else if (o3->op_type == OP_CONST)
11436                     o3->op_private &= ~OPpCONST_STRICT;
11437                 scalar(aop);
11438                 break;
11439             case '+':
11440                 proto++;
11441                 arg++;
11442                 if (o3->op_type == OP_RV2AV ||
11443                     o3->op_type == OP_PADAV ||
11444                     o3->op_type == OP_RV2HV ||
11445                     o3->op_type == OP_PADHV
11446                 ) {
11447                     goto wrapref;
11448                 }
11449                 scalar(aop);
11450                 break;
11451             case '[': case ']':
11452                 goto oops;
11453
11454             case '\\':
11455                 proto++;
11456                 arg++;
11457             again:
11458                 switch (*proto++) {
11459                     case '[':
11460                         if (contextclass++ == 0) {
11461                             e = strchr(proto, ']');
11462                             if (!e || e == proto)
11463                                 goto oops;
11464                         }
11465                         else
11466                             goto oops;
11467                         goto again;
11468
11469                     case ']':
11470                         if (contextclass) {
11471                             const char *p = proto;
11472                             const char *const end = proto;
11473                             contextclass = 0;
11474                             while (*--p != '[')
11475                                 /* \[$] accepts any scalar lvalue */
11476                                 if (*p == '$'
11477                                  && Perl_op_lvalue_flags(aTHX_
11478                                      scalar(o3),
11479                                      OP_READ, /* not entersub */
11480                                      OP_LVALUE_NO_CROAK
11481                                     )) goto wrapref;
11482                             bad_type_gv(arg, namegv, o3,
11483                                     Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
11484                         } else
11485                             goto oops;
11486                         break;
11487                     case '*':
11488                         if (o3->op_type == OP_RV2GV)
11489                             goto wrapref;
11490                         if (!contextclass)
11491                             bad_type_gv(arg, namegv, o3, "symbol");
11492                         break;
11493                     case '&':
11494                         if (o3->op_type == OP_ENTERSUB
11495                          && !(o3->op_flags & OPf_STACKED))
11496                             goto wrapref;
11497                         if (!contextclass)
11498                             bad_type_gv(arg, namegv, o3, "subroutine");
11499                         break;
11500                     case '$':
11501                         if (o3->op_type == OP_RV2SV ||
11502                                 o3->op_type == OP_PADSV ||
11503                                 o3->op_type == OP_HELEM ||
11504                                 o3->op_type == OP_AELEM)
11505                             goto wrapref;
11506                         if (!contextclass) {
11507                             /* \$ accepts any scalar lvalue */
11508                             if (Perl_op_lvalue_flags(aTHX_
11509                                     scalar(o3),
11510                                     OP_READ,  /* not entersub */
11511                                     OP_LVALUE_NO_CROAK
11512                                )) goto wrapref;
11513                             bad_type_gv(arg, namegv, o3, "scalar");
11514                         }
11515                         break;
11516                     case '@':
11517                         if (o3->op_type == OP_RV2AV ||
11518                                 o3->op_type == OP_PADAV)
11519                         {
11520                             o3->op_flags &=~ OPf_PARENS;
11521                             goto wrapref;
11522                         }
11523                         if (!contextclass)
11524                             bad_type_gv(arg, namegv, o3, "array");
11525                         break;
11526                     case '%':
11527                         if (o3->op_type == OP_RV2HV ||
11528                                 o3->op_type == OP_PADHV)
11529                         {
11530                             o3->op_flags &=~ OPf_PARENS;
11531                             goto wrapref;
11532                         }
11533                         if (!contextclass)
11534                             bad_type_gv(arg, namegv, o3, "hash");
11535                         break;
11536                     wrapref:
11537                             aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
11538                                                 OP_REFGEN, 0);
11539                         if (contextclass && e) {
11540                             proto = e + 1;
11541                             contextclass = 0;
11542                         }
11543                         break;
11544                     default: goto oops;
11545                 }
11546                 if (contextclass)
11547                     goto again;
11548                 break;
11549             case ' ':
11550                 proto++;
11551                 continue;
11552             default:
11553             oops: {
11554                 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
11555                                   SVfARG(cv_name((CV *)namegv, NULL, 0)),
11556                                   SVfARG(protosv));
11557             }
11558         }
11559
11560         op_lvalue(aop, OP_ENTERSUB);
11561         prev = aop;
11562         aop = OpSIBLING(aop);
11563     }
11564     if (aop == cvop && *proto == '_') {
11565         /* generate an access to $_ */
11566         op_sibling_splice(parent, prev, 0, newDEFSVOP());
11567     }
11568     if (!optional && proto_end > proto &&
11569         (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
11570     {
11571         SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11572         yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf,
11573                                     SVfARG(namesv)), SvUTF8(namesv));
11574     }
11575     return entersubop;
11576 }
11577
11578 /*
11579 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
11580
11581 Performs the fixup of the arguments part of an C<entersub> op tree either
11582 based on a subroutine prototype or using default list-context processing.
11583 This is the standard treatment used on a subroutine call, not marked
11584 with C<&>, where the callee can be identified at compile time.
11585
11586 I<protosv> supplies the subroutine prototype to be applied to the call,
11587 or indicates that there is no prototype.  It may be a normal scalar,
11588 in which case if it is defined then the string value will be used
11589 as a prototype, and if it is undefined then there is no prototype.
11590 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11591 that has been cast to C<SV*>), of which the prototype will be used if it
11592 has one.  The prototype (or lack thereof) supplied, in whichever form,
11593 does not need to match the actual callee referenced by the op tree.
11594
11595 If the argument ops disagree with the prototype, for example by having
11596 an unacceptable number of arguments, a valid op tree is returned anyway.
11597 The error is reflected in the parser state, normally resulting in a single
11598 exception at the top level of parsing which covers all the compilation
11599 errors that occurred.  In the error message, the callee is referred to
11600 by the name defined by the I<namegv> parameter.
11601
11602 =cut
11603 */
11604
11605 OP *
11606 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
11607         GV *namegv, SV *protosv)
11608 {
11609     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
11610     if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
11611         return ck_entersub_args_proto(entersubop, namegv, protosv);
11612     else
11613         return ck_entersub_args_list(entersubop);
11614 }
11615
11616 OP *
11617 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11618 {
11619     int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
11620     OP *aop = cUNOPx(entersubop)->op_first;
11621
11622     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
11623
11624     if (!opnum) {
11625         OP *cvop;
11626         if (!OpHAS_SIBLING(aop))
11627             aop = cUNOPx(aop)->op_first;
11628         aop = OpSIBLING(aop);
11629         for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11630         if (aop != cvop)
11631             (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
11632
11633         op_free(entersubop);
11634         switch(GvNAME(namegv)[2]) {
11635         case 'F': return newSVOP(OP_CONST, 0,
11636                                         newSVpv(CopFILE(PL_curcop),0));
11637         case 'L': return newSVOP(
11638                            OP_CONST, 0,
11639                            Perl_newSVpvf(aTHX_
11640                              "%"IVdf, (IV)CopLINE(PL_curcop)
11641                            )
11642                          );
11643         case 'P': return newSVOP(OP_CONST, 0,
11644                                    (PL_curstash
11645                                      ? newSVhek(HvNAME_HEK(PL_curstash))
11646                                      : &PL_sv_undef
11647                                    )
11648                                 );
11649         }
11650         NOT_REACHED; /* NOTREACHED */
11651     }
11652     else {
11653         OP *prev, *cvop, *first, *parent;
11654         U32 flags = 0;
11655
11656         parent = entersubop;
11657         if (!OpHAS_SIBLING(aop)) {
11658             parent = aop;
11659             aop = cUNOPx(aop)->op_first;
11660         }
11661
11662         first = prev = aop;
11663         aop = OpSIBLING(aop);
11664         /* find last sibling */
11665         for (cvop = aop;
11666              OpHAS_SIBLING(cvop);
11667              prev = cvop, cvop = OpSIBLING(cvop))
11668             ;
11669         if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
11670             /* Usually, OPf_SPECIAL on an op with no args means that it had
11671              * parens, but these have their own meaning for that flag: */
11672             && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
11673             && opnum != OP_DELETE && opnum != OP_EXISTS)
11674                 flags |= OPf_SPECIAL;
11675         /* excise cvop from end of sibling chain */
11676         op_sibling_splice(parent, prev, 1, NULL);
11677         op_free(cvop);
11678         if (aop == cvop) aop = NULL;
11679
11680         /* detach remaining siblings from the first sibling, then
11681          * dispose of original optree */
11682
11683         if (aop)
11684             op_sibling_splice(parent, first, -1, NULL);
11685         op_free(entersubop);
11686
11687         if (opnum == OP_ENTEREVAL
11688          && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
11689             flags |= OPpEVAL_BYTES <<8;
11690
11691         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
11692         case OA_UNOP:
11693         case OA_BASEOP_OR_UNOP:
11694         case OA_FILESTATOP:
11695             return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
11696         case OA_BASEOP:
11697             if (aop) {
11698                     (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
11699                 op_free(aop);
11700             }
11701             return opnum == OP_RUNCV
11702                 ? newPVOP(OP_RUNCV,0,NULL)
11703                 : newOP(opnum,0);
11704         default:
11705             return op_convert_list(opnum,0,aop);
11706         }
11707     }
11708     NOT_REACHED; /* NOTREACHED */
11709     return entersubop;
11710 }
11711
11712 /*
11713 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
11714
11715 Retrieves the function that will be used to fix up a call to I<cv>.
11716 Specifically, the function is applied to an C<entersub> op tree for a
11717 subroutine call, not marked with C<&>, where the callee can be identified
11718 at compile time as I<cv>.
11719
11720 The C-level function pointer is returned in I<*ckfun_p>, and an SV
11721 argument for it is returned in I<*ckobj_p>.  The function is intended
11722 to be called in this manner:
11723
11724  entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
11725
11726 In this call, I<entersubop> is a pointer to the C<entersub> op,
11727 which may be replaced by the check function, and I<namegv> is a GV
11728 supplying the name that should be used by the check function to refer
11729 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11730 It is permitted to apply the check function in non-standard situations,
11731 such as to a call to a different subroutine or to a method call.
11732
11733 By default, the function is
11734 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
11735 and the SV parameter is I<cv> itself.  This implements standard
11736 prototype processing.  It can be changed, for a particular subroutine,
11737 by L</cv_set_call_checker>.
11738
11739 =cut
11740 */
11741
11742 static void
11743 S_cv_get_call_checker(CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p,
11744                       U8 *flagsp)
11745 {
11746     MAGIC *callmg;
11747     callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
11748     if (callmg) {
11749         *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
11750         *ckobj_p = callmg->mg_obj;
11751         if (flagsp) *flagsp = callmg->mg_flags;
11752     } else {
11753         *ckfun_p = Perl_ck_entersub_args_proto_or_list;
11754         *ckobj_p = (SV*)cv;
11755         if (flagsp) *flagsp = 0;
11756     }
11757 }
11758
11759 void
11760 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
11761 {
11762     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
11763     PERL_UNUSED_CONTEXT;
11764     S_cv_get_call_checker(cv, ckfun_p, ckobj_p, NULL);
11765 }
11766
11767 /*
11768 =for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 flags
11769
11770 Sets the function that will be used to fix up a call to I<cv>.
11771 Specifically, the function is applied to an C<entersub> op tree for a
11772 subroutine call, not marked with C<&>, where the callee can be identified
11773 at compile time as I<cv>.
11774
11775 The C-level function pointer is supplied in I<ckfun>, and an SV argument
11776 for it is supplied in I<ckobj>.  The function should be defined like this:
11777
11778     STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
11779
11780 It is intended to be called in this manner:
11781
11782     entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
11783
11784 In this call, I<entersubop> is a pointer to the C<entersub> op,
11785 which may be replaced by the check function, and I<namegv> supplies
11786 the name that should be used by the check function to refer
11787 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11788 It is permitted to apply the check function in non-standard situations,
11789 such as to a call to a different subroutine or to a method call.
11790
11791 I<namegv> may not actually be a GV.  For efficiency, perl may pass a
11792 CV or other SV instead.  Whatever is passed can be used as the first
11793 argument to L</cv_name>.  You can force perl to pass a GV by including
11794 C<CALL_CHECKER_REQUIRE_GV> in the I<flags>.
11795
11796 The current setting for a particular CV can be retrieved by
11797 L</cv_get_call_checker>.
11798
11799 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
11800
11801 The original form of L</cv_set_call_checker_flags>, which passes it the
11802 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.
11803
11804 =cut
11805 */
11806
11807 void
11808 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
11809 {
11810     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
11811     cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
11812 }
11813
11814 void
11815 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
11816                                      SV *ckobj, U32 flags)
11817 {
11818     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
11819     if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
11820         if (SvMAGICAL((SV*)cv))
11821             mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
11822     } else {
11823         MAGIC *callmg;
11824         sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
11825         callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
11826         assert(callmg);
11827         if (callmg->mg_flags & MGf_REFCOUNTED) {
11828             SvREFCNT_dec(callmg->mg_obj);
11829             callmg->mg_flags &= ~MGf_REFCOUNTED;
11830         }
11831         callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
11832         callmg->mg_obj = ckobj;
11833         if (ckobj != (SV*)cv) {
11834             SvREFCNT_inc_simple_void_NN(ckobj);
11835             callmg->mg_flags |= MGf_REFCOUNTED;
11836         }
11837         callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
11838                          | (U8)(flags & MGf_REQUIRE_GV) | MGf_COPY;
11839     }
11840 }
11841
11842 static void
11843 S_entersub_alloc_targ(pTHX_ OP * const o)
11844 {
11845     o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
11846     o->op_private |= OPpENTERSUB_HASTARG;
11847 }
11848
11849 OP *
11850 Perl_ck_subr(pTHX_ OP *o)
11851 {
11852     OP *aop, *cvop;
11853     CV *cv;
11854     GV *namegv;
11855     SV **const_class = NULL;
11856
11857     PERL_ARGS_ASSERT_CK_SUBR;
11858
11859     aop = cUNOPx(o)->op_first;
11860     if (!OpHAS_SIBLING(aop))
11861         aop = cUNOPx(aop)->op_first;
11862     aop = OpSIBLING(aop);
11863     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11864     cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
11865     namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
11866
11867     o->op_private &= ~1;
11868     o->op_private |= (PL_hints & HINT_STRICT_REFS);
11869     if (PERLDB_SUB && PL_curstash != PL_debstash)
11870         o->op_private |= OPpENTERSUB_DB;
11871     switch (cvop->op_type) {
11872         case OP_RV2CV:
11873             o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
11874             op_null(cvop);
11875             break;
11876         case OP_METHOD:
11877         case OP_METHOD_NAMED:
11878         case OP_METHOD_SUPER:
11879         case OP_METHOD_REDIR:
11880         case OP_METHOD_REDIR_SUPER:
11881             if (aop->op_type == OP_CONST) {
11882                 aop->op_private &= ~OPpCONST_STRICT;
11883                 const_class = &cSVOPx(aop)->op_sv;
11884             }
11885             else if (aop->op_type == OP_LIST) {
11886                 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
11887                 if (sib && sib->op_type == OP_CONST) {
11888                     sib->op_private &= ~OPpCONST_STRICT;
11889                     const_class = &cSVOPx(sib)->op_sv;
11890                 }
11891             }
11892             /* make class name a shared cow string to speedup method calls */
11893             /* constant string might be replaced with object, f.e. bigint */
11894             if (const_class && SvPOK(*const_class)) {
11895                 STRLEN len;
11896                 const char* str = SvPV(*const_class, len);
11897                 if (len) {
11898                     SV* const shared = newSVpvn_share(
11899                         str, SvUTF8(*const_class)
11900                                     ? -(SSize_t)len : (SSize_t)len,
11901                         0
11902                     );
11903                     if (SvREADONLY(*const_class))
11904                         SvREADONLY_on(shared);
11905                     SvREFCNT_dec(*const_class);
11906                     *const_class = shared;
11907                 }
11908             }
11909             break;
11910     }
11911
11912     if (!cv) {
11913         S_entersub_alloc_targ(aTHX_ o);
11914         return ck_entersub_args_list(o);
11915     } else {
11916         Perl_call_checker ckfun;
11917         SV *ckobj;
11918         U8 flags;
11919         S_cv_get_call_checker(cv, &ckfun, &ckobj, &flags);
11920         if (CvISXSUB(cv) || !CvROOT(cv))
11921             S_entersub_alloc_targ(aTHX_ o);
11922         if (!namegv) {
11923             /* The original call checker API guarantees that a GV will be
11924                be provided with the right name.  So, if the old API was
11925                used (or the REQUIRE_GV flag was passed), we have to reify
11926                the CV’s GV, unless this is an anonymous sub.  This is not
11927                ideal for lexical subs, as its stringification will include
11928                the package.  But it is the best we can do.  */
11929             if (flags & MGf_REQUIRE_GV) {
11930                 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
11931                     namegv = CvGV(cv);
11932             }
11933             else namegv = MUTABLE_GV(cv);
11934             /* After a syntax error in a lexical sub, the cv that
11935                rv2cv_op_cv returns may be a nameless stub. */
11936             if (!namegv) return ck_entersub_args_list(o);
11937
11938         }
11939         return ckfun(aTHX_ o, namegv, ckobj);
11940     }
11941 }
11942
11943 OP *
11944 Perl_ck_svconst(pTHX_ OP *o)
11945 {
11946     SV * const sv = cSVOPo->op_sv;
11947     PERL_ARGS_ASSERT_CK_SVCONST;
11948     PERL_UNUSED_CONTEXT;
11949 #ifdef PERL_OLD_COPY_ON_WRITE
11950     if (SvIsCOW(sv)) sv_force_normal(sv);
11951 #elif defined(PERL_NEW_COPY_ON_WRITE)
11952     /* Since the read-only flag may be used to protect a string buffer, we
11953        cannot do copy-on-write with existing read-only scalars that are not
11954        already copy-on-write scalars.  To allow $_ = "hello" to do COW with
11955        that constant, mark the constant as COWable here, if it is not
11956        already read-only. */
11957     if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
11958         SvIsCOW_on(sv);
11959         CowREFCNT(sv) = 0;
11960 # ifdef PERL_DEBUG_READONLY_COW
11961         sv_buf_to_ro(sv);
11962 # endif
11963     }
11964 #endif
11965     SvREADONLY_on(sv);
11966     return o;
11967 }
11968
11969 OP *
11970 Perl_ck_trunc(pTHX_ OP *o)
11971 {
11972     PERL_ARGS_ASSERT_CK_TRUNC;
11973
11974     if (o->op_flags & OPf_KIDS) {
11975         SVOP *kid = (SVOP*)cUNOPo->op_first;
11976
11977         if (kid->op_type == OP_NULL)
11978             kid = (SVOP*)OpSIBLING(kid);
11979         if (kid && kid->op_type == OP_CONST &&
11980             (kid->op_private & OPpCONST_BARE) &&
11981             !kid->op_folded)
11982         {
11983             o->op_flags |= OPf_SPECIAL;
11984             kid->op_private &= ~OPpCONST_STRICT;
11985         }
11986     }
11987     return ck_fun(o);
11988 }
11989
11990 OP *
11991 Perl_ck_substr(pTHX_ OP *o)
11992 {
11993     PERL_ARGS_ASSERT_CK_SUBSTR;
11994
11995     o = ck_fun(o);
11996     if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
11997         OP *kid = cLISTOPo->op_first;
11998
11999         if (kid->op_type == OP_NULL)
12000             kid = OpSIBLING(kid);
12001         if (kid)
12002             kid->op_flags |= OPf_MOD;
12003
12004     }
12005     return o;
12006 }
12007
12008 OP *
12009 Perl_ck_tell(pTHX_ OP *o)
12010 {
12011     PERL_ARGS_ASSERT_CK_TELL;
12012     o = ck_fun(o);
12013     if (o->op_flags & OPf_KIDS) {
12014      OP *kid = cLISTOPo->op_first;
12015      if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
12016      if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
12017     }
12018     return o;
12019 }
12020
12021 OP *
12022 Perl_ck_each(pTHX_ OP *o)
12023 {
12024     dVAR;
12025     OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
12026     const unsigned orig_type  = o->op_type;
12027     const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
12028                               : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
12029     const unsigned ref_type   = orig_type == OP_EACH ? OP_REACH
12030                               : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
12031
12032     PERL_ARGS_ASSERT_CK_EACH;
12033
12034     if (kid) {
12035         switch (kid->op_type) {
12036             case OP_PADHV:
12037             case OP_RV2HV:
12038                 break;
12039             case OP_PADAV:
12040             case OP_RV2AV:
12041                 OpTYPE_set(o, array_type);
12042                 break;
12043             case OP_CONST:
12044                 if (kid->op_private == OPpCONST_BARE
12045                  || !SvROK(cSVOPx_sv(kid))
12046                  || (  SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
12047                     && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV  )
12048                    )
12049                     /* we let ck_fun handle it */
12050                     break;
12051             default:
12052                 OpTYPE_set(o, ref_type);
12053                 scalar(kid);
12054         }
12055     }
12056     /* if treating as a reference, defer additional checks to runtime */
12057     if (o->op_type == ref_type) {
12058         /* diag_listed_as: keys on reference is experimental */
12059         Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__AUTODEREF),
12060                               "%s is experimental", PL_op_desc[ref_type]);
12061         return o;
12062     }
12063     return ck_fun(o);
12064 }
12065
12066 OP *
12067 Perl_ck_length(pTHX_ OP *o)
12068 {
12069     PERL_ARGS_ASSERT_CK_LENGTH;
12070
12071     o = ck_fun(o);
12072
12073     if (ckWARN(WARN_SYNTAX)) {
12074         const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
12075
12076         if (kid) {
12077             SV *name = NULL;
12078             const bool hash = kid->op_type == OP_PADHV
12079                            || kid->op_type == OP_RV2HV;
12080             switch (kid->op_type) {
12081                 case OP_PADHV:
12082                 case OP_PADAV:
12083                 case OP_RV2HV:
12084                 case OP_RV2AV:
12085                     name = S_op_varname(aTHX_ kid);
12086                     break;
12087                 default:
12088                     return o;
12089             }
12090             if (name)
12091                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12092                     "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
12093                     ")\"?)",
12094                     SVfARG(name), hash ? "keys " : "", SVfARG(name)
12095                 );
12096             else if (hash)
12097      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
12098                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12099                     "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
12100             else
12101      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
12102                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12103                     "length() used on @array (did you mean \"scalar(@array)\"?)");
12104         }
12105     }
12106
12107     return o;
12108 }
12109
12110 /* Check for in place reverse and sort assignments like "@a = reverse @a"
12111    and modify the optree to make them work inplace */
12112
12113 STATIC void
12114 S_inplace_aassign(pTHX_ OP *o) {
12115
12116     OP *modop, *modop_pushmark;
12117     OP *oright;
12118     OP *oleft, *oleft_pushmark;
12119
12120     PERL_ARGS_ASSERT_INPLACE_AASSIGN;
12121
12122     assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
12123
12124     assert(cUNOPo->op_first->op_type == OP_NULL);
12125     modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
12126     assert(modop_pushmark->op_type == OP_PUSHMARK);
12127     modop = OpSIBLING(modop_pushmark);
12128
12129     if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
12130         return;
12131
12132     /* no other operation except sort/reverse */
12133     if (OpHAS_SIBLING(modop))
12134         return;
12135
12136     assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
12137     if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
12138
12139     if (modop->op_flags & OPf_STACKED) {
12140         /* skip sort subroutine/block */
12141         assert(oright->op_type == OP_NULL);
12142         oright = OpSIBLING(oright);
12143     }
12144
12145     assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
12146     oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
12147     assert(oleft_pushmark->op_type == OP_PUSHMARK);
12148     oleft = OpSIBLING(oleft_pushmark);
12149
12150     /* Check the lhs is an array */
12151     if (!oleft ||
12152         (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
12153         || OpHAS_SIBLING(oleft)
12154         || (oleft->op_private & OPpLVAL_INTRO)
12155     )
12156         return;
12157
12158     /* Only one thing on the rhs */
12159     if (OpHAS_SIBLING(oright))
12160         return;
12161
12162     /* check the array is the same on both sides */
12163     if (oleft->op_type == OP_RV2AV) {
12164         if (oright->op_type != OP_RV2AV
12165             || !cUNOPx(oright)->op_first
12166             || cUNOPx(oright)->op_first->op_type != OP_GV
12167             || cUNOPx(oleft )->op_first->op_type != OP_GV
12168             || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
12169                cGVOPx_gv(cUNOPx(oright)->op_first)
12170         )
12171             return;
12172     }
12173     else if (oright->op_type != OP_PADAV
12174         || oright->op_targ != oleft->op_targ
12175     )
12176         return;
12177
12178     /* This actually is an inplace assignment */
12179
12180     modop->op_private |= OPpSORT_INPLACE;
12181
12182     /* transfer MODishness etc from LHS arg to RHS arg */
12183     oright->op_flags = oleft->op_flags;
12184
12185     /* remove the aassign op and the lhs */
12186     op_null(o);
12187     op_null(oleft_pushmark);
12188     if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
12189         op_null(cUNOPx(oleft)->op_first);
12190     op_null(oleft);
12191 }
12192
12193
12194
12195 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
12196  * that potentially represent a series of one or more aggregate derefs
12197  * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
12198  * the whole chain to a single OP_MULTIDEREF op (maybe with a few
12199  * additional ops left in too).
12200  *
12201  * The caller will have already verified that the first few ops in the
12202  * chain following 'start' indicate a multideref candidate, and will have
12203  * set 'orig_o' to the point further on in the chain where the first index
12204  * expression (if any) begins.  'orig_action' specifies what type of
12205  * beginning has already been determined by the ops between start..orig_o
12206  * (e.g.  $lex_ary[], $pkg_ary->{}, expr->[], etc).
12207  *
12208  * 'hints' contains any hints flags that need adding (currently just
12209  * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
12210  */
12211
12212 void
12213 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
12214 {
12215     dVAR;
12216     int pass;
12217     UNOP_AUX_item *arg_buf = NULL;
12218     bool reset_start_targ  = FALSE; /* start->op_targ needs zeroing */
12219     int index_skip         = -1;    /* don't output index arg on this action */
12220
12221     /* similar to regex compiling, do two passes; the first pass
12222      * determines whether the op chain is convertible and calculates the
12223      * buffer size; the second pass populates the buffer and makes any
12224      * changes necessary to ops (such as moving consts to the pad on
12225      * threaded builds).
12226      *
12227      * NB: for things like Coverity, note that both passes take the same
12228      * path through the logic tree (except for 'if (pass)' bits), since
12229      * both passes are following the same op_next chain; and in
12230      * particular, if it would return early on the second pass, it would
12231      * already have returned early on the first pass.
12232      */
12233     for (pass = 0; pass < 2; pass++) {
12234         OP *o                = orig_o;
12235         UV action            = orig_action;
12236         OP *first_elem_op    = NULL;  /* first seen aelem/helem */
12237         OP *top_op           = NULL;  /* highest [ah]elem/exists/del/rv2[ah]v */
12238         int action_count     = 0;     /* number of actions seen so far */
12239         int action_ix        = 0;     /* action_count % (actions per IV) */
12240         bool next_is_hash    = FALSE; /* is the next lookup to be a hash? */
12241         bool is_last         = FALSE; /* no more derefs to follow */
12242         bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
12243         UNOP_AUX_item *arg     = arg_buf;
12244         UNOP_AUX_item *action_ptr = arg_buf;
12245
12246         if (pass)
12247             action_ptr->uv = 0;
12248         arg++;
12249
12250         switch (action) {
12251         case MDEREF_HV_gvsv_vivify_rv2hv_helem:
12252         case MDEREF_HV_gvhv_helem:
12253             next_is_hash = TRUE;
12254             /* FALLTHROUGH */
12255         case MDEREF_AV_gvsv_vivify_rv2av_aelem:
12256         case MDEREF_AV_gvav_aelem:
12257             if (pass) {
12258 #ifdef USE_ITHREADS
12259                 arg->pad_offset = cPADOPx(start)->op_padix;
12260                 /* stop it being swiped when nulled */
12261                 cPADOPx(start)->op_padix = 0;
12262 #else
12263                 arg->sv = cSVOPx(start)->op_sv;
12264                 cSVOPx(start)->op_sv = NULL;
12265 #endif
12266             }
12267             arg++;
12268             break;
12269
12270         case MDEREF_HV_padhv_helem:
12271         case MDEREF_HV_padsv_vivify_rv2hv_helem:
12272             next_is_hash = TRUE;
12273             /* FALLTHROUGH */
12274         case MDEREF_AV_padav_aelem:
12275         case MDEREF_AV_padsv_vivify_rv2av_aelem:
12276             if (pass) {
12277                 arg->pad_offset = start->op_targ;
12278                 /* we skip setting op_targ = 0 for now, since the intact
12279                  * OP_PADXV is needed by S_check_hash_fields_and_hekify */
12280                 reset_start_targ = TRUE;
12281             }
12282             arg++;
12283             break;
12284
12285         case MDEREF_HV_pop_rv2hv_helem:
12286             next_is_hash = TRUE;
12287             /* FALLTHROUGH */
12288         case MDEREF_AV_pop_rv2av_aelem:
12289             break;
12290
12291         default:
12292             NOT_REACHED; /* NOTREACHED */
12293             return;
12294         }
12295
12296         while (!is_last) {
12297             /* look for another (rv2av/hv; get index;
12298              * aelem/helem/exists/delele) sequence */
12299
12300             OP *kid;
12301             bool is_deref;
12302             bool ok;
12303             UV index_type = MDEREF_INDEX_none;
12304
12305             if (action_count) {
12306                 /* if this is not the first lookup, consume the rv2av/hv  */
12307
12308                 /* for N levels of aggregate lookup, we normally expect
12309                  * that the first N-1 [ah]elem ops will be flagged as
12310                  * /DEREF (so they autovivifiy if necessary), and the last
12311                  * lookup op not to be.
12312                  * For other things (like @{$h{k1}{k2}}) extra scope or
12313                  * leave ops can appear, so abandon the effort in that
12314                  * case */
12315                 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
12316                     return;
12317
12318                 /* rv2av or rv2hv sKR/1 */
12319
12320                 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12321                                             |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12322                 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
12323                     return;
12324
12325                 /* at this point, we wouldn't expect any of these
12326                  * possible private flags:
12327                  * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
12328                  * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
12329                  */
12330                 ASSUME(!(o->op_private &
12331                     ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
12332
12333                 hints = (o->op_private & OPpHINT_STRICT_REFS);
12334
12335                 /* make sure the type of the previous /DEREF matches the
12336                  * type of the next lookup */
12337                 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
12338                 top_op = o;
12339
12340                 action = next_is_hash
12341                             ? MDEREF_HV_vivify_rv2hv_helem
12342                             : MDEREF_AV_vivify_rv2av_aelem;
12343                 o = o->op_next;
12344             }
12345
12346             /* if this is the second pass, and we're at the depth where
12347              * previously we encountered a non-simple index expression,
12348              * stop processing the index at this point */
12349             if (action_count != index_skip) {
12350
12351                 /* look for one or more simple ops that return an array
12352                  * index or hash key */
12353
12354                 switch (o->op_type) {
12355                 case OP_PADSV:
12356                     /* it may be a lexical var index */
12357                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
12358                                             |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12359                     ASSUME(!(o->op_private &
12360                             ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
12361
12362                     if (   OP_GIMME(o,0) == G_SCALAR
12363                         && !(o->op_flags & (OPf_REF|OPf_MOD))
12364                         && o->op_private == 0)
12365                     {
12366                         if (pass)
12367                             arg->pad_offset = o->op_targ;
12368                         arg++;
12369                         index_type = MDEREF_INDEX_padsv;
12370                         o = o->op_next;
12371                     }
12372                     break;
12373
12374                 case OP_CONST:
12375                     if (next_is_hash) {
12376                         /* it's a constant hash index */
12377                         if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
12378                             /* "use constant foo => FOO; $h{+foo}" for
12379                              * some weird FOO, can leave you with constants
12380                              * that aren't simple strings. It's not worth
12381                              * the extra hassle for those edge cases */
12382                             break;
12383
12384                         if (pass) {
12385                             UNOP *rop = NULL;
12386                             OP * helem_op = o->op_next;
12387
12388                             ASSUME(   helem_op->op_type == OP_HELEM
12389                                    || helem_op->op_type == OP_NULL);
12390                             if (helem_op->op_type == OP_HELEM) {
12391                                 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
12392                                 if (   helem_op->op_private & OPpLVAL_INTRO
12393                                     || rop->op_type != OP_RV2HV
12394                                 )
12395                                     rop = NULL;
12396                             }
12397                             S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo);
12398
12399 #ifdef USE_ITHREADS
12400                             /* Relocate sv to the pad for thread safety */
12401                             op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
12402                             arg->pad_offset = o->op_targ;
12403                             o->op_targ = 0;
12404 #else
12405                             arg->sv = cSVOPx_sv(o);
12406 #endif
12407                         }
12408                     }
12409                     else {
12410                         /* it's a constant array index */
12411                         IV iv;
12412                         SV *ix_sv = cSVOPo->op_sv;
12413                         if (!SvIOK(ix_sv))
12414                             break;
12415                         iv = SvIV(ix_sv);
12416
12417                         if (   action_count == 0
12418                             && iv >= -128
12419                             && iv <= 127
12420                             && (   action == MDEREF_AV_padav_aelem
12421                                 || action == MDEREF_AV_gvav_aelem)
12422                         )
12423                             maybe_aelemfast = TRUE;
12424
12425                         if (pass) {
12426                             arg->iv = iv;
12427                             SvREFCNT_dec_NN(cSVOPo->op_sv);
12428                         }
12429                     }
12430                     if (pass)
12431                         /* we've taken ownership of the SV */
12432                         cSVOPo->op_sv = NULL;
12433                     arg++;
12434                     index_type = MDEREF_INDEX_const;
12435                     o = o->op_next;
12436                     break;
12437
12438                 case OP_GV:
12439                     /* it may be a package var index */
12440
12441                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_SPECIAL)));
12442                     ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
12443                     if (  (o->op_flags &~ OPf_SPECIAL) != OPf_WANT_SCALAR
12444                         || o->op_private != 0
12445                     )
12446                         break;
12447
12448                     kid = o->op_next;
12449                     if (kid->op_type != OP_RV2SV)
12450                         break;
12451
12452                     ASSUME(!(kid->op_flags &
12453                             ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
12454                              |OPf_SPECIAL|OPf_PARENS)));
12455                     ASSUME(!(kid->op_private &
12456                                     ~(OPpARG1_MASK
12457                                      |OPpHINT_STRICT_REFS|OPpOUR_INTRO
12458                                      |OPpDEREF|OPpLVAL_INTRO)));
12459                     if(   (kid->op_flags &~ OPf_PARENS)
12460                             != (OPf_WANT_SCALAR|OPf_KIDS)
12461                        || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
12462                     )
12463                         break;
12464
12465                     if (pass) {
12466 #ifdef USE_ITHREADS
12467                         arg->pad_offset = cPADOPx(o)->op_padix;
12468                         /* stop it being swiped when nulled */
12469                         cPADOPx(o)->op_padix = 0;
12470 #else
12471                         arg->sv = cSVOPx(o)->op_sv;
12472                         cSVOPo->op_sv = NULL;
12473 #endif
12474                     }
12475                     arg++;
12476                     index_type = MDEREF_INDEX_gvsv;
12477                     o = kid->op_next;
12478                     break;
12479
12480                 } /* switch */
12481             } /* action_count != index_skip */
12482
12483             action |= index_type;
12484
12485
12486             /* at this point we have either:
12487              *   * detected what looks like a simple index expression,
12488              *     and expect the next op to be an [ah]elem, or
12489              *     an nulled  [ah]elem followed by a delete or exists;
12490              *  * found a more complex expression, so something other
12491              *    than the above follows.
12492              */
12493
12494             /* possibly an optimised away [ah]elem (where op_next is
12495              * exists or delete) */
12496             if (o->op_type == OP_NULL)
12497                 o = o->op_next;
12498
12499             /* at this point we're looking for an OP_AELEM, OP_HELEM,
12500              * OP_EXISTS or OP_DELETE */
12501
12502             /* if something like arybase (a.k.a $[ ) is in scope,
12503              * abandon optimisation attempt */
12504             if (  (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
12505                && PL_check[o->op_type] != Perl_ck_null)
12506                 return;
12507
12508             if (   o->op_type != OP_AELEM
12509                 || (o->op_private &
12510                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
12511                 )
12512                 maybe_aelemfast = FALSE;
12513
12514             /* look for aelem/helem/exists/delete. If it's not the last elem
12515              * lookup, it *must* have OPpDEREF_AV/HV, but not many other
12516              * flags; if it's the last, then it mustn't have
12517              * OPpDEREF_AV/HV, but may have lots of other flags, like
12518              * OPpLVAL_INTRO etc
12519              */
12520
12521             if (   index_type == MDEREF_INDEX_none
12522                 || (   o->op_type != OP_AELEM  && o->op_type != OP_HELEM
12523                     && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
12524             )
12525                 ok = FALSE;
12526             else {
12527                 /* we have aelem/helem/exists/delete with valid simple index */
12528
12529                 is_deref =    (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
12530                            && (   (o->op_private & OPpDEREF) == OPpDEREF_AV
12531                                || (o->op_private & OPpDEREF) == OPpDEREF_HV);
12532
12533                 if (is_deref) {
12534                     ASSUME(!(o->op_flags &
12535                                  ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
12536                     ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
12537
12538                     ok =    (o->op_flags &~ OPf_PARENS)
12539                                == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
12540                          && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
12541                 }
12542                 else if (o->op_type == OP_EXISTS) {
12543                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12544                                 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12545                     ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
12546                     ok =  !(o->op_private & ~OPpARG1_MASK);
12547                 }
12548                 else if (o->op_type == OP_DELETE) {
12549                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12550                                 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12551                     ASSUME(!(o->op_private &
12552                                     ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
12553                     /* don't handle slices or 'local delete'; the latter
12554                      * is fairly rare, and has a complex runtime */
12555                     ok =  !(o->op_private & ~OPpARG1_MASK);
12556                     if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
12557                         /* skip handling run-tome error */
12558                         ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
12559                 }
12560                 else {
12561                     ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
12562                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
12563                                             |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
12564                     ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
12565                                     |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
12566                     ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
12567                 }
12568             }
12569
12570             if (ok) {
12571                 if (!first_elem_op)
12572                     first_elem_op = o;
12573                 top_op = o;
12574                 if (is_deref) {
12575                     next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
12576                     o = o->op_next;
12577                 }
12578                 else {
12579                     is_last = TRUE;
12580                     action |= MDEREF_FLAG_last;
12581                 }
12582             }
12583             else {
12584                 /* at this point we have something that started
12585                  * promisingly enough (with rv2av or whatever), but failed
12586                  * to find a simple index followed by an
12587                  * aelem/helem/exists/delete. If this is the first action,
12588                  * give up; but if we've already seen at least one
12589                  * aelem/helem, then keep them and add a new action with
12590                  * MDEREF_INDEX_none, which causes it to do the vivify
12591                  * from the end of the previous lookup, and do the deref,
12592                  * but stop at that point. So $a[0][expr] will do one
12593                  * av_fetch, vivify and deref, then continue executing at
12594                  * expr */
12595                 if (!action_count)
12596                     return;
12597                 is_last = TRUE;
12598                 index_skip = action_count;
12599                 action |= MDEREF_FLAG_last;
12600             }
12601
12602             if (pass)
12603                 action_ptr->uv |= (action << (action_ix * MDEREF_SHIFT));
12604             action_ix++;
12605             action_count++;
12606             /* if there's no space for the next action, create a new slot
12607              * for it *before* we start adding args for that action */
12608             if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
12609                 action_ptr = arg;
12610                 if (pass)
12611                     arg->uv = 0;
12612                 arg++;
12613                 action_ix = 0;
12614             }
12615         } /* while !is_last */
12616
12617         /* success! */
12618
12619         if (pass) {
12620             OP *mderef;
12621             OP *p, *q;
12622
12623             mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
12624             if (index_skip == -1) {
12625                 mderef->op_flags = o->op_flags
12626                         & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
12627                 if (o->op_type == OP_EXISTS)
12628                     mderef->op_private = OPpMULTIDEREF_EXISTS;
12629                 else if (o->op_type == OP_DELETE)
12630                     mderef->op_private = OPpMULTIDEREF_DELETE;
12631                 else
12632                     mderef->op_private = o->op_private
12633                         & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
12634             }
12635             /* accumulate strictness from every level (although I don't think
12636              * they can actually vary) */
12637             mderef->op_private |= hints;
12638
12639             /* integrate the new multideref op into the optree and the
12640              * op_next chain.
12641              *
12642              * In general an op like aelem or helem has two child
12643              * sub-trees: the aggregate expression (a_expr) and the
12644              * index expression (i_expr):
12645              *
12646              *     aelem
12647              *       |
12648              *     a_expr - i_expr
12649              *
12650              * The a_expr returns an AV or HV, while the i-expr returns an
12651              * index. In general a multideref replaces most or all of a
12652              * multi-level tree, e.g.
12653              *
12654              *     exists
12655              *       |
12656              *     ex-aelem
12657              *       |
12658              *     rv2av  - i_expr1
12659              *       |
12660              *     helem
12661              *       |
12662              *     rv2hv  - i_expr2
12663              *       |
12664              *     aelem
12665              *       |
12666              *     a_expr - i_expr3
12667              *
12668              * With multideref, all the i_exprs will be simple vars or
12669              * constants, except that i_expr1 may be arbitrary in the case
12670              * of MDEREF_INDEX_none.
12671              *
12672              * The bottom-most a_expr will be either:
12673              *   1) a simple var (so padXv or gv+rv2Xv);
12674              *   2) a simple scalar var dereferenced (e.g. $r->[0]):
12675              *      so a simple var with an extra rv2Xv;
12676              *   3) or an arbitrary expression.
12677              *
12678              * 'start', the first op in the execution chain, will point to
12679              *   1),2): the padXv or gv op;
12680              *   3):    the rv2Xv which forms the last op in the a_expr
12681              *          execution chain, and the top-most op in the a_expr
12682              *          subtree.
12683              *
12684              * For all cases, the 'start' node is no longer required,
12685              * but we can't free it since one or more external nodes
12686              * may point to it. E.g. consider
12687              *     $h{foo} = $a ? $b : $c
12688              * Here, both the op_next and op_other branches of the
12689              * cond_expr point to the gv[*h] of the hash expression, so
12690              * we can't free the 'start' op.
12691              *
12692              * For expr->[...], we need to save the subtree containing the
12693              * expression; for the other cases, we just need to save the
12694              * start node.
12695              * So in all cases, we null the start op and keep it around by
12696              * making it the child of the multideref op; for the expr->
12697              * case, the expr will be a subtree of the start node.
12698              *
12699              * So in the simple 1,2 case the  optree above changes to
12700              *
12701              *     ex-exists
12702              *       |
12703              *     multideref
12704              *       |
12705              *     ex-gv (or ex-padxv)
12706              *
12707              *  with the op_next chain being
12708              *
12709              *  -> ex-gv -> multideref -> op-following-ex-exists ->
12710              *
12711              *  In the 3 case, we have
12712              *
12713              *     ex-exists
12714              *       |
12715              *     multideref
12716              *       |
12717              *     ex-rv2xv
12718              *       |
12719              *    rest-of-a_expr
12720              *      subtree
12721              *
12722              *  and
12723              *
12724              *  -> rest-of-a_expr subtree ->
12725              *    ex-rv2xv -> multideref -> op-following-ex-exists ->
12726              *
12727              *
12728              * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
12729              * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
12730              * multideref attached as the child, e.g.
12731              *
12732              *     exists
12733              *       |
12734              *     ex-aelem
12735              *       |
12736              *     ex-rv2av  - i_expr1
12737              *       |
12738              *     multideref
12739              *       |
12740              *     ex-whatever
12741              *
12742              */
12743
12744             /* if we free this op, don't free the pad entry */
12745             if (reset_start_targ)
12746                 start->op_targ = 0;
12747
12748
12749             /* Cut the bit we need to save out of the tree and attach to
12750              * the multideref op, then free the rest of the tree */
12751
12752             /* find parent of node to be detached (for use by splice) */
12753             p = first_elem_op;
12754             if (   orig_action == MDEREF_AV_pop_rv2av_aelem
12755                 || orig_action == MDEREF_HV_pop_rv2hv_helem)
12756             {
12757                 /* there is an arbitrary expression preceding us, e.g.
12758                  * expr->[..]? so we need to save the 'expr' subtree */
12759                 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
12760                     p = cUNOPx(p)->op_first;
12761                 ASSUME(   start->op_type == OP_RV2AV
12762                        || start->op_type == OP_RV2HV);
12763             }
12764             else {
12765                 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
12766                  * above for exists/delete. */
12767                 while (   (p->op_flags & OPf_KIDS)
12768                        && cUNOPx(p)->op_first != start
12769                 )
12770                     p = cUNOPx(p)->op_first;
12771             }
12772             ASSUME(cUNOPx(p)->op_first == start);
12773
12774             /* detach from main tree, and re-attach under the multideref */
12775             op_sibling_splice(mderef, NULL, 0,
12776                     op_sibling_splice(p, NULL, 1, NULL));
12777             op_null(start);
12778
12779             start->op_next = mderef;
12780
12781             mderef->op_next = index_skip == -1 ? o->op_next : o;
12782
12783             /* excise and free the original tree, and replace with
12784              * the multideref op */
12785             p = op_sibling_splice(top_op, NULL, -1, mderef);
12786             while (p) {
12787                 q = OpSIBLING(p);
12788                 op_free(p);
12789                 p = q;
12790             }
12791             op_null(top_op);
12792         }
12793         else {
12794             Size_t size = arg - arg_buf;
12795
12796             if (maybe_aelemfast && action_count == 1)
12797                 return;
12798
12799             arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
12800                                 sizeof(UNOP_AUX_item) * (size + 1));
12801             /* for dumping etc: store the length in a hidden first slot;
12802              * we set the op_aux pointer to the second slot */
12803             arg_buf->uv = size;
12804             arg_buf++;
12805         }
12806     } /* for (pass = ...) */
12807 }
12808
12809
12810
12811 /* mechanism for deferring recursion in rpeep() */
12812
12813 #define MAX_DEFERRED 4
12814
12815 #define DEFER(o) \
12816   STMT_START { \
12817     if (defer_ix == (MAX_DEFERRED-1)) { \
12818         OP **defer = defer_queue[defer_base]; \
12819         CALL_RPEEP(*defer); \
12820         S_prune_chain_head(defer); \
12821         defer_base = (defer_base + 1) % MAX_DEFERRED; \
12822         defer_ix--; \
12823     } \
12824     defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
12825   } STMT_END
12826
12827 #define IS_AND_OP(o)   (o->op_type == OP_AND)
12828 #define IS_OR_OP(o)    (o->op_type == OP_OR)
12829
12830
12831 /* A peephole optimizer.  We visit the ops in the order they're to execute.
12832  * See the comments at the top of this file for more details about when
12833  * peep() is called */
12834
12835 void
12836 Perl_rpeep(pTHX_ OP *o)
12837 {
12838     dVAR;
12839     OP* oldop = NULL;
12840     OP* oldoldop = NULL;
12841     OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
12842     int defer_base = 0;
12843     int defer_ix = -1;
12844     OP *fop;
12845     OP *sop;
12846
12847     if (!o || o->op_opt)
12848         return;
12849     ENTER;
12850     SAVEOP();
12851     SAVEVPTR(PL_curcop);
12852     for (;; o = o->op_next) {
12853         if (o && o->op_opt)
12854             o = NULL;
12855         if (!o) {
12856             while (defer_ix >= 0) {
12857                 OP **defer =
12858                         defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
12859                 CALL_RPEEP(*defer);
12860                 S_prune_chain_head(defer);
12861             }
12862             break;
12863         }
12864
12865       redo:
12866         /* By default, this op has now been optimised. A couple of cases below
12867            clear this again.  */
12868         o->op_opt = 1;
12869         PL_op = o;
12870
12871         /* look for a series of 1 or more aggregate derefs, e.g.
12872          *   $a[1]{foo}[$i]{$k}
12873          * and replace with a single OP_MULTIDEREF op.
12874          * Each index must be either a const, or a simple variable,
12875          *
12876          * First, look for likely combinations of starting ops,
12877          * corresponding to (global and lexical variants of)
12878          *     $a[...]   $h{...}
12879          *     $r->[...] $r->{...}
12880          *     (preceding expression)->[...]
12881          *     (preceding expression)->{...}
12882          * and if so, call maybe_multideref() to do a full inspection
12883          * of the op chain and if appropriate, replace with an
12884          * OP_MULTIDEREF
12885          */
12886         {
12887             UV action;
12888             OP *o2 = o;
12889             U8 hints = 0;
12890
12891             switch (o2->op_type) {
12892             case OP_GV:
12893                 /* $pkg[..]   :   gv[*pkg]
12894                  * $pkg->[...]:   gv[*pkg]; rv2sv sKM/DREFAV */
12895
12896                 /* Fail if there are new op flag combinations that we're
12897                  * not aware of, rather than:
12898                  *  * silently failing to optimise, or
12899                  *  * silently optimising the flag away.
12900                  * If this ASSUME starts failing, examine what new flag
12901                  * has been added to the op, and decide whether the
12902                  * optimisation should still occur with that flag, then
12903                  * update the code accordingly. This applies to all the
12904                  * other ASSUMEs in the block of code too.
12905                  */
12906                 ASSUME(!(o2->op_flags &
12907                             ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
12908                 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
12909
12910                 o2 = o2->op_next;
12911
12912                 if (o2->op_type == OP_RV2AV) {
12913                     action = MDEREF_AV_gvav_aelem;
12914                     goto do_deref;
12915                 }
12916
12917                 if (o2->op_type == OP_RV2HV) {
12918                     action = MDEREF_HV_gvhv_helem;
12919                     goto do_deref;
12920                 }
12921
12922                 if (o2->op_type != OP_RV2SV)
12923                     break;
12924
12925                 /* at this point we've seen gv,rv2sv, so the only valid
12926                  * construct left is $pkg->[] or $pkg->{} */
12927
12928                 ASSUME(!(o2->op_flags & OPf_STACKED));
12929                 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
12930                             != (OPf_WANT_SCALAR|OPf_MOD))
12931                     break;
12932
12933                 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
12934                                     |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
12935                 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
12936                     break;
12937                 if (   (o2->op_private & OPpDEREF) != OPpDEREF_AV
12938                     && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
12939                     break;
12940
12941                 o2 = o2->op_next;
12942                 if (o2->op_type == OP_RV2AV) {
12943                     action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
12944                     goto do_deref;
12945                 }
12946                 if (o2->op_type == OP_RV2HV) {
12947                     action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
12948                     goto do_deref;
12949                 }
12950                 break;
12951
12952             case OP_PADSV:
12953                 /* $lex->[...]: padsv[$lex] sM/DREFAV */
12954
12955                 ASSUME(!(o2->op_flags &
12956                     ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
12957                 if ((o2->op_flags &
12958                         (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
12959                      != (OPf_WANT_SCALAR|OPf_MOD))
12960                     break;
12961
12962                 ASSUME(!(o2->op_private &
12963                                 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
12964                 /* skip if state or intro, or not a deref */
12965                 if (      o2->op_private != OPpDEREF_AV
12966                        && o2->op_private != OPpDEREF_HV)
12967                     break;
12968
12969                 o2 = o2->op_next;
12970                 if (o2->op_type == OP_RV2AV) {
12971                     action = MDEREF_AV_padsv_vivify_rv2av_aelem;
12972                     goto do_deref;
12973                 }
12974                 if (o2->op_type == OP_RV2HV) {
12975                     action = MDEREF_HV_padsv_vivify_rv2hv_helem;
12976                     goto do_deref;
12977                 }
12978                 break;
12979
12980             case OP_PADAV:
12981             case OP_PADHV:
12982                 /*    $lex[..]:  padav[@lex:1,2] sR *
12983                  * or $lex{..}:  padhv[%lex:1,2] sR */
12984                 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
12985                                             OPf_REF|OPf_SPECIAL)));
12986                 if ((o2->op_flags &
12987                         (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
12988                      != (OPf_WANT_SCALAR|OPf_REF))
12989                     break;
12990                 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
12991                     break;
12992                 /* OPf_PARENS isn't currently used in this case;
12993                  * if that changes, let us know! */
12994                 ASSUME(!(o2->op_flags & OPf_PARENS));
12995
12996                 /* at this point, we wouldn't expect any of the remaining
12997                  * possible private flags:
12998                  * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
12999                  * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
13000                  *
13001                  * OPpSLICEWARNING shouldn't affect runtime
13002                  */
13003                 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
13004
13005                 action = o2->op_type == OP_PADAV
13006                             ? MDEREF_AV_padav_aelem
13007                             : MDEREF_HV_padhv_helem;
13008                 o2 = o2->op_next;
13009                 S_maybe_multideref(aTHX_ o, o2, action, 0);
13010                 break;
13011
13012
13013             case OP_RV2AV:
13014             case OP_RV2HV:
13015                 action = o2->op_type == OP_RV2AV
13016                             ? MDEREF_AV_pop_rv2av_aelem
13017                             : MDEREF_HV_pop_rv2hv_helem;
13018                 /* FALLTHROUGH */
13019             do_deref:
13020                 /* (expr)->[...]:  rv2av sKR/1;
13021                  * (expr)->{...}:  rv2hv sKR/1; */
13022
13023                 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
13024
13025                 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
13026                                 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
13027                 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
13028                     break;
13029
13030                 /* at this point, we wouldn't expect any of these
13031                  * possible private flags:
13032                  * OPpMAYBE_LVSUB, OPpLVAL_INTRO
13033                  * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
13034                  */
13035                 ASSUME(!(o2->op_private &
13036                     ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
13037                      |OPpOUR_INTRO)));
13038                 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
13039
13040                 o2 = o2->op_next;
13041
13042                 S_maybe_multideref(aTHX_ o, o2, action, hints);
13043                 break;
13044
13045             default:
13046                 break;
13047             }
13048         }
13049
13050
13051         switch (o->op_type) {
13052         case OP_DBSTATE:
13053             PL_curcop = ((COP*)o);              /* for warnings */
13054             break;
13055         case OP_NEXTSTATE:
13056             PL_curcop = ((COP*)o);              /* for warnings */
13057
13058             /* Optimise a "return ..." at the end of a sub to just be "...".
13059              * This saves 2 ops. Before:
13060              * 1  <;> nextstate(main 1 -e:1) v ->2
13061              * 4  <@> return K ->5
13062              * 2    <0> pushmark s ->3
13063              * -    <1> ex-rv2sv sK/1 ->4
13064              * 3      <#> gvsv[*cat] s ->4
13065              *
13066              * After:
13067              * -  <@> return K ->-
13068              * -    <0> pushmark s ->2
13069              * -    <1> ex-rv2sv sK/1 ->-
13070              * 2      <$> gvsv(*cat) s ->3
13071              */
13072             {
13073                 OP *next = o->op_next;
13074                 OP *sibling = OpSIBLING(o);
13075                 if (   OP_TYPE_IS(next, OP_PUSHMARK)
13076                     && OP_TYPE_IS(sibling, OP_RETURN)
13077                     && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
13078                     && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
13079                        ||OP_TYPE_IS(sibling->op_next->op_next,
13080                                     OP_LEAVESUBLV))
13081                     && cUNOPx(sibling)->op_first == next
13082                     && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
13083                     && next->op_next
13084                 ) {
13085                     /* Look through the PUSHMARK's siblings for one that
13086                      * points to the RETURN */
13087                     OP *top = OpSIBLING(next);
13088                     while (top && top->op_next) {
13089                         if (top->op_next == sibling) {
13090                             top->op_next = sibling->op_next;
13091                             o->op_next = next->op_next;
13092                             break;
13093                         }
13094                         top = OpSIBLING(top);
13095                     }
13096                 }
13097             }
13098
13099             /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
13100              *
13101              * This latter form is then suitable for conversion into padrange
13102              * later on. Convert:
13103              *
13104              *   nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
13105              *
13106              * into:
13107              *
13108              *   nextstate1 ->     listop     -> nextstate3
13109              *                 /            \
13110              *         pushmark -> padop1 -> padop2
13111              */
13112             if (o->op_next && (
13113                     o->op_next->op_type == OP_PADSV
13114                  || o->op_next->op_type == OP_PADAV
13115                  || o->op_next->op_type == OP_PADHV
13116                 )
13117                 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
13118                 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
13119                 && o->op_next->op_next->op_next && (
13120                     o->op_next->op_next->op_next->op_type == OP_PADSV
13121                  || o->op_next->op_next->op_next->op_type == OP_PADAV
13122                  || o->op_next->op_next->op_next->op_type == OP_PADHV
13123                 )
13124                 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
13125                 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
13126                 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
13127                 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
13128             ) {
13129                 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
13130
13131                 pad1 =    o->op_next;
13132                 ns2  = pad1->op_next;
13133                 pad2 =  ns2->op_next;
13134                 ns3  = pad2->op_next;
13135
13136                 /* we assume here that the op_next chain is the same as
13137                  * the op_sibling chain */
13138                 assert(OpSIBLING(o)    == pad1);
13139                 assert(OpSIBLING(pad1) == ns2);
13140                 assert(OpSIBLING(ns2)  == pad2);
13141                 assert(OpSIBLING(pad2) == ns3);
13142
13143                 /* excise and delete ns2 */
13144                 op_sibling_splice(NULL, pad1, 1, NULL);
13145                 op_free(ns2);
13146
13147                 /* excise pad1 and pad2 */
13148                 op_sibling_splice(NULL, o, 2, NULL);
13149
13150                 /* create new listop, with children consisting of:
13151                  * a new pushmark, pad1, pad2. */
13152                 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
13153                 newop->op_flags |= OPf_PARENS;
13154                 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
13155
13156                 /* insert newop between o and ns3 */
13157                 op_sibling_splice(NULL, o, 0, newop);
13158
13159                 /*fixup op_next chain */
13160                 newpm = cUNOPx(newop)->op_first; /* pushmark */
13161                 o    ->op_next = newpm;
13162                 newpm->op_next = pad1;
13163                 pad1 ->op_next = pad2;
13164                 pad2 ->op_next = newop; /* listop */
13165                 newop->op_next = ns3;
13166
13167                 /* Ensure pushmark has this flag if padops do */
13168                 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
13169                     newpm->op_flags |= OPf_MOD;
13170                 }
13171
13172                 break;
13173             }
13174
13175             /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
13176                to carry two labels. For now, take the easier option, and skip
13177                this optimisation if the first NEXTSTATE has a label.  */
13178             if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
13179                 OP *nextop = o->op_next;
13180                 while (nextop && nextop->op_type == OP_NULL)
13181                     nextop = nextop->op_next;
13182
13183                 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
13184                     op_null(o);
13185                     if (oldop)
13186                         oldop->op_next = nextop;
13187                     /* Skip (old)oldop assignment since the current oldop's
13188                        op_next already points to the next op.  */
13189                     continue;
13190                 }
13191             }
13192             break;
13193
13194         case OP_CONCAT:
13195             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
13196                 if (o->op_next->op_private & OPpTARGET_MY) {
13197                     if (o->op_flags & OPf_STACKED) /* chained concats */
13198                         break; /* ignore_optimization */
13199                     else {
13200                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
13201                         o->op_targ = o->op_next->op_targ;
13202                         o->op_next->op_targ = 0;
13203                         o->op_private |= OPpTARGET_MY;
13204                     }
13205                 }
13206                 op_null(o->op_next);
13207             }
13208             break;
13209         case OP_STUB:
13210             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
13211                 break; /* Scalar stub must produce undef.  List stub is noop */
13212             }
13213             goto nothin;
13214         case OP_NULL:
13215             if (o->op_targ == OP_NEXTSTATE
13216                 || o->op_targ == OP_DBSTATE)
13217             {
13218                 PL_curcop = ((COP*)o);
13219             }
13220             /* XXX: We avoid setting op_seq here to prevent later calls
13221                to rpeep() from mistakenly concluding that optimisation
13222                has already occurred. This doesn't fix the real problem,
13223                though (See 20010220.007). AMS 20010719 */
13224             /* op_seq functionality is now replaced by op_opt */
13225             o->op_opt = 0;
13226             /* FALLTHROUGH */
13227         case OP_SCALAR:
13228         case OP_LINESEQ:
13229         case OP_SCOPE:
13230         nothin:
13231             if (oldop) {
13232                 oldop->op_next = o->op_next;
13233                 o->op_opt = 0;
13234                 continue;
13235             }
13236             break;
13237
13238         case OP_PUSHMARK:
13239
13240             /* Given
13241                  5 repeat/DOLIST
13242                  3   ex-list
13243                  1     pushmark
13244                  2     scalar or const
13245                  4   const[0]
13246                convert repeat into a stub with no kids.
13247              */
13248             if (o->op_next->op_type == OP_CONST
13249              || (  o->op_next->op_type == OP_PADSV
13250                 && !(o->op_next->op_private & OPpLVAL_INTRO))
13251              || (  o->op_next->op_type == OP_GV
13252                 && o->op_next->op_next->op_type == OP_RV2SV
13253                 && !(o->op_next->op_next->op_private
13254                         & (OPpLVAL_INTRO|OPpOUR_INTRO))))
13255             {
13256                 const OP *kid = o->op_next->op_next;
13257                 if (o->op_next->op_type == OP_GV)
13258                    kid = kid->op_next;
13259                 /* kid is now the ex-list.  */
13260                 if (kid->op_type == OP_NULL
13261                  && (kid = kid->op_next)->op_type == OP_CONST
13262                     /* kid is now the repeat count.  */
13263                  && kid->op_next->op_type == OP_REPEAT
13264                  && kid->op_next->op_private & OPpREPEAT_DOLIST
13265                  && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
13266                  && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0)
13267                 {
13268                     o = kid->op_next; /* repeat */
13269                     assert(oldop);
13270                     oldop->op_next = o;
13271                     op_free(cBINOPo->op_first);
13272                     op_free(cBINOPo->op_last );
13273                     o->op_flags &=~ OPf_KIDS;
13274                     /* stub is a baseop; repeat is a binop */
13275                     STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
13276                     OpTYPE_set(o, OP_STUB);
13277                     o->op_private = 0;
13278                     break;
13279                 }
13280             }
13281
13282             /* Convert a series of PAD ops for my vars plus support into a
13283              * single padrange op. Basically
13284              *
13285              *    pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
13286              *
13287              * becomes, depending on circumstances, one of
13288              *
13289              *    padrange  ----------------------------------> (list) -> rest
13290              *    padrange  --------------------------------------------> rest
13291              *
13292              * where all the pad indexes are sequential and of the same type
13293              * (INTRO or not).
13294              * We convert the pushmark into a padrange op, then skip
13295              * any other pad ops, and possibly some trailing ops.
13296              * Note that we don't null() the skipped ops, to make it
13297              * easier for Deparse to undo this optimisation (and none of
13298              * the skipped ops are holding any resourses). It also makes
13299              * it easier for find_uninit_var(), as it can just ignore
13300              * padrange, and examine the original pad ops.
13301              */
13302         {
13303             OP *p;
13304             OP *followop = NULL; /* the op that will follow the padrange op */
13305             U8 count = 0;
13306             U8 intro = 0;
13307             PADOFFSET base = 0; /* init only to stop compiler whining */
13308             bool gvoid = 0;     /* init only to stop compiler whining */
13309             bool defav = 0;  /* seen (...) = @_ */
13310             bool reuse = 0;  /* reuse an existing padrange op */
13311
13312             /* look for a pushmark -> gv[_] -> rv2av */
13313
13314             {
13315                 OP *rv2av, *q;
13316                 p = o->op_next;
13317                 if (   p->op_type == OP_GV
13318                     && cGVOPx_gv(p) == PL_defgv
13319                     && (rv2av = p->op_next)
13320                     && rv2av->op_type == OP_RV2AV
13321                     && !(rv2av->op_flags & OPf_REF)
13322                     && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
13323                     && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
13324                 ) {
13325                     q = rv2av->op_next;
13326                     if (q->op_type == OP_NULL)
13327                         q = q->op_next;
13328                     if (q->op_type == OP_PUSHMARK) {
13329                         defav = 1;
13330                         p = q;
13331                     }
13332                 }
13333             }
13334             if (!defav) {
13335                 p = o;
13336             }
13337
13338             /* scan for PAD ops */
13339
13340             for (p = p->op_next; p; p = p->op_next) {
13341                 if (p->op_type == OP_NULL)
13342                     continue;
13343
13344                 if ((     p->op_type != OP_PADSV
13345                        && p->op_type != OP_PADAV
13346                        && p->op_type != OP_PADHV
13347                     )
13348                       /* any private flag other than INTRO? e.g. STATE */
13349                    || (p->op_private & ~OPpLVAL_INTRO)
13350                 )
13351                     break;
13352
13353                 /* let $a[N] potentially be optimised into AELEMFAST_LEX
13354                  * instead */
13355                 if (   p->op_type == OP_PADAV
13356                     && p->op_next
13357                     && p->op_next->op_type == OP_CONST
13358                     && p->op_next->op_next
13359                     && p->op_next->op_next->op_type == OP_AELEM
13360                 )
13361                     break;
13362
13363                 /* for 1st padop, note what type it is and the range
13364                  * start; for the others, check that it's the same type
13365                  * and that the targs are contiguous */
13366                 if (count == 0) {
13367                     intro = (p->op_private & OPpLVAL_INTRO);
13368                     base = p->op_targ;
13369                     gvoid = OP_GIMME(p,0) == G_VOID;
13370                 }
13371                 else {
13372                     if ((p->op_private & OPpLVAL_INTRO) != intro)
13373                         break;
13374                     /* Note that you'd normally  expect targs to be
13375                      * contiguous in my($a,$b,$c), but that's not the case
13376                      * when external modules start doing things, e.g.
13377                      i* Function::Parameters */
13378                     if (p->op_targ != base + count)
13379                         break;
13380                     assert(p->op_targ == base + count);
13381                     /* Either all the padops or none of the padops should
13382                        be in void context.  Since we only do the optimisa-
13383                        tion for av/hv when the aggregate itself is pushed
13384                        on to the stack (one item), there is no need to dis-
13385                        tinguish list from scalar context.  */
13386                     if (gvoid != (OP_GIMME(p,0) == G_VOID))
13387                         break;
13388                 }
13389
13390                 /* for AV, HV, only when we're not flattening */
13391                 if (   p->op_type != OP_PADSV
13392                     && !gvoid
13393                     && !(p->op_flags & OPf_REF)
13394                 )
13395                     break;
13396
13397                 if (count >= OPpPADRANGE_COUNTMASK)
13398                     break;
13399
13400                 /* there's a biggest base we can fit into a
13401                  * SAVEt_CLEARPADRANGE in pp_padrange */
13402                 if (intro && base >
13403                         (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)))
13404                     break;
13405
13406                 /* Success! We've got another valid pad op to optimise away */
13407                 count++;
13408                 followop = p->op_next;
13409             }
13410
13411             if (count < 1 || (count == 1 && !defav))
13412                 break;
13413
13414             /* pp_padrange in specifically compile-time void context
13415              * skips pushing a mark and lexicals; in all other contexts
13416              * (including unknown till runtime) it pushes a mark and the
13417              * lexicals. We must be very careful then, that the ops we
13418              * optimise away would have exactly the same effect as the
13419              * padrange.
13420              * In particular in void context, we can only optimise to
13421              * a padrange if see see the complete sequence
13422              *     pushmark, pad*v, ...., list
13423              * which has the net effect of of leaving the markstack as it
13424              * was.  Not pushing on to the stack (whereas padsv does touch
13425              * the stack) makes no difference in void context.
13426              */
13427             assert(followop);
13428             if (gvoid) {
13429                 if (followop->op_type == OP_LIST
13430                         && OP_GIMME(followop,0) == G_VOID
13431                    )
13432                 {
13433                     followop = followop->op_next; /* skip OP_LIST */
13434
13435                     /* consolidate two successive my(...);'s */
13436
13437                     if (   oldoldop
13438                         && oldoldop->op_type == OP_PADRANGE
13439                         && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
13440                         && (oldoldop->op_private & OPpLVAL_INTRO) == intro
13441                         && !(oldoldop->op_flags & OPf_SPECIAL)
13442                     ) {
13443                         U8 old_count;
13444                         assert(oldoldop->op_next == oldop);
13445                         assert(   oldop->op_type == OP_NEXTSTATE
13446                                || oldop->op_type == OP_DBSTATE);
13447                         assert(oldop->op_next == o);
13448
13449                         old_count
13450                             = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
13451
13452                        /* Do not assume pad offsets for $c and $d are con-
13453                           tiguous in
13454                             my ($a,$b,$c);
13455                             my ($d,$e,$f);
13456                         */
13457                         if (  oldoldop->op_targ + old_count == base
13458                            && old_count < OPpPADRANGE_COUNTMASK - count) {
13459                             base = oldoldop->op_targ;
13460                             count += old_count;
13461                             reuse = 1;
13462                         }
13463                     }
13464
13465                     /* if there's any immediately following singleton
13466                      * my var's; then swallow them and the associated
13467                      * nextstates; i.e.
13468                      *    my ($a,$b); my $c; my $d;
13469                      * is treated as
13470                      *    my ($a,$b,$c,$d);
13471                      */
13472
13473                     while (    ((p = followop->op_next))
13474                             && (  p->op_type == OP_PADSV
13475                                || p->op_type == OP_PADAV
13476                                || p->op_type == OP_PADHV)
13477                             && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
13478                             && (p->op_private & OPpLVAL_INTRO) == intro
13479                             && !(p->op_private & ~OPpLVAL_INTRO)
13480                             && p->op_next
13481                             && (   p->op_next->op_type == OP_NEXTSTATE
13482                                 || p->op_next->op_type == OP_DBSTATE)
13483                             && count < OPpPADRANGE_COUNTMASK
13484                             && base + count == p->op_targ
13485                     ) {
13486                         count++;
13487                         followop = p->op_next;
13488                     }
13489                 }
13490                 else
13491                     break;
13492             }
13493
13494             if (reuse) {
13495                 assert(oldoldop->op_type == OP_PADRANGE);
13496                 oldoldop->op_next = followop;
13497                 oldoldop->op_private = (intro | count);
13498                 o = oldoldop;
13499                 oldop = NULL;
13500                 oldoldop = NULL;
13501             }
13502             else {
13503                 /* Convert the pushmark into a padrange.
13504                  * To make Deparse easier, we guarantee that a padrange was
13505                  * *always* formerly a pushmark */
13506                 assert(o->op_type == OP_PUSHMARK);
13507                 o->op_next = followop;
13508                 OpTYPE_set(o, OP_PADRANGE);
13509                 o->op_targ = base;
13510                 /* bit 7: INTRO; bit 6..0: count */
13511                 o->op_private = (intro | count);
13512                 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
13513                               | gvoid * OPf_WANT_VOID
13514                               | (defav ? OPf_SPECIAL : 0));
13515             }
13516             break;
13517         }
13518
13519         case OP_PADAV:
13520         case OP_PADSV:
13521         case OP_PADHV:
13522         /* Skip over state($x) in void context.  */
13523         if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
13524          && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
13525         {
13526             oldop->op_next = o->op_next;
13527             goto redo_nextstate;
13528         }
13529         if (o->op_type != OP_PADAV)
13530             break;
13531         /* FALLTHROUGH */
13532         case OP_GV:
13533             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
13534                 OP* const pop = (o->op_type == OP_PADAV) ?
13535                             o->op_next : o->op_next->op_next;
13536                 IV i;
13537                 if (pop && pop->op_type == OP_CONST &&
13538                     ((PL_op = pop->op_next)) &&
13539                     pop->op_next->op_type == OP_AELEM &&
13540                     !(pop->op_next->op_private &
13541                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
13542                     (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
13543                 {
13544                     GV *gv;
13545                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
13546                         no_bareword_allowed(pop);
13547                     if (o->op_type == OP_GV)
13548                         op_null(o->op_next);
13549                     op_null(pop->op_next);
13550                     op_null(pop);
13551                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
13552                     o->op_next = pop->op_next->op_next;
13553                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
13554                     o->op_private = (U8)i;
13555                     if (o->op_type == OP_GV) {
13556                         gv = cGVOPo_gv;
13557                         GvAVn(gv);
13558                         o->op_type = OP_AELEMFAST;
13559                     }
13560                     else
13561                         o->op_type = OP_AELEMFAST_LEX;
13562                 }
13563                 if (o->op_type != OP_GV)
13564                     break;
13565             }
13566
13567             /* Remove $foo from the op_next chain in void context.  */
13568             if (oldop
13569              && (  o->op_next->op_type == OP_RV2SV
13570                 || o->op_next->op_type == OP_RV2AV
13571                 || o->op_next->op_type == OP_RV2HV  )
13572              && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
13573              && !(o->op_next->op_private & OPpLVAL_INTRO))
13574             {
13575                 oldop->op_next = o->op_next->op_next;
13576                 /* Reprocess the previous op if it is a nextstate, to
13577                    allow double-nextstate optimisation.  */
13578               redo_nextstate:
13579                 if (oldop->op_type == OP_NEXTSTATE) {
13580                     oldop->op_opt = 0;
13581                     o = oldop;
13582                     oldop = oldoldop;
13583                     oldoldop = NULL;
13584                     goto redo;
13585                 }
13586                 o = oldop;
13587             }
13588             else if (o->op_next->op_type == OP_RV2SV) {
13589                 if (!(o->op_next->op_private & OPpDEREF)) {
13590                     op_null(o->op_next);
13591                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
13592                                                                | OPpOUR_INTRO);
13593                     o->op_next = o->op_next->op_next;
13594                     OpTYPE_set(o, OP_GVSV);
13595                 }
13596             }
13597             else if (o->op_next->op_type == OP_READLINE
13598                     && o->op_next->op_next->op_type == OP_CONCAT
13599                     && (o->op_next->op_next->op_flags & OPf_STACKED))
13600             {
13601                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
13602                 OpTYPE_set(o, OP_RCATLINE);
13603                 o->op_flags |= OPf_STACKED;
13604                 op_null(o->op_next->op_next);
13605                 op_null(o->op_next);
13606             }
13607
13608             break;
13609
13610 #define HV_OR_SCALARHV(op)                                   \
13611     (  (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \
13612        ? (op)                                                  \
13613        : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \
13614        && (  cUNOPx(op)->op_first->op_type == OP_PADHV          \
13615           || cUNOPx(op)->op_first->op_type == OP_RV2HV)          \
13616          ? cUNOPx(op)->op_first                                   \
13617          : NULL)
13618
13619         case OP_NOT:
13620             if ((fop = HV_OR_SCALARHV(cUNOP->op_first)))
13621                 fop->op_private |= OPpTRUEBOOL;
13622             break;
13623
13624         case OP_AND:
13625         case OP_OR:
13626         case OP_DOR:
13627             fop = cLOGOP->op_first;
13628             sop = OpSIBLING(fop);
13629             while (cLOGOP->op_other->op_type == OP_NULL)
13630                 cLOGOP->op_other = cLOGOP->op_other->op_next;
13631             while (o->op_next && (   o->op_type == o->op_next->op_type
13632                                   || o->op_next->op_type == OP_NULL))
13633                 o->op_next = o->op_next->op_next;
13634
13635             /* if we're an OR and our next is a AND in void context, we'll
13636                follow it's op_other on short circuit, same for reverse.
13637                We can't do this with OP_DOR since if it's true, its return
13638                value is the underlying value which must be evaluated
13639                by the next op */
13640             if (o->op_next &&
13641                 (
13642                     (IS_AND_OP(o) && IS_OR_OP(o->op_next))
13643                  || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
13644                 )
13645                 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
13646             ) {
13647                 o->op_next = ((LOGOP*)o->op_next)->op_other;
13648             }
13649             DEFER(cLOGOP->op_other);
13650
13651             o->op_opt = 1;
13652             fop = HV_OR_SCALARHV(fop);
13653             if (sop) sop = HV_OR_SCALARHV(sop);
13654             if (fop || sop
13655             ){
13656                 OP * nop = o;
13657                 OP * lop = o;
13658                 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
13659                     while (nop && nop->op_next) {
13660                         switch (nop->op_next->op_type) {
13661                             case OP_NOT:
13662                             case OP_AND:
13663                             case OP_OR:
13664                             case OP_DOR:
13665                                 lop = nop = nop->op_next;
13666                                 break;
13667                             case OP_NULL:
13668                                 nop = nop->op_next;
13669                                 break;
13670                             default:
13671                                 nop = NULL;
13672                                 break;
13673                         }
13674                     }
13675                 }
13676                 if (fop) {
13677                     if (  (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
13678                       || o->op_type == OP_AND  )
13679                         fop->op_private |= OPpTRUEBOOL;
13680                     else if (!(lop->op_flags & OPf_WANT))
13681                         fop->op_private |= OPpMAYBE_TRUEBOOL;
13682                 }
13683                 if (  (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
13684                    && sop)
13685                     sop->op_private |= OPpTRUEBOOL;
13686             }
13687
13688
13689             break;
13690
13691         case OP_COND_EXPR:
13692             if ((fop = HV_OR_SCALARHV(cLOGOP->op_first)))
13693                 fop->op_private |= OPpTRUEBOOL;
13694 #undef HV_OR_SCALARHV
13695             /* GERONIMO! */ /* FALLTHROUGH */
13696
13697         case OP_MAPWHILE:
13698         case OP_GREPWHILE:
13699         case OP_ANDASSIGN:
13700         case OP_ORASSIGN:
13701         case OP_DORASSIGN:
13702         case OP_RANGE:
13703         case OP_ONCE:
13704             while (cLOGOP->op_other->op_type == OP_NULL)
13705                 cLOGOP->op_other = cLOGOP->op_other->op_next;
13706             DEFER(cLOGOP->op_other);
13707             break;
13708
13709         case OP_ENTERLOOP:
13710         case OP_ENTERITER:
13711             while (cLOOP->op_redoop->op_type == OP_NULL)
13712                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
13713             while (cLOOP->op_nextop->op_type == OP_NULL)
13714                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
13715             while (cLOOP->op_lastop->op_type == OP_NULL)
13716                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
13717             /* a while(1) loop doesn't have an op_next that escapes the
13718              * loop, so we have to explicitly follow the op_lastop to
13719              * process the rest of the code */
13720             DEFER(cLOOP->op_lastop);
13721             break;
13722
13723         case OP_ENTERTRY:
13724             assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
13725             DEFER(cLOGOPo->op_other);
13726             break;
13727
13728         case OP_SUBST:
13729             assert(!(cPMOP->op_pmflags & PMf_ONCE));
13730             while (cPMOP->op_pmstashstartu.op_pmreplstart &&
13731                    cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
13732                 cPMOP->op_pmstashstartu.op_pmreplstart
13733                     = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
13734             DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
13735             break;
13736
13737         case OP_SORT: {
13738             OP *oright;
13739
13740             if (o->op_flags & OPf_SPECIAL) {
13741                 /* first arg is a code block */
13742                 OP * const nullop = OpSIBLING(cLISTOP->op_first);
13743                 OP * kid          = cUNOPx(nullop)->op_first;
13744
13745                 assert(nullop->op_type == OP_NULL);
13746                 assert(kid->op_type == OP_SCOPE
13747                  || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
13748                 /* since OP_SORT doesn't have a handy op_other-style
13749                  * field that can point directly to the start of the code
13750                  * block, store it in the otherwise-unused op_next field
13751                  * of the top-level OP_NULL. This will be quicker at
13752                  * run-time, and it will also allow us to remove leading
13753                  * OP_NULLs by just messing with op_nexts without
13754                  * altering the basic op_first/op_sibling layout. */
13755                 kid = kLISTOP->op_first;
13756                 assert(
13757                       (kid->op_type == OP_NULL
13758                       && (  kid->op_targ == OP_NEXTSTATE
13759                          || kid->op_targ == OP_DBSTATE  ))
13760                     || kid->op_type == OP_STUB
13761                     || kid->op_type == OP_ENTER);
13762                 nullop->op_next = kLISTOP->op_next;
13763                 DEFER(nullop->op_next);
13764             }
13765
13766             /* check that RHS of sort is a single plain array */
13767             oright = cUNOPo->op_first;
13768             if (!oright || oright->op_type != OP_PUSHMARK)
13769                 break;
13770
13771             if (o->op_private & OPpSORT_INPLACE)
13772                 break;
13773
13774             /* reverse sort ... can be optimised.  */
13775             if (!OpHAS_SIBLING(cUNOPo)) {
13776                 /* Nothing follows us on the list. */
13777                 OP * const reverse = o->op_next;
13778
13779                 if (reverse->op_type == OP_REVERSE &&
13780                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
13781                     OP * const pushmark = cUNOPx(reverse)->op_first;
13782                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
13783                         && (OpSIBLING(cUNOPx(pushmark)) == o)) {
13784                         /* reverse -> pushmark -> sort */
13785                         o->op_private |= OPpSORT_REVERSE;
13786                         op_null(reverse);
13787                         pushmark->op_next = oright->op_next;
13788                         op_null(oright);
13789                     }
13790                 }
13791             }
13792
13793             break;
13794         }
13795
13796         case OP_REVERSE: {
13797             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
13798             OP *gvop = NULL;
13799             LISTOP *enter, *exlist;
13800
13801             if (o->op_private & OPpSORT_INPLACE)
13802                 break;
13803
13804             enter = (LISTOP *) o->op_next;
13805             if (!enter)
13806                 break;
13807             if (enter->op_type == OP_NULL) {
13808                 enter = (LISTOP *) enter->op_next;
13809                 if (!enter)
13810                     break;
13811             }
13812             /* for $a (...) will have OP_GV then OP_RV2GV here.
13813                for (...) just has an OP_GV.  */
13814             if (enter->op_type == OP_GV) {
13815                 gvop = (OP *) enter;
13816                 enter = (LISTOP *) enter->op_next;
13817                 if (!enter)
13818                     break;
13819                 if (enter->op_type == OP_RV2GV) {
13820                   enter = (LISTOP *) enter->op_next;
13821                   if (!enter)
13822                     break;
13823                 }
13824             }
13825
13826             if (enter->op_type != OP_ENTERITER)
13827                 break;
13828
13829             iter = enter->op_next;
13830             if (!iter || iter->op_type != OP_ITER)
13831                 break;
13832
13833             expushmark = enter->op_first;
13834             if (!expushmark || expushmark->op_type != OP_NULL
13835                 || expushmark->op_targ != OP_PUSHMARK)
13836                 break;
13837
13838             exlist = (LISTOP *) OpSIBLING(expushmark);
13839             if (!exlist || exlist->op_type != OP_NULL
13840                 || exlist->op_targ != OP_LIST)
13841                 break;
13842
13843             if (exlist->op_last != o) {
13844                 /* Mmm. Was expecting to point back to this op.  */
13845                 break;
13846             }
13847             theirmark = exlist->op_first;
13848             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
13849                 break;
13850
13851             if (OpSIBLING(theirmark) != o) {
13852                 /* There's something between the mark and the reverse, eg
13853                    for (1, reverse (...))
13854                    so no go.  */
13855                 break;
13856             }
13857
13858             ourmark = ((LISTOP *)o)->op_first;
13859             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
13860                 break;
13861
13862             ourlast = ((LISTOP *)o)->op_last;
13863             if (!ourlast || ourlast->op_next != o)
13864                 break;
13865
13866             rv2av = OpSIBLING(ourmark);
13867             if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
13868                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
13869                 /* We're just reversing a single array.  */
13870                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
13871                 enter->op_flags |= OPf_STACKED;
13872             }
13873
13874             /* We don't have control over who points to theirmark, so sacrifice
13875                ours.  */
13876             theirmark->op_next = ourmark->op_next;
13877             theirmark->op_flags = ourmark->op_flags;
13878             ourlast->op_next = gvop ? gvop : (OP *) enter;
13879             op_null(ourmark);
13880             op_null(o);
13881             enter->op_private |= OPpITER_REVERSED;
13882             iter->op_private |= OPpITER_REVERSED;
13883
13884             break;
13885         }
13886
13887         case OP_QR:
13888         case OP_MATCH:
13889             if (!(cPMOP->op_pmflags & PMf_ONCE)) {
13890                 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
13891             }
13892             break;
13893
13894         case OP_RUNCV:
13895             if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
13896              && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
13897             {
13898                 SV *sv;
13899                 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
13900                 else {
13901                     sv = newRV((SV *)PL_compcv);
13902                     sv_rvweaken(sv);
13903                     SvREADONLY_on(sv);
13904                 }
13905                 OpTYPE_set(o, OP_CONST);
13906                 o->op_flags |= OPf_SPECIAL;
13907                 cSVOPo->op_sv = sv;
13908             }
13909             break;
13910
13911         case OP_SASSIGN:
13912             if (OP_GIMME(o,0) == G_VOID
13913              || (  o->op_next->op_type == OP_LINESEQ
13914                 && (  o->op_next->op_next->op_type == OP_LEAVESUB
13915                    || (  o->op_next->op_next->op_type == OP_RETURN
13916                       && !CvLVALUE(PL_compcv)))))
13917             {
13918                 OP *right = cBINOP->op_first;
13919                 if (right) {
13920                     /*   sassign
13921                     *      RIGHT
13922                     *      substr
13923                     *         pushmark
13924                     *         arg1
13925                     *         arg2
13926                     *         ...
13927                     * becomes
13928                     *
13929                     *  ex-sassign
13930                     *     substr
13931                     *        pushmark
13932                     *        RIGHT
13933                     *        arg1
13934                     *        arg2
13935                     *        ...
13936                     */
13937                     OP *left = OpSIBLING(right);
13938                     if (left->op_type == OP_SUBSTR
13939                          && (left->op_private & 7) < 4) {
13940                         op_null(o);
13941                         /* cut out right */
13942                         op_sibling_splice(o, NULL, 1, NULL);
13943                         /* and insert it as second child of OP_SUBSTR */
13944                         op_sibling_splice(left, cBINOPx(left)->op_first, 0,
13945                                     right);
13946                         left->op_private |= OPpSUBSTR_REPL_FIRST;
13947                         left->op_flags =
13948                             (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
13949                     }
13950                 }
13951             }
13952             break;
13953
13954         case OP_AASSIGN:
13955             /* We do the common-vars check here, rather than in newASSIGNOP
13956                (as formerly), so that all lexical vars that get aliased are
13957                marked as such before we do the check.  */
13958             /* There can’t be common vars if the lhs is a stub.  */
13959             if (OpSIBLING(cLISTOPx(cBINOPo->op_last)->op_first)
13960                     == cLISTOPx(cBINOPo->op_last)->op_last
13961              && cLISTOPx(cBINOPo->op_last)->op_last->op_type == OP_STUB)
13962             {
13963                 o->op_private &=~ OPpASSIGN_COMMON;
13964                 break;
13965             }
13966             if (o->op_private & OPpASSIGN_COMMON) {
13967                  /* See the comment before S_aassign_common_vars concerning
13968                     PL_generation sorcery.  */
13969                 PL_generation++;
13970                 if (!aassign_common_vars(o))
13971                     o->op_private &=~ OPpASSIGN_COMMON;
13972             }
13973             else if (S_aassign_common_vars_aliases_only(aTHX_ o))
13974                 o->op_private |= OPpASSIGN_COMMON;
13975             break;
13976
13977         case OP_CUSTOM: {
13978             Perl_cpeep_t cpeep =
13979                 XopENTRYCUSTOM(o, xop_peep);
13980             if (cpeep)
13981                 cpeep(aTHX_ o, oldop);
13982             break;
13983         }
13984
13985         }
13986         /* did we just null the current op? If so, re-process it to handle
13987          * eliding "empty" ops from the chain */
13988         if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
13989             o->op_opt = 0;
13990             o = oldop;
13991         }
13992         else {
13993             oldoldop = oldop;
13994             oldop = o;
13995         }
13996     }
13997     LEAVE;
13998 }
13999
14000 void
14001 Perl_peep(pTHX_ OP *o)
14002 {
14003     CALL_RPEEP(o);
14004 }
14005
14006 /*
14007 =head1 Custom Operators
14008
14009 =for apidoc Ao||custom_op_xop
14010 Return the XOP structure for a given custom op.  This macro should be
14011 considered internal to OP_NAME and the other access macros: use them instead.
14012 This macro does call a function.  Prior
14013 to 5.19.6, this was implemented as a
14014 function.
14015
14016 =cut
14017 */
14018
14019 XOPRETANY
14020 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
14021 {
14022     SV *keysv;
14023     HE *he = NULL;
14024     XOP *xop;
14025
14026     static const XOP xop_null = { 0, 0, 0, 0, 0 };
14027
14028     PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
14029     assert(o->op_type == OP_CUSTOM);
14030
14031     /* This is wrong. It assumes a function pointer can be cast to IV,
14032      * which isn't guaranteed, but this is what the old custom OP code
14033      * did. In principle it should be safer to Copy the bytes of the
14034      * pointer into a PV: since the new interface is hidden behind
14035      * functions, this can be changed later if necessary.  */
14036     /* Change custom_op_xop if this ever happens */
14037     keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
14038
14039     if (PL_custom_ops)
14040         he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
14041
14042     /* assume noone will have just registered a desc */
14043     if (!he && PL_custom_op_names &&
14044         (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
14045     ) {
14046         const char *pv;
14047         STRLEN l;
14048
14049         /* XXX does all this need to be shared mem? */
14050         Newxz(xop, 1, XOP);
14051         pv = SvPV(HeVAL(he), l);
14052         XopENTRY_set(xop, xop_name, savepvn(pv, l));
14053         if (PL_custom_op_descs &&
14054             (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
14055         ) {
14056             pv = SvPV(HeVAL(he), l);
14057             XopENTRY_set(xop, xop_desc, savepvn(pv, l));
14058         }
14059         Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
14060     }
14061     else {
14062         if (!he)
14063             xop = (XOP *)&xop_null;
14064         else
14065             xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
14066     }
14067     {
14068         XOPRETANY any;
14069         if(field == XOPe_xop_ptr) {
14070             any.xop_ptr = xop;
14071         } else {
14072             const U32 flags = XopFLAGS(xop);
14073             if(flags & field) {
14074                 switch(field) {
14075                 case XOPe_xop_name:
14076                     any.xop_name = xop->xop_name;
14077                     break;
14078                 case XOPe_xop_desc:
14079                     any.xop_desc = xop->xop_desc;
14080                     break;
14081                 case XOPe_xop_class:
14082                     any.xop_class = xop->xop_class;
14083                     break;
14084                 case XOPe_xop_peep:
14085                     any.xop_peep = xop->xop_peep;
14086                     break;
14087                 default:
14088                     NOT_REACHED; /* NOTREACHED */
14089                     break;
14090                 }
14091             } else {
14092                 switch(field) {
14093                 case XOPe_xop_name:
14094                     any.xop_name = XOPd_xop_name;
14095                     break;
14096                 case XOPe_xop_desc:
14097                     any.xop_desc = XOPd_xop_desc;
14098                     break;
14099                 case XOPe_xop_class:
14100                     any.xop_class = XOPd_xop_class;
14101                     break;
14102                 case XOPe_xop_peep:
14103                     any.xop_peep = XOPd_xop_peep;
14104                     break;
14105                 default:
14106                     NOT_REACHED; /* NOTREACHED */
14107                     break;
14108                 }
14109             }
14110         }
14111         /* Some gcc releases emit a warning for this function:
14112          * op.c: In function 'Perl_custom_op_get_field':
14113          * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
14114          * Whether this is true, is currently unknown. */
14115         return any;
14116     }
14117 }
14118
14119 /*
14120 =for apidoc Ao||custom_op_register
14121 Register a custom op.  See L<perlguts/"Custom Operators">.
14122
14123 =cut
14124 */
14125
14126 void
14127 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
14128 {
14129     SV *keysv;
14130
14131     PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
14132
14133     /* see the comment in custom_op_xop */
14134     keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
14135
14136     if (!PL_custom_ops)
14137         PL_custom_ops = newHV();
14138
14139     if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
14140         Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
14141 }
14142
14143 /*
14144
14145 =for apidoc core_prototype
14146
14147 This function assigns the prototype of the named core function to C<sv>, or
14148 to a new mortal SV if C<sv> is NULL.  It returns the modified C<sv>, or
14149 NULL if the core function has no prototype.  C<code> is a code as returned
14150 by C<keyword()>.  It must not be equal to 0.
14151
14152 =cut
14153 */
14154
14155 SV *
14156 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
14157                           int * const opnum)
14158 {
14159     int i = 0, n = 0, seen_question = 0, defgv = 0;
14160     I32 oa;
14161 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
14162     char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
14163     bool nullret = FALSE;
14164
14165     PERL_ARGS_ASSERT_CORE_PROTOTYPE;
14166
14167     assert (code);
14168
14169     if (!sv) sv = sv_newmortal();
14170
14171 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
14172
14173     switch (code < 0 ? -code : code) {
14174     case KEY_and   : case KEY_chop: case KEY_chomp:
14175     case KEY_cmp   : case KEY_defined: case KEY_delete: case KEY_exec  :
14176     case KEY_exists: case KEY_eq     : case KEY_ge    : case KEY_goto  :
14177     case KEY_grep  : case KEY_gt     : case KEY_last  : case KEY_le    :
14178     case KEY_lt    : case KEY_map    : case KEY_ne    : case KEY_next  :
14179     case KEY_or    : case KEY_print  : case KEY_printf: case KEY_qr    :
14180     case KEY_redo  : case KEY_require: case KEY_return: case KEY_say   :
14181     case KEY_select: case KEY_sort   : case KEY_split : case KEY_system:
14182     case KEY_x     : case KEY_xor    :
14183         if (!opnum) return NULL; nullret = TRUE; goto findopnum;
14184     case KEY_glob:    retsetpvs("_;", OP_GLOB);
14185     case KEY_keys:    retsetpvs("+", OP_KEYS);
14186     case KEY_values:  retsetpvs("+", OP_VALUES);
14187     case KEY_each:    retsetpvs("+", OP_EACH);
14188     case KEY_push:    retsetpvs("+@", OP_PUSH);
14189     case KEY_unshift: retsetpvs("+@", OP_UNSHIFT);
14190     case KEY_pop:     retsetpvs(";+", OP_POP);
14191     case KEY_shift:   retsetpvs(";+", OP_SHIFT);
14192     case KEY_pos:     retsetpvs(";\\[$*]", OP_POS);
14193     case KEY_splice:
14194         retsetpvs("+;$$@", OP_SPLICE);
14195     case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
14196         retsetpvs("", 0);
14197     case KEY_evalbytes:
14198         name = "entereval"; break;
14199     case KEY_readpipe:
14200         name = "backtick";
14201     }
14202
14203 #undef retsetpvs
14204
14205   findopnum:
14206     while (i < MAXO) {  /* The slow way. */
14207         if (strEQ(name, PL_op_name[i])
14208             || strEQ(name, PL_op_desc[i]))
14209         {
14210             if (nullret) { assert(opnum); *opnum = i; return NULL; }
14211             goto found;
14212         }
14213         i++;
14214     }
14215     return NULL;
14216   found:
14217     defgv = PL_opargs[i] & OA_DEFGV;
14218     oa = PL_opargs[i] >> OASHIFT;
14219     while (oa) {
14220         if (oa & OA_OPTIONAL && !seen_question && (
14221               !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
14222         )) {
14223             seen_question = 1;
14224             str[n++] = ';';
14225         }
14226         if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
14227             && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
14228             /* But globs are already references (kinda) */
14229             && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
14230         ) {
14231             str[n++] = '\\';
14232         }
14233         if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
14234          && !scalar_mod_type(NULL, i)) {
14235             str[n++] = '[';
14236             str[n++] = '$';
14237             str[n++] = '@';
14238             str[n++] = '%';
14239             if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
14240             str[n++] = '*';
14241             str[n++] = ']';
14242         }
14243         else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
14244         if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
14245             str[n-1] = '_'; defgv = 0;
14246         }
14247         oa = oa >> 4;
14248     }
14249     if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
14250     str[n++] = '\0';
14251     sv_setpvn(sv, str, n - 1);
14252     if (opnum) *opnum = i;
14253     return sv;
14254 }
14255
14256 OP *
14257 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
14258                       const int opnum)
14259 {
14260     OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
14261     OP *o;
14262
14263     PERL_ARGS_ASSERT_CORESUB_OP;
14264
14265     switch(opnum) {
14266     case 0:
14267         return op_append_elem(OP_LINESEQ,
14268                        argop,
14269                        newSLICEOP(0,
14270                                   newSVOP(OP_CONST, 0, newSViv(-code % 3)),
14271                                   newOP(OP_CALLER,0)
14272                        )
14273                );
14274     case OP_SELECT: /* which represents OP_SSELECT as well */
14275         if (code)
14276             return newCONDOP(
14277                          0,
14278                          newBINOP(OP_GT, 0,
14279                                   newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
14280                                   newSVOP(OP_CONST, 0, newSVuv(1))
14281                                  ),
14282                          coresub_op(newSVuv((UV)OP_SSELECT), 0,
14283                                     OP_SSELECT),
14284                          coresub_op(coreargssv, 0, OP_SELECT)
14285                    );
14286         /* FALLTHROUGH */
14287     default:
14288         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
14289         case OA_BASEOP:
14290             return op_append_elem(
14291                         OP_LINESEQ, argop,
14292                         newOP(opnum,
14293                               opnum == OP_WANTARRAY || opnum == OP_RUNCV
14294                                 ? OPpOFFBYONE << 8 : 0)
14295                    );
14296         case OA_BASEOP_OR_UNOP:
14297             if (opnum == OP_ENTEREVAL) {
14298                 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
14299                 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
14300             }
14301             else o = newUNOP(opnum,0,argop);
14302             if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
14303             else {
14304           onearg:
14305               if (is_handle_constructor(o, 1))
14306                 argop->op_private |= OPpCOREARGS_DEREF1;
14307               if (scalar_mod_type(NULL, opnum))
14308                 argop->op_private |= OPpCOREARGS_SCALARMOD;
14309             }
14310             return o;
14311         default:
14312             o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
14313             if (is_handle_constructor(o, 2))
14314                 argop->op_private |= OPpCOREARGS_DEREF2;
14315             if (opnum == OP_SUBSTR) {
14316                 o->op_private |= OPpMAYBE_LVSUB;
14317                 return o;
14318             }
14319             else goto onearg;
14320         }
14321     }
14322 }
14323
14324 void
14325 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
14326                                SV * const *new_const_svp)
14327 {
14328     const char *hvname;
14329     bool is_const = !!CvCONST(old_cv);
14330     SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
14331
14332     PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
14333
14334     if (is_const && new_const_svp && old_const_sv == *new_const_svp)
14335         return;
14336         /* They are 2 constant subroutines generated from
14337            the same constant. This probably means that
14338            they are really the "same" proxy subroutine
14339            instantiated in 2 places. Most likely this is
14340            when a constant is exported twice.  Don't warn.
14341         */
14342     if (
14343         (ckWARN(WARN_REDEFINE)
14344          && !(
14345                 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
14346              && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
14347              && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
14348                  strEQ(hvname, "autouse"))
14349              )
14350         )
14351      || (is_const
14352          && ckWARN_d(WARN_REDEFINE)
14353          && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
14354         )
14355     )
14356         Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
14357                           is_const
14358                             ? "Constant subroutine %"SVf" redefined"
14359                             : "Subroutine %"SVf" redefined",
14360                           SVfARG(name));
14361 }
14362
14363 /*
14364 =head1 Hook manipulation
14365
14366 These functions provide convenient and thread-safe means of manipulating
14367 hook variables.
14368
14369 =cut
14370 */
14371
14372 /*
14373 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
14374
14375 Puts a C function into the chain of check functions for a specified op
14376 type.  This is the preferred way to manipulate the L</PL_check> array.
14377 I<opcode> specifies which type of op is to be affected.  I<new_checker>
14378 is a pointer to the C function that is to be added to that opcode's
14379 check chain, and I<old_checker_p> points to the storage location where a
14380 pointer to the next function in the chain will be stored.  The value of
14381 I<new_pointer> is written into the L</PL_check> array, while the value
14382 previously stored there is written to I<*old_checker_p>.
14383
14384 The function should be defined like this:
14385
14386     static OP *new_checker(pTHX_ OP *op) { ... }
14387
14388 It is intended to be called in this manner:
14389
14390     new_checker(aTHX_ op)
14391
14392 I<old_checker_p> should be defined like this:
14393
14394     static Perl_check_t old_checker_p;
14395
14396 L</PL_check> is global to an entire process, and a module wishing to
14397 hook op checking may find itself invoked more than once per process,
14398 typically in different threads.  To handle that situation, this function
14399 is idempotent.  The location I<*old_checker_p> must initially (once
14400 per process) contain a null pointer.  A C variable of static duration
14401 (declared at file scope, typically also marked C<static> to give
14402 it internal linkage) will be implicitly initialised appropriately,
14403 if it does not have an explicit initialiser.  This function will only
14404 actually modify the check chain if it finds I<*old_checker_p> to be null.
14405 This function is also thread safe on the small scale.  It uses appropriate
14406 locking to avoid race conditions in accessing L</PL_check>.
14407
14408 When this function is called, the function referenced by I<new_checker>
14409 must be ready to be called, except for I<*old_checker_p> being unfilled.
14410 In a threading situation, I<new_checker> may be called immediately,
14411 even before this function has returned.  I<*old_checker_p> will always
14412 be appropriately set before I<new_checker> is called.  If I<new_checker>
14413 decides not to do anything special with an op that it is given (which
14414 is the usual case for most uses of op check hooking), it must chain the
14415 check function referenced by I<*old_checker_p>.
14416
14417 If you want to influence compilation of calls to a specific subroutine,
14418 then use L</cv_set_call_checker> rather than hooking checking of all
14419 C<entersub> ops.
14420
14421 =cut
14422 */
14423
14424 void
14425 Perl_wrap_op_checker(pTHX_ Optype opcode,
14426     Perl_check_t new_checker, Perl_check_t *old_checker_p)
14427 {
14428     dVAR;
14429
14430     PERL_UNUSED_CONTEXT;
14431     PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
14432     if (*old_checker_p) return;
14433     OP_CHECK_MUTEX_LOCK;
14434     if (!*old_checker_p) {
14435         *old_checker_p = PL_check[opcode];
14436         PL_check[opcode] = new_checker;
14437     }
14438     OP_CHECK_MUTEX_UNLOCK;
14439 }
14440
14441 #include "XSUB.h"
14442
14443 /* Efficient sub that returns a constant scalar value. */
14444 static void
14445 const_sv_xsub(pTHX_ CV* cv)
14446 {
14447     dXSARGS;
14448     SV *const sv = MUTABLE_SV(XSANY.any_ptr);
14449     PERL_UNUSED_ARG(items);
14450     if (!sv) {
14451         XSRETURN(0);
14452     }
14453     EXTEND(sp, 1);
14454     ST(0) = sv;
14455     XSRETURN(1);
14456 }
14457
14458 static void
14459 const_av_xsub(pTHX_ CV* cv)
14460 {
14461     dXSARGS;
14462     AV * const av = MUTABLE_AV(XSANY.any_ptr);
14463     SP -= items;
14464     assert(av);
14465 #ifndef DEBUGGING
14466     if (!av) {
14467         XSRETURN(0);
14468     }
14469 #endif
14470     if (SvRMAGICAL(av))
14471         Perl_croak(aTHX_ "Magical list constants are not supported");
14472     if (GIMME_V != G_ARRAY) {
14473         EXTEND(SP, 1);
14474         ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
14475         XSRETURN(1);
14476     }
14477     EXTEND(SP, AvFILLp(av)+1);
14478     Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
14479     XSRETURN(AvFILLp(av)+1);
14480 }
14481
14482 /*
14483  * ex: set ts=8 sts=4 sw=4 et:
14484  */