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 C<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 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1226 the splicing doesn't affect the first or last op in the chain.
1227
1228 C<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 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1231 beginning.
1232
1233 C<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 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1238 If C<NULL>, no nodes are inserted.
1239
1240 The head of the chain of deleted ops is returned, or C<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<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</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 C<o>, if it has a parent. Returns C<NULL> otherwise.
1366 This function is only available on perls built with C<-DPERL_OP_PARENT>.
1367
1368 =cut
1369 */
1370
1371 OP *
1372 Perl_op_parent(OP *o)
1373 {
1374     PERL_ARGS_ASSERT_OP_PARENT;
1375     while (OpHAS_SIBLING(o))
1376         o = OpSIBLING(o);
1377     return o->op_sibparent;
1378 }
1379
1380 #endif
1381
1382
1383 /* replace the sibling following start with a new UNOP, which becomes
1384  * the parent of the original sibling; e.g.
1385  *
1386  *  op_sibling_newUNOP(P, A, unop-args...)
1387  *
1388  *  P              P
1389  *  |      becomes |
1390  *  A-B-C          A-U-C
1391  *                   |
1392  *                   B
1393  *
1394  * where U is the new UNOP.
1395  *
1396  * parent and start args are the same as for op_sibling_splice();
1397  * type and flags args are as newUNOP().
1398  *
1399  * Returns the new UNOP.
1400  */
1401
1402 OP *
1403 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1404 {
1405     OP *kid, *newop;
1406
1407     kid = op_sibling_splice(parent, start, 1, NULL);
1408     newop = newUNOP(type, flags, kid);
1409     op_sibling_splice(parent, start, 0, newop);
1410     return newop;
1411 }
1412
1413
1414 /* lowest-level newLOGOP-style function - just allocates and populates
1415  * the struct. Higher-level stuff should be done by S_new_logop() /
1416  * newLOGOP(). This function exists mainly to avoid op_first assignment
1417  * being spread throughout this file.
1418  */
1419
1420 LOGOP *
1421 S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1422 {
1423     dVAR;
1424     LOGOP *logop;
1425     OP *kid = first;
1426     NewOp(1101, logop, 1, LOGOP);
1427     OpTYPE_set(logop, type);
1428     logop->op_first = first;
1429     logop->op_other = other;
1430     logop->op_flags = OPf_KIDS;
1431     while (kid && OpHAS_SIBLING(kid))
1432         kid = OpSIBLING(kid);
1433     if (kid)
1434         OpLASTSIB_set(kid, (OP*)logop);
1435     return logop;
1436 }
1437
1438
1439 /* Contextualizers */
1440
1441 /*
1442 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1443
1444 Applies a syntactic context to an op tree representing an expression.
1445 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
1446 or C<G_VOID> to specify the context to apply.  The modified op tree
1447 is returned.
1448
1449 =cut
1450 */
1451
1452 OP *
1453 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1454 {
1455     PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1456     switch (context) {
1457         case G_SCALAR: return scalar(o);
1458         case G_ARRAY:  return list(o);
1459         case G_VOID:   return scalarvoid(o);
1460         default:
1461             Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1462                        (long) context);
1463     }
1464 }
1465
1466 /*
1467
1468 =for apidoc Am|OP*|op_linklist|OP *o
1469 This function is the implementation of the L</LINKLIST> macro.  It should
1470 not be called directly.
1471
1472 =cut
1473 */
1474
1475 OP *
1476 Perl_op_linklist(pTHX_ OP *o)
1477 {
1478     OP *first;
1479
1480     PERL_ARGS_ASSERT_OP_LINKLIST;
1481
1482     if (o->op_next)
1483         return o->op_next;
1484
1485     /* establish postfix order */
1486     first = cUNOPo->op_first;
1487     if (first) {
1488         OP *kid;
1489         o->op_next = LINKLIST(first);
1490         kid = first;
1491         for (;;) {
1492             OP *sibl = OpSIBLING(kid);
1493             if (sibl) {
1494                 kid->op_next = LINKLIST(sibl);
1495                 kid = sibl;
1496             } else {
1497                 kid->op_next = o;
1498                 break;
1499             }
1500         }
1501     }
1502     else
1503         o->op_next = o;
1504
1505     return o->op_next;
1506 }
1507
1508 static OP *
1509 S_scalarkids(pTHX_ OP *o)
1510 {
1511     if (o && o->op_flags & OPf_KIDS) {
1512         OP *kid;
1513         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1514             scalar(kid);
1515     }
1516     return o;
1517 }
1518
1519 STATIC OP *
1520 S_scalarboolean(pTHX_ OP *o)
1521 {
1522     PERL_ARGS_ASSERT_SCALARBOOLEAN;
1523
1524     if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
1525      && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
1526         if (ckWARN(WARN_SYNTAX)) {
1527             const line_t oldline = CopLINE(PL_curcop);
1528
1529             if (PL_parser && PL_parser->copline != NOLINE) {
1530                 /* This ensures that warnings are reported at the first line
1531                    of the conditional, not the last.  */
1532                 CopLINE_set(PL_curcop, PL_parser->copline);
1533             }
1534             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1535             CopLINE_set(PL_curcop, oldline);
1536         }
1537     }
1538     return scalar(o);
1539 }
1540
1541 static SV *
1542 S_op_varname(pTHX_ const OP *o)
1543 {
1544     assert(o);
1545     assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1546            o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1547     {
1548         const char funny  = o->op_type == OP_PADAV
1549                          || o->op_type == OP_RV2AV ? '@' : '%';
1550         if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1551             GV *gv;
1552             if (cUNOPo->op_first->op_type != OP_GV
1553              || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1554                 return NULL;
1555             return varname(gv, funny, 0, NULL, 0, 1);
1556         }
1557         return
1558             varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, 1);
1559     }
1560 }
1561
1562 static void
1563 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1564 { /* or not so pretty :-) */
1565     if (o->op_type == OP_CONST) {
1566         *retsv = cSVOPo_sv;
1567         if (SvPOK(*retsv)) {
1568             SV *sv = *retsv;
1569             *retsv = sv_newmortal();
1570             pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1571                       PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1572         }
1573         else if (!SvOK(*retsv))
1574             *retpv = "undef";
1575     }
1576     else *retpv = "...";
1577 }
1578
1579 static void
1580 S_scalar_slice_warning(pTHX_ const OP *o)
1581 {
1582     OP *kid;
1583     const char lbrack =
1584         o->op_type == OP_HSLICE ? '{' : '[';
1585     const char rbrack =
1586         o->op_type == OP_HSLICE ? '}' : ']';
1587     SV *name;
1588     SV *keysv = NULL; /* just to silence compiler warnings */
1589     const char *key = NULL;
1590
1591     if (!(o->op_private & OPpSLICEWARNING))
1592         return;
1593     if (PL_parser && PL_parser->error_count)
1594         /* This warning can be nonsensical when there is a syntax error. */
1595         return;
1596
1597     kid = cLISTOPo->op_first;
1598     kid = OpSIBLING(kid); /* get past pushmark */
1599     /* weed out false positives: any ops that can return lists */
1600     switch (kid->op_type) {
1601     case OP_BACKTICK:
1602     case OP_GLOB:
1603     case OP_READLINE:
1604     case OP_MATCH:
1605     case OP_RV2AV:
1606     case OP_EACH:
1607     case OP_VALUES:
1608     case OP_KEYS:
1609     case OP_SPLIT:
1610     case OP_LIST:
1611     case OP_SORT:
1612     case OP_REVERSE:
1613     case OP_ENTERSUB:
1614     case OP_CALLER:
1615     case OP_LSTAT:
1616     case OP_STAT:
1617     case OP_READDIR:
1618     case OP_SYSTEM:
1619     case OP_TMS:
1620     case OP_LOCALTIME:
1621     case OP_GMTIME:
1622     case OP_ENTEREVAL:
1623         return;
1624     }
1625
1626     /* Don't warn if we have a nulled list either. */
1627     if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1628         return;
1629
1630     assert(OpSIBLING(kid));
1631     name = S_op_varname(aTHX_ OpSIBLING(kid));
1632     if (!name) /* XS module fiddling with the op tree */
1633         return;
1634     S_op_pretty(aTHX_ kid, &keysv, &key);
1635     assert(SvPOK(name));
1636     sv_chop(name,SvPVX(name)+1);
1637     if (key)
1638        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1639         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1640                    "Scalar value @%"SVf"%c%s%c better written as $%"SVf
1641                    "%c%s%c",
1642                     SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1643                     lbrack, key, rbrack);
1644     else
1645        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1646         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1647                    "Scalar value @%"SVf"%c%"SVf"%c better written as $%"
1648                     SVf"%c%"SVf"%c",
1649                     SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1650                     SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1651 }
1652
1653 OP *
1654 Perl_scalar(pTHX_ OP *o)
1655 {
1656     OP *kid;
1657
1658     /* assumes no premature commitment */
1659     if (!o || (PL_parser && PL_parser->error_count)
1660          || (o->op_flags & OPf_WANT)
1661          || o->op_type == OP_RETURN)
1662     {
1663         return o;
1664     }
1665
1666     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1667
1668     switch (o->op_type) {
1669     case OP_REPEAT:
1670         scalar(cBINOPo->op_first);
1671         if (o->op_private & OPpREPEAT_DOLIST) {
1672             kid = cLISTOPx(cUNOPo->op_first)->op_first;
1673             assert(kid->op_type == OP_PUSHMARK);
1674             if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1675                 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1676                 o->op_private &=~ OPpREPEAT_DOLIST;
1677             }
1678         }
1679         break;
1680     case OP_OR:
1681     case OP_AND:
1682     case OP_COND_EXPR:
1683         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
1684             scalar(kid);
1685         break;
1686         /* FALLTHROUGH */
1687     case OP_SPLIT:
1688     case OP_MATCH:
1689     case OP_QR:
1690     case OP_SUBST:
1691     case OP_NULL:
1692     default:
1693         if (o->op_flags & OPf_KIDS) {
1694             for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1695                 scalar(kid);
1696         }
1697         break;
1698     case OP_LEAVE:
1699     case OP_LEAVETRY:
1700         kid = cLISTOPo->op_first;
1701         scalar(kid);
1702         kid = OpSIBLING(kid);
1703     do_kids:
1704         while (kid) {
1705             OP *sib = OpSIBLING(kid);
1706             if (sib && kid->op_type != OP_LEAVEWHEN
1707              && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
1708                 || (  sib->op_targ != OP_NEXTSTATE
1709                    && sib->op_targ != OP_DBSTATE  )))
1710                 scalarvoid(kid);
1711             else
1712                 scalar(kid);
1713             kid = sib;
1714         }
1715         PL_curcop = &PL_compiling;
1716         break;
1717     case OP_SCOPE:
1718     case OP_LINESEQ:
1719     case OP_LIST:
1720         kid = cLISTOPo->op_first;
1721         goto do_kids;
1722     case OP_SORT:
1723         Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1724         break;
1725     case OP_KVHSLICE:
1726     case OP_KVASLICE:
1727     {
1728         /* Warn about scalar context */
1729         const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1730         const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1731         SV *name;
1732         SV *keysv;
1733         const char *key = NULL;
1734
1735         /* This warning can be nonsensical when there is a syntax error. */
1736         if (PL_parser && PL_parser->error_count)
1737             break;
1738
1739         if (!ckWARN(WARN_SYNTAX)) break;
1740
1741         kid = cLISTOPo->op_first;
1742         kid = OpSIBLING(kid); /* get past pushmark */
1743         assert(OpSIBLING(kid));
1744         name = S_op_varname(aTHX_ OpSIBLING(kid));
1745         if (!name) /* XS module fiddling with the op tree */
1746             break;
1747         S_op_pretty(aTHX_ kid, &keysv, &key);
1748         assert(SvPOK(name));
1749         sv_chop(name,SvPVX(name)+1);
1750         if (key)
1751   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1752             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1753                        "%%%"SVf"%c%s%c in scalar context better written "
1754                        "as $%"SVf"%c%s%c",
1755                         SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1756                         lbrack, key, rbrack);
1757         else
1758   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1759             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1760                        "%%%"SVf"%c%"SVf"%c in scalar context better "
1761                        "written as $%"SVf"%c%"SVf"%c",
1762                         SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1763                         SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1764     }
1765     }
1766     return o;
1767 }
1768
1769 OP *
1770 Perl_scalarvoid(pTHX_ OP *arg)
1771 {
1772     dVAR;
1773     OP *kid;
1774     SV* sv;
1775     U8 want;
1776     SSize_t defer_stack_alloc = 0;
1777     SSize_t defer_ix = -1;
1778     OP **defer_stack = NULL;
1779     OP *o = arg;
1780
1781     PERL_ARGS_ASSERT_SCALARVOID;
1782
1783     do {
1784         SV *useless_sv = NULL;
1785         const char* useless = NULL;
1786
1787         if (o->op_type == OP_NEXTSTATE
1788             || o->op_type == OP_DBSTATE
1789             || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1790                                           || o->op_targ == OP_DBSTATE)))
1791             PL_curcop = (COP*)o;                /* for warning below */
1792
1793         /* assumes no premature commitment */
1794         want = o->op_flags & OPf_WANT;
1795         if ((want && want != OPf_WANT_SCALAR)
1796             || (PL_parser && PL_parser->error_count)
1797             || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1798         {
1799             continue;
1800         }
1801
1802         if ((o->op_private & OPpTARGET_MY)
1803             && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1804         {
1805             /* newASSIGNOP has already applied scalar context, which we
1806                leave, as if this op is inside SASSIGN.  */
1807             continue;
1808         }
1809
1810         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1811
1812         switch (o->op_type) {
1813         default:
1814             if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1815                 break;
1816             /* FALLTHROUGH */
1817         case OP_REPEAT:
1818             if (o->op_flags & OPf_STACKED)
1819                 break;
1820             if (o->op_type == OP_REPEAT)
1821                 scalar(cBINOPo->op_first);
1822             goto func_ops;
1823         case OP_SUBSTR:
1824             if (o->op_private == 4)
1825                 break;
1826             /* FALLTHROUGH */
1827         case OP_WANTARRAY:
1828         case OP_GV:
1829         case OP_SMARTMATCH:
1830         case OP_AV2ARYLEN:
1831         case OP_REF:
1832         case OP_REFGEN:
1833         case OP_SREFGEN:
1834         case OP_DEFINED:
1835         case OP_HEX:
1836         case OP_OCT:
1837         case OP_LENGTH:
1838         case OP_VEC:
1839         case OP_INDEX:
1840         case OP_RINDEX:
1841         case OP_SPRINTF:
1842         case OP_KVASLICE:
1843         case OP_KVHSLICE:
1844         case OP_UNPACK:
1845         case OP_PACK:
1846         case OP_JOIN:
1847         case OP_LSLICE:
1848         case OP_ANONLIST:
1849         case OP_ANONHASH:
1850         case OP_SORT:
1851         case OP_REVERSE:
1852         case OP_RANGE:
1853         case OP_FLIP:
1854         case OP_FLOP:
1855         case OP_CALLER:
1856         case OP_FILENO:
1857         case OP_EOF:
1858         case OP_TELL:
1859         case OP_GETSOCKNAME:
1860         case OP_GETPEERNAME:
1861         case OP_READLINK:
1862         case OP_TELLDIR:
1863         case OP_GETPPID:
1864         case OP_GETPGRP:
1865         case OP_GETPRIORITY:
1866         case OP_TIME:
1867         case OP_TMS:
1868         case OP_LOCALTIME:
1869         case OP_GMTIME:
1870         case OP_GHBYNAME:
1871         case OP_GHBYADDR:
1872         case OP_GHOSTENT:
1873         case OP_GNBYNAME:
1874         case OP_GNBYADDR:
1875         case OP_GNETENT:
1876         case OP_GPBYNAME:
1877         case OP_GPBYNUMBER:
1878         case OP_GPROTOENT:
1879         case OP_GSBYNAME:
1880         case OP_GSBYPORT:
1881         case OP_GSERVENT:
1882         case OP_GPWNAM:
1883         case OP_GPWUID:
1884         case OP_GGRNAM:
1885         case OP_GGRGID:
1886         case OP_GETLOGIN:
1887         case OP_PROTOTYPE:
1888         case OP_RUNCV:
1889         func_ops:
1890             useless = OP_DESC(o);
1891             break;
1892
1893         case OP_GVSV:
1894         case OP_PADSV:
1895         case OP_PADAV:
1896         case OP_PADHV:
1897         case OP_PADANY:
1898         case OP_AELEM:
1899         case OP_AELEMFAST:
1900         case OP_AELEMFAST_LEX:
1901         case OP_ASLICE:
1902         case OP_HELEM:
1903         case OP_HSLICE:
1904             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1905                 /* Otherwise it's "Useless use of grep iterator" */
1906                 useless = OP_DESC(o);
1907             break;
1908
1909         case OP_SPLIT:
1910             kid = cLISTOPo->op_first;
1911             if (kid && kid->op_type == OP_PUSHRE
1912                 && !kid->op_targ
1913                 && !(o->op_flags & OPf_STACKED)
1914 #ifdef USE_ITHREADS
1915                 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
1916 #else
1917                 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
1918 #endif
1919                 )
1920                 useless = OP_DESC(o);
1921             break;
1922
1923         case OP_NOT:
1924             kid = cUNOPo->op_first;
1925             if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1926                 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1927                 goto func_ops;
1928             }
1929             useless = "negative pattern binding (!~)";
1930             break;
1931
1932         case OP_SUBST:
1933             if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1934                 useless = "non-destructive substitution (s///r)";
1935             break;
1936
1937         case OP_TRANSR:
1938             useless = "non-destructive transliteration (tr///r)";
1939             break;
1940
1941         case OP_RV2GV:
1942         case OP_RV2SV:
1943         case OP_RV2AV:
1944         case OP_RV2HV:
1945             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1946                 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
1947                 useless = "a variable";
1948             break;
1949
1950         case OP_CONST:
1951             sv = cSVOPo_sv;
1952             if (cSVOPo->op_private & OPpCONST_STRICT)
1953                 no_bareword_allowed(o);
1954             else {
1955                 if (ckWARN(WARN_VOID)) {
1956                     NV nv;
1957                     /* don't warn on optimised away booleans, eg
1958                      * use constant Foo, 5; Foo || print; */
1959                     if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1960                         useless = NULL;
1961                     /* the constants 0 and 1 are permitted as they are
1962                        conventionally used as dummies in constructs like
1963                        1 while some_condition_with_side_effects;  */
1964                     else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
1965                         useless = NULL;
1966                     else if (SvPOK(sv)) {
1967                         SV * const dsv = newSVpvs("");
1968                         useless_sv
1969                             = Perl_newSVpvf(aTHX_
1970                                             "a constant (%s)",
1971                                             pv_pretty(dsv, SvPVX_const(sv),
1972                                                       SvCUR(sv), 32, NULL, NULL,
1973                                                       PERL_PV_PRETTY_DUMP
1974                                                       | PERL_PV_ESCAPE_NOCLEAR
1975                                                       | PERL_PV_ESCAPE_UNI_DETECT));
1976                         SvREFCNT_dec_NN(dsv);
1977                     }
1978                     else if (SvOK(sv)) {
1979                         useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", SVfARG(sv));
1980                     }
1981                     else
1982                         useless = "a constant (undef)";
1983                 }
1984             }
1985             op_null(o);         /* don't execute or even remember it */
1986             break;
1987
1988         case OP_POSTINC:
1989             OpTYPE_set(o, OP_PREINC);  /* pre-increment is faster */
1990             break;
1991
1992         case OP_POSTDEC:
1993             OpTYPE_set(o, OP_PREDEC);  /* pre-decrement is faster */
1994             break;
1995
1996         case OP_I_POSTINC:
1997             OpTYPE_set(o, OP_I_PREINC);        /* pre-increment is faster */
1998             break;
1999
2000         case OP_I_POSTDEC:
2001             OpTYPE_set(o, OP_I_PREDEC);        /* pre-decrement is faster */
2002             break;
2003
2004         case OP_SASSIGN: {
2005             OP *rv2gv;
2006             UNOP *refgen, *rv2cv;
2007             LISTOP *exlist;
2008
2009             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2010                 break;
2011
2012             rv2gv = ((BINOP *)o)->op_last;
2013             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2014                 break;
2015
2016             refgen = (UNOP *)((BINOP *)o)->op_first;
2017
2018             if (!refgen || (refgen->op_type != OP_REFGEN
2019                             && refgen->op_type != OP_SREFGEN))
2020                 break;
2021
2022             exlist = (LISTOP *)refgen->op_first;
2023             if (!exlist || exlist->op_type != OP_NULL
2024                 || exlist->op_targ != OP_LIST)
2025                 break;
2026
2027             if (exlist->op_first->op_type != OP_PUSHMARK
2028                 && exlist->op_first != exlist->op_last)
2029                 break;
2030
2031             rv2cv = (UNOP*)exlist->op_last;
2032
2033             if (rv2cv->op_type != OP_RV2CV)
2034                 break;
2035
2036             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2037             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2038             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2039
2040             o->op_private |= OPpASSIGN_CV_TO_GV;
2041             rv2gv->op_private |= OPpDONT_INIT_GV;
2042             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2043
2044             break;
2045         }
2046
2047         case OP_AASSIGN: {
2048             inplace_aassign(o);
2049             break;
2050         }
2051
2052         case OP_OR:
2053         case OP_AND:
2054             kid = cLOGOPo->op_first;
2055             if (kid->op_type == OP_NOT
2056                 && (kid->op_flags & OPf_KIDS)) {
2057                 if (o->op_type == OP_AND) {
2058                     OpTYPE_set(o, OP_OR);
2059                 } else {
2060                     OpTYPE_set(o, OP_AND);
2061                 }
2062                 op_null(kid);
2063             }
2064             /* FALLTHROUGH */
2065
2066         case OP_DOR:
2067         case OP_COND_EXPR:
2068         case OP_ENTERGIVEN:
2069         case OP_ENTERWHEN:
2070             for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2071                 if (!(kid->op_flags & OPf_KIDS))
2072                     scalarvoid(kid);
2073                 else
2074                     DEFER_OP(kid);
2075         break;
2076
2077         case OP_NULL:
2078             if (o->op_flags & OPf_STACKED)
2079                 break;
2080             /* FALLTHROUGH */
2081         case OP_NEXTSTATE:
2082         case OP_DBSTATE:
2083         case OP_ENTERTRY:
2084         case OP_ENTER:
2085             if (!(o->op_flags & OPf_KIDS))
2086                 break;
2087             /* FALLTHROUGH */
2088         case OP_SCOPE:
2089         case OP_LEAVE:
2090         case OP_LEAVETRY:
2091         case OP_LEAVELOOP:
2092         case OP_LINESEQ:
2093         case OP_LEAVEGIVEN:
2094         case OP_LEAVEWHEN:
2095         kids:
2096             for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2097                 if (!(kid->op_flags & OPf_KIDS))
2098                     scalarvoid(kid);
2099                 else
2100                     DEFER_OP(kid);
2101             break;
2102         case OP_LIST:
2103             /* If the first kid after pushmark is something that the padrange
2104                optimisation would reject, then null the list and the pushmark.
2105             */
2106             if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2107                 && (  !(kid = OpSIBLING(kid))
2108                       || (  kid->op_type != OP_PADSV
2109                             && kid->op_type != OP_PADAV
2110                             && kid->op_type != OP_PADHV)
2111                       || kid->op_private & ~OPpLVAL_INTRO
2112                       || !(kid = OpSIBLING(kid))
2113                       || (  kid->op_type != OP_PADSV
2114                             && kid->op_type != OP_PADAV
2115                             && kid->op_type != OP_PADHV)
2116                       || kid->op_private & ~OPpLVAL_INTRO)
2117             ) {
2118                 op_null(cUNOPo->op_first); /* NULL the pushmark */
2119                 op_null(o); /* NULL the list */
2120             }
2121             goto kids;
2122         case OP_ENTEREVAL:
2123             scalarkids(o);
2124             break;
2125         case OP_SCALAR:
2126             scalar(o);
2127             break;
2128         }
2129
2130         if (useless_sv) {
2131             /* mortalise it, in case warnings are fatal.  */
2132             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2133                            "Useless use of %"SVf" in void context",
2134                            SVfARG(sv_2mortal(useless_sv)));
2135         }
2136         else if (useless) {
2137             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2138                            "Useless use of %s in void context",
2139                            useless);
2140         }
2141     } while ( (o = POP_DEFERRED_OP()) );
2142
2143     Safefree(defer_stack);
2144
2145     return arg;
2146 }
2147
2148 static OP *
2149 S_listkids(pTHX_ OP *o)
2150 {
2151     if (o && o->op_flags & OPf_KIDS) {
2152         OP *kid;
2153         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2154             list(kid);
2155     }
2156     return o;
2157 }
2158
2159 OP *
2160 Perl_list(pTHX_ OP *o)
2161 {
2162     OP *kid;
2163
2164     /* assumes no premature commitment */
2165     if (!o || (o->op_flags & OPf_WANT)
2166          || (PL_parser && PL_parser->error_count)
2167          || o->op_type == OP_RETURN)
2168     {
2169         return o;
2170     }
2171
2172     if ((o->op_private & OPpTARGET_MY)
2173         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2174     {
2175         return o;                               /* As if inside SASSIGN */
2176     }
2177
2178     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2179
2180     switch (o->op_type) {
2181     case OP_FLOP:
2182         list(cBINOPo->op_first);
2183         break;
2184     case OP_REPEAT:
2185         if (o->op_private & OPpREPEAT_DOLIST
2186          && !(o->op_flags & OPf_STACKED))
2187         {
2188             list(cBINOPo->op_first);
2189             kid = cBINOPo->op_last;
2190             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2191              && SvIVX(kSVOP_sv) == 1)
2192             {
2193                 op_null(o); /* repeat */
2194                 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2195                 /* const (rhs): */
2196                 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2197             }
2198         }
2199         break;
2200     case OP_OR:
2201     case OP_AND:
2202     case OP_COND_EXPR:
2203         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2204             list(kid);
2205         break;
2206     default:
2207     case OP_MATCH:
2208     case OP_QR:
2209     case OP_SUBST:
2210     case OP_NULL:
2211         if (!(o->op_flags & OPf_KIDS))
2212             break;
2213         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2214             list(cBINOPo->op_first);
2215             return gen_constant_list(o);
2216         }
2217         listkids(o);
2218         break;
2219     case OP_LIST:
2220         listkids(o);
2221         if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2222             op_null(cUNOPo->op_first); /* NULL the pushmark */
2223             op_null(o); /* NULL the list */
2224         }
2225         break;
2226     case OP_LEAVE:
2227     case OP_LEAVETRY:
2228         kid = cLISTOPo->op_first;
2229         list(kid);
2230         kid = OpSIBLING(kid);
2231     do_kids:
2232         while (kid) {
2233             OP *sib = OpSIBLING(kid);
2234             if (sib && kid->op_type != OP_LEAVEWHEN)
2235                 scalarvoid(kid);
2236             else
2237                 list(kid);
2238             kid = sib;
2239         }
2240         PL_curcop = &PL_compiling;
2241         break;
2242     case OP_SCOPE:
2243     case OP_LINESEQ:
2244         kid = cLISTOPo->op_first;
2245         goto do_kids;
2246     }
2247     return o;
2248 }
2249
2250 static OP *
2251 S_scalarseq(pTHX_ OP *o)
2252 {
2253     if (o) {
2254         const OPCODE type = o->op_type;
2255
2256         if (type == OP_LINESEQ || type == OP_SCOPE ||
2257             type == OP_LEAVE || type == OP_LEAVETRY)
2258         {
2259             OP *kid, *sib;
2260             for (kid = cLISTOPo->op_first; kid; kid = sib) {
2261                 if ((sib = OpSIBLING(kid))
2262                  && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2263                     || (  sib->op_targ != OP_NEXTSTATE
2264                        && sib->op_targ != OP_DBSTATE  )))
2265                 {
2266                     scalarvoid(kid);
2267                 }
2268             }
2269             PL_curcop = &PL_compiling;
2270         }
2271         o->op_flags &= ~OPf_PARENS;
2272         if (PL_hints & HINT_BLOCK_SCOPE)
2273             o->op_flags |= OPf_PARENS;
2274     }
2275     else
2276         o = newOP(OP_STUB, 0);
2277     return o;
2278 }
2279
2280 STATIC OP *
2281 S_modkids(pTHX_ OP *o, I32 type)
2282 {
2283     if (o && o->op_flags & OPf_KIDS) {
2284         OP *kid;
2285         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2286             op_lvalue(kid, type);
2287     }
2288     return o;
2289 }
2290
2291
2292 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2293  * const fields. Also, convert CONST keys to HEK-in-SVs.
2294  * rop is the op that retrieves the hash;
2295  * key_op is the first key
2296  */
2297
2298 void
2299 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op)
2300 {
2301     PADNAME *lexname;
2302     GV **fields;
2303     bool check_fields;
2304
2305     /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2306     if (rop) {
2307         if (rop->op_first->op_type == OP_PADSV)
2308             /* @$hash{qw(keys here)} */
2309             rop = (UNOP*)rop->op_first;
2310         else {
2311             /* @{$hash}{qw(keys here)} */
2312             if (rop->op_first->op_type == OP_SCOPE
2313                 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2314                 {
2315                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2316                 }
2317             else
2318                 rop = NULL;
2319         }
2320     }
2321
2322     lexname = NULL; /* just to silence compiler warnings */
2323     fields  = NULL; /* just to silence compiler warnings */
2324
2325     check_fields =
2326             rop
2327          && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2328              SvPAD_TYPED(lexname))
2329          && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2330          && isGV(*fields) && GvHV(*fields);
2331
2332     for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2333         SV **svp, *sv;
2334         if (key_op->op_type != OP_CONST)
2335             continue;
2336         svp = cSVOPx_svp(key_op);
2337
2338         /* Make the CONST have a shared SV */
2339         if (   !SvIsCOW_shared_hash(sv = *svp)
2340             && SvTYPE(sv) < SVt_PVMG
2341             && SvOK(sv)
2342             && !SvROK(sv))
2343         {
2344             SSize_t keylen;
2345             const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2346             SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2347             SvREFCNT_dec_NN(sv);
2348             *svp = nsv;
2349         }
2350
2351         if (   check_fields
2352             && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2353         {
2354             Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
2355                         "in variable %"PNf" of type %"HEKf,
2356                         SVfARG(*svp), PNfARG(lexname),
2357                         HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2358         }
2359     }
2360 }
2361
2362
2363 /*
2364 =for apidoc finalize_optree
2365
2366 This function finalizes the optree.  Should be called directly after
2367 the complete optree is built.  It does some additional
2368 checking which can't be done in the normal C<ck_>xxx functions and makes
2369 the tree thread-safe.
2370
2371 =cut
2372 */
2373 void
2374 Perl_finalize_optree(pTHX_ OP* o)
2375 {
2376     PERL_ARGS_ASSERT_FINALIZE_OPTREE;
2377
2378     ENTER;
2379     SAVEVPTR(PL_curcop);
2380
2381     finalize_op(o);
2382
2383     LEAVE;
2384 }
2385
2386 #ifdef USE_ITHREADS
2387 /* Relocate sv to the pad for thread safety.
2388  * Despite being a "constant", the SV is written to,
2389  * for reference counts, sv_upgrade() etc. */
2390 PERL_STATIC_INLINE void
2391 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
2392 {
2393     PADOFFSET ix;
2394     PERL_ARGS_ASSERT_OP_RELOCATE_SV;
2395     if (!*svp) return;
2396     ix = pad_alloc(OP_CONST, SVf_READONLY);
2397     SvREFCNT_dec(PAD_SVl(ix));
2398     PAD_SETSV(ix, *svp);
2399     /* XXX I don't know how this isn't readonly already. */
2400     if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
2401     *svp = NULL;
2402     *targp = ix;
2403 }
2404 #endif
2405
2406
2407 STATIC void
2408 S_finalize_op(pTHX_ OP* o)
2409 {
2410     PERL_ARGS_ASSERT_FINALIZE_OP;
2411
2412
2413     switch (o->op_type) {
2414     case OP_NEXTSTATE:
2415     case OP_DBSTATE:
2416         PL_curcop = ((COP*)o);          /* for warnings */
2417         break;
2418     case OP_EXEC:
2419         if (OpHAS_SIBLING(o)) {
2420             OP *sib = OpSIBLING(o);
2421             if ((  sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
2422                 && ckWARN(WARN_EXEC)
2423                 && OpHAS_SIBLING(sib))
2424             {
2425                     const OPCODE type = OpSIBLING(sib)->op_type;
2426                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
2427                         const line_t oldline = CopLINE(PL_curcop);
2428                         CopLINE_set(PL_curcop, CopLINE((COP*)sib));
2429                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
2430                             "Statement unlikely to be reached");
2431                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
2432                             "\t(Maybe you meant system() when you said exec()?)\n");
2433                         CopLINE_set(PL_curcop, oldline);
2434                     }
2435             }
2436         }
2437         break;
2438
2439     case OP_GV:
2440         if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
2441             GV * const gv = cGVOPo_gv;
2442             if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
2443                 /* XXX could check prototype here instead of just carping */
2444                 SV * const sv = sv_newmortal();
2445                 gv_efullname3(sv, gv, NULL);
2446                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
2447                     "%"SVf"() called too early to check prototype",
2448                     SVfARG(sv));
2449             }
2450         }
2451         break;
2452
2453     case OP_CONST:
2454         if (cSVOPo->op_private & OPpCONST_STRICT)
2455             no_bareword_allowed(o);
2456         /* FALLTHROUGH */
2457 #ifdef USE_ITHREADS
2458     case OP_HINTSEVAL:
2459         op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
2460 #endif
2461         break;
2462
2463 #ifdef USE_ITHREADS
2464     /* Relocate all the METHOP's SVs to the pad for thread safety. */
2465     case OP_METHOD_NAMED:
2466     case OP_METHOD_SUPER:
2467     case OP_METHOD_REDIR:
2468     case OP_METHOD_REDIR_SUPER:
2469         op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
2470         break;
2471 #endif
2472
2473     case OP_HELEM: {
2474         UNOP *rop;
2475         SVOP *key_op;
2476         OP *kid;
2477
2478         if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
2479             break;
2480
2481         rop = (UNOP*)((BINOP*)o)->op_first;
2482
2483         goto check_keys;
2484
2485     case OP_HSLICE:
2486         S_scalar_slice_warning(aTHX_ o);
2487         /* FALLTHROUGH */
2488
2489     case OP_KVHSLICE:
2490         kid = OpSIBLING(cLISTOPo->op_first);
2491         if (/* I bet there's always a pushmark... */
2492             OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
2493             && OP_TYPE_ISNT_NN(kid, OP_CONST))
2494         {
2495             break;
2496         }
2497
2498         key_op = (SVOP*)(kid->op_type == OP_CONST
2499                                 ? kid
2500                                 : OpSIBLING(kLISTOP->op_first));
2501
2502         rop = (UNOP*)((LISTOP*)o)->op_last;
2503
2504       check_keys:
2505         if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
2506             rop = NULL;
2507         S_check_hash_fields_and_hekify(aTHX_ rop, key_op);
2508         break;
2509     }
2510     case OP_ASLICE:
2511         S_scalar_slice_warning(aTHX_ o);
2512         break;
2513
2514     case OP_SUBST: {
2515         if (cPMOPo->op_pmreplrootu.op_pmreplroot)
2516             finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
2517         break;
2518     }
2519     default:
2520         break;
2521     }
2522
2523     if (o->op_flags & OPf_KIDS) {
2524         OP *kid;
2525
2526 #ifdef DEBUGGING
2527         /* check that op_last points to the last sibling, and that
2528          * the last op_sibling/op_sibparent field points back to the
2529          * parent, and that the only ops with KIDS are those which are
2530          * entitled to them */
2531         U32 type = o->op_type;
2532         U32 family;
2533         bool has_last;
2534
2535         if (type == OP_NULL) {
2536             type = o->op_targ;
2537             /* ck_glob creates a null UNOP with ex-type GLOB
2538              * (which is a list op. So pretend it wasn't a listop */
2539             if (type == OP_GLOB)
2540                 type = OP_NULL;
2541         }
2542         family = PL_opargs[type] & OA_CLASS_MASK;
2543
2544         has_last = (   family == OA_BINOP
2545                     || family == OA_LISTOP
2546                     || family == OA_PMOP
2547                     || family == OA_LOOP
2548                    );
2549         assert(  has_last /* has op_first and op_last, or ...
2550               ... has (or may have) op_first: */
2551               || family == OA_UNOP
2552               || family == OA_UNOP_AUX
2553               || family == OA_LOGOP
2554               || family == OA_BASEOP_OR_UNOP
2555               || family == OA_FILESTATOP
2556               || family == OA_LOOPEXOP
2557               || family == OA_METHOP
2558               /* I don't know why SASSIGN is tagged as OA_BASEOP - DAPM */
2559               || type == OP_SASSIGN
2560               || type == OP_CUSTOM
2561               || type == OP_NULL /* new_logop does this */
2562               );
2563
2564         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2565 #  ifdef PERL_OP_PARENT
2566             if (!OpHAS_SIBLING(kid)) {
2567                 if (has_last)
2568                     assert(kid == cLISTOPo->op_last);
2569                 assert(kid->op_sibparent == o);
2570             }
2571 #  else
2572             if (has_last && !OpHAS_SIBLING(kid))
2573                 assert(kid == cLISTOPo->op_last);
2574 #  endif
2575         }
2576 #endif
2577
2578         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
2579             finalize_op(kid);
2580     }
2581 }
2582
2583 /*
2584 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
2585
2586 Propagate lvalue ("modifiable") context to an op and its children.
2587 C<type> represents the context type, roughly based on the type of op that
2588 would do the modifying, although C<local()> is represented by C<OP_NULL>,
2589 because it has no op type of its own (it is signalled by a flag on
2590 the lvalue op).
2591
2592 This function detects things that can't be modified, such as C<$x+1>, and
2593 generates errors for them.  For example, C<$x+1 = 2> would cause it to be
2594 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
2595
2596 It also flags things that need to behave specially in an lvalue context,
2597 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
2598
2599 =cut
2600 */
2601
2602 static void
2603 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
2604 {
2605     CV *cv = PL_compcv;
2606     PadnameLVALUE_on(pn);
2607     while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
2608         cv = CvOUTSIDE(cv);
2609         assert(cv);
2610         assert(CvPADLIST(cv));
2611         pn =
2612            PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
2613         assert(PadnameLEN(pn));
2614         PadnameLVALUE_on(pn);
2615     }
2616 }
2617
2618 static bool
2619 S_vivifies(const OPCODE type)
2620 {
2621     switch(type) {
2622     case OP_RV2AV:     case   OP_ASLICE:
2623     case OP_RV2HV:     case OP_KVASLICE:
2624     case OP_RV2SV:     case   OP_HSLICE:
2625     case OP_AELEMFAST: case OP_KVHSLICE:
2626     case OP_HELEM:
2627     case OP_AELEM:
2628         return 1;
2629     }
2630     return 0;
2631 }
2632
2633 static void
2634 S_lvref(pTHX_ OP *o, I32 type)
2635 {
2636     dVAR;
2637     OP *kid;
2638     switch (o->op_type) {
2639     case OP_COND_EXPR:
2640         for (kid = OpSIBLING(cUNOPo->op_first); kid;
2641              kid = OpSIBLING(kid))
2642             S_lvref(aTHX_ kid, type);
2643         /* FALLTHROUGH */
2644     case OP_PUSHMARK:
2645         return;
2646     case OP_RV2AV:
2647         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2648         o->op_flags |= OPf_STACKED;
2649         if (o->op_flags & OPf_PARENS) {
2650             if (o->op_private & OPpLVAL_INTRO) {
2651                  yyerror(Perl_form(aTHX_ "Can't modify reference to "
2652                       "localized parenthesized array in list assignment"));
2653                 return;
2654             }
2655           slurpy:
2656             OpTYPE_set(o, OP_LVAVREF);
2657             o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
2658             o->op_flags |= OPf_MOD|OPf_REF;
2659             return;
2660         }
2661         o->op_private |= OPpLVREF_AV;
2662         goto checkgv;
2663     case OP_RV2CV:
2664         kid = cUNOPo->op_first;
2665         if (kid->op_type == OP_NULL)
2666             kid = cUNOPx(OpSIBLING(kUNOP->op_first))
2667                 ->op_first;
2668         o->op_private = OPpLVREF_CV;
2669         if (kid->op_type == OP_GV)
2670             o->op_flags |= OPf_STACKED;
2671         else if (kid->op_type == OP_PADCV) {
2672             o->op_targ = kid->op_targ;
2673             kid->op_targ = 0;
2674             op_free(cUNOPo->op_first);
2675             cUNOPo->op_first = NULL;
2676             o->op_flags &=~ OPf_KIDS;
2677         }
2678         else goto badref;
2679         break;
2680     case OP_RV2HV:
2681         if (o->op_flags & OPf_PARENS) {
2682           parenhash:
2683             yyerror(Perl_form(aTHX_ "Can't modify reference to "
2684                                  "parenthesized hash in list assignment"));
2685                 return;
2686         }
2687         o->op_private |= OPpLVREF_HV;
2688         /* FALLTHROUGH */
2689     case OP_RV2SV:
2690       checkgv:
2691         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2692         o->op_flags |= OPf_STACKED;
2693         break;
2694     case OP_PADHV:
2695         if (o->op_flags & OPf_PARENS) goto parenhash;
2696         o->op_private |= OPpLVREF_HV;
2697         /* FALLTHROUGH */
2698     case OP_PADSV:
2699         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2700         break;
2701     case OP_PADAV:
2702         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2703         if (o->op_flags & OPf_PARENS) goto slurpy;
2704         o->op_private |= OPpLVREF_AV;
2705         break;
2706     case OP_AELEM:
2707     case OP_HELEM:
2708         o->op_private |= OPpLVREF_ELEM;
2709         o->op_flags   |= OPf_STACKED;
2710         break;
2711     case OP_ASLICE:
2712     case OP_HSLICE:
2713         OpTYPE_set(o, OP_LVREFSLICE);
2714         o->op_private &= OPpLVAL_INTRO|OPpLVREF_ELEM;
2715         return;
2716     case OP_NULL:
2717         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
2718             goto badref;
2719         else if (!(o->op_flags & OPf_KIDS))
2720             return;
2721         if (o->op_targ != OP_LIST) {
2722             S_lvref(aTHX_ cBINOPo->op_first, type);
2723             return;
2724         }
2725         /* FALLTHROUGH */
2726     case OP_LIST:
2727         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
2728             assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
2729             S_lvref(aTHX_ kid, type);
2730         }
2731         return;
2732     case OP_STUB:
2733         if (o->op_flags & OPf_PARENS)
2734             return;
2735         /* FALLTHROUGH */
2736     default:
2737       badref:
2738         /* diag_listed_as: Can't modify reference to %s in %s assignment */
2739         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
2740                      o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
2741                       ? "do block"
2742                       : OP_DESC(o),
2743                      PL_op_desc[type]));
2744     }
2745     OpTYPE_set(o, OP_LVREF);
2746     o->op_private &=
2747         OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
2748     if (type == OP_ENTERLOOP)
2749         o->op_private |= OPpLVREF_ITER;
2750 }
2751
2752 OP *
2753 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
2754 {
2755     dVAR;
2756     OP *kid;
2757     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2758     int localize = -1;
2759
2760     if (!o || (PL_parser && PL_parser->error_count))
2761         return o;
2762
2763     if ((o->op_private & OPpTARGET_MY)
2764         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2765     {
2766         return o;
2767     }
2768
2769     assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2770
2771     if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2772
2773     switch (o->op_type) {
2774     case OP_UNDEF:
2775         PL_modcount++;
2776         return o;
2777     case OP_STUB:
2778         if ((o->op_flags & OPf_PARENS))
2779             break;
2780         goto nomod;
2781     case OP_ENTERSUB:
2782         if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
2783             !(o->op_flags & OPf_STACKED)) {
2784             OpTYPE_set(o, OP_RV2CV);            /* entersub => rv2cv */
2785             assert(cUNOPo->op_first->op_type == OP_NULL);
2786             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
2787             break;
2788         }
2789         else {                          /* lvalue subroutine call */
2790             o->op_private |= OPpLVAL_INTRO;
2791             PL_modcount = RETURN_UNLIMITED_NUMBER;
2792             if (type == OP_GREPSTART || type == OP_ENTERSUB
2793              || type == OP_REFGEN    || type == OP_LEAVESUBLV) {
2794                 /* Potential lvalue context: */
2795                 o->op_private |= OPpENTERSUB_INARGS;
2796                 break;
2797             }
2798             else {                      /* Compile-time error message: */
2799                 OP *kid = cUNOPo->op_first;
2800                 CV *cv;
2801                 GV *gv;
2802
2803                 if (kid->op_type != OP_PUSHMARK) {
2804                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2805                         Perl_croak(aTHX_
2806                                 "panic: unexpected lvalue entersub "
2807                                 "args: type/targ %ld:%"UVuf,
2808                                 (long)kid->op_type, (UV)kid->op_targ);
2809                     kid = kLISTOP->op_first;
2810                 }
2811                 while (OpHAS_SIBLING(kid))
2812                     kid = OpSIBLING(kid);
2813                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
2814                     break;      /* Postpone until runtime */
2815                 }
2816
2817                 kid = kUNOP->op_first;
2818                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2819                     kid = kUNOP->op_first;
2820                 if (kid->op_type == OP_NULL)
2821                     Perl_croak(aTHX_
2822                                "Unexpected constant lvalue entersub "
2823                                "entry via type/targ %ld:%"UVuf,
2824                                (long)kid->op_type, (UV)kid->op_targ);
2825                 if (kid->op_type != OP_GV) {
2826                     break;
2827                 }
2828
2829                 gv = kGVOP_gv;
2830                 cv = isGV(gv)
2831                     ? GvCV(gv)
2832                     : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
2833                         ? MUTABLE_CV(SvRV(gv))
2834                         : NULL;
2835                 if (!cv)
2836                     break;
2837                 if (CvLVALUE(cv))
2838                     break;
2839             }
2840         }
2841         /* FALLTHROUGH */
2842     default:
2843       nomod:
2844         if (flags & OP_LVALUE_NO_CROAK) return NULL;
2845         /* grep, foreach, subcalls, refgen */
2846         if (type == OP_GREPSTART || type == OP_ENTERSUB
2847          || type == OP_REFGEN    || type == OP_LEAVESUBLV)
2848             break;
2849         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2850                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
2851                       ? "do block"
2852                       : (o->op_type == OP_ENTERSUB
2853                         ? "non-lvalue subroutine call"
2854                         : OP_DESC(o))),
2855                      type ? PL_op_desc[type] : "local"));
2856         return o;
2857
2858     case OP_PREINC:
2859     case OP_PREDEC:
2860     case OP_POW:
2861     case OP_MULTIPLY:
2862     case OP_DIVIDE:
2863     case OP_MODULO:
2864     case OP_ADD:
2865     case OP_SUBTRACT:
2866     case OP_CONCAT:
2867     case OP_LEFT_SHIFT:
2868     case OP_RIGHT_SHIFT:
2869     case OP_BIT_AND:
2870     case OP_BIT_XOR:
2871     case OP_BIT_OR:
2872     case OP_I_MULTIPLY:
2873     case OP_I_DIVIDE:
2874     case OP_I_MODULO:
2875     case OP_I_ADD:
2876     case OP_I_SUBTRACT:
2877         if (!(o->op_flags & OPf_STACKED))
2878             goto nomod;
2879         PL_modcount++;
2880         break;
2881
2882     case OP_REPEAT:
2883         if (o->op_flags & OPf_STACKED) {
2884             PL_modcount++;
2885             break;
2886         }
2887         if (!(o->op_private & OPpREPEAT_DOLIST))
2888             goto nomod;
2889         else {
2890             const I32 mods = PL_modcount;
2891             modkids(cBINOPo->op_first, type);
2892             if (type != OP_AASSIGN)
2893                 goto nomod;
2894             kid = cBINOPo->op_last;
2895             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
2896                 const IV iv = SvIV(kSVOP_sv);
2897                 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
2898                     PL_modcount =
2899                         mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
2900             }
2901             else
2902                 PL_modcount = RETURN_UNLIMITED_NUMBER;
2903         }
2904         break;
2905
2906     case OP_COND_EXPR:
2907         localize = 1;
2908         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2909             op_lvalue(kid, type);
2910         break;
2911
2912     case OP_RV2AV:
2913     case OP_RV2HV:
2914         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
2915            PL_modcount = RETURN_UNLIMITED_NUMBER;
2916             return o;           /* Treat \(@foo) like ordinary list. */
2917         }
2918         /* FALLTHROUGH */
2919     case OP_RV2GV:
2920         if (scalar_mod_type(o, type))
2921             goto nomod;
2922         ref(cUNOPo->op_first, o->op_type);
2923         /* FALLTHROUGH */
2924     case OP_ASLICE:
2925     case OP_HSLICE:
2926         localize = 1;
2927         /* FALLTHROUGH */
2928     case OP_AASSIGN:
2929         /* Do not apply the lvsub flag for rv2[ah]v in scalar context.  */
2930         if (type == OP_LEAVESUBLV && (
2931                 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
2932              || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2933            ))
2934             o->op_private |= OPpMAYBE_LVSUB;
2935         /* FALLTHROUGH */
2936     case OP_NEXTSTATE:
2937     case OP_DBSTATE:
2938        PL_modcount = RETURN_UNLIMITED_NUMBER;
2939         break;
2940     case OP_KVHSLICE:
2941     case OP_KVASLICE:
2942         if (type == OP_LEAVESUBLV)
2943             o->op_private |= OPpMAYBE_LVSUB;
2944         goto nomod;
2945     case OP_AV2ARYLEN:
2946         PL_hints |= HINT_BLOCK_SCOPE;
2947         if (type == OP_LEAVESUBLV)
2948             o->op_private |= OPpMAYBE_LVSUB;
2949         PL_modcount++;
2950         break;
2951     case OP_RV2SV:
2952         ref(cUNOPo->op_first, o->op_type);
2953         localize = 1;
2954         /* FALLTHROUGH */
2955     case OP_GV:
2956         PL_hints |= HINT_BLOCK_SCOPE;
2957         /* FALLTHROUGH */
2958     case OP_SASSIGN:
2959     case OP_ANDASSIGN:
2960     case OP_ORASSIGN:
2961     case OP_DORASSIGN:
2962         PL_modcount++;
2963         break;
2964
2965     case OP_AELEMFAST:
2966     case OP_AELEMFAST_LEX:
2967         localize = -1;
2968         PL_modcount++;
2969         break;
2970
2971     case OP_PADAV:
2972     case OP_PADHV:
2973        PL_modcount = RETURN_UNLIMITED_NUMBER;
2974         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
2975             return o;           /* Treat \(@foo) like ordinary list. */
2976         if (scalar_mod_type(o, type))
2977             goto nomod;
2978         if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2979           && type == OP_LEAVESUBLV)
2980             o->op_private |= OPpMAYBE_LVSUB;
2981         /* FALLTHROUGH */
2982     case OP_PADSV:
2983         PL_modcount++;
2984         if (!type) /* local() */
2985             Perl_croak(aTHX_ "Can't localize lexical variable %"PNf,
2986                               PNfARG(PAD_COMPNAME(o->op_targ)));
2987         if (!(o->op_private & OPpLVAL_INTRO)
2988          || (  type != OP_SASSIGN && type != OP_AASSIGN
2989             && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ))  ))
2990             S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
2991         break;
2992
2993     case OP_PUSHMARK:
2994         localize = 0;
2995         break;
2996
2997     case OP_KEYS:
2998         if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
2999             goto nomod;
3000         goto lvalue_func;
3001     case OP_SUBSTR:
3002         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
3003             goto nomod;
3004         /* FALLTHROUGH */
3005     case OP_POS:
3006     case OP_VEC:
3007       lvalue_func:
3008         if (type == OP_LEAVESUBLV)
3009             o->op_private |= OPpMAYBE_LVSUB;
3010         if (o->op_flags & OPf_KIDS)
3011             op_lvalue(OpSIBLING(cBINOPo->op_first), type);
3012         break;
3013
3014     case OP_AELEM:
3015     case OP_HELEM:
3016         ref(cBINOPo->op_first, o->op_type);
3017         if (type == OP_ENTERSUB &&
3018              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
3019             o->op_private |= OPpLVAL_DEFER;
3020         if (type == OP_LEAVESUBLV)
3021             o->op_private |= OPpMAYBE_LVSUB;
3022         localize = 1;
3023         PL_modcount++;
3024         break;
3025
3026     case OP_LEAVE:
3027     case OP_LEAVELOOP:
3028         o->op_private |= OPpLVALUE;
3029         /* FALLTHROUGH */
3030     case OP_SCOPE:
3031     case OP_ENTER:
3032     case OP_LINESEQ:
3033         localize = 0;
3034         if (o->op_flags & OPf_KIDS)
3035             op_lvalue(cLISTOPo->op_last, type);
3036         break;
3037
3038     case OP_NULL:
3039         localize = 0;
3040         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
3041             goto nomod;
3042         else if (!(o->op_flags & OPf_KIDS))
3043             break;
3044         if (o->op_targ != OP_LIST) {
3045             op_lvalue(cBINOPo->op_first, type);
3046             break;
3047         }
3048         /* FALLTHROUGH */
3049     case OP_LIST:
3050         localize = 0;
3051         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3052             /* elements might be in void context because the list is
3053                in scalar context or because they are attribute sub calls */
3054             if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
3055                 op_lvalue(kid, type);
3056         break;
3057
3058     case OP_COREARGS:
3059         return o;
3060
3061     case OP_AND:
3062     case OP_OR:
3063         if (type == OP_LEAVESUBLV
3064          || !S_vivifies(cLOGOPo->op_first->op_type))
3065             op_lvalue(cLOGOPo->op_first, type);
3066         if (type == OP_LEAVESUBLV
3067          || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
3068             op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
3069         goto nomod;
3070
3071     case OP_SREFGEN:
3072         if (type != OP_AASSIGN && type != OP_SASSIGN
3073          && type != OP_ENTERLOOP)
3074             goto nomod;
3075         /* Don’t bother applying lvalue context to the ex-list.  */
3076         kid = cUNOPx(cUNOPo->op_first)->op_first;
3077         assert (!OpHAS_SIBLING(kid));
3078         goto kid_2lvref;
3079     case OP_REFGEN:
3080         if (type != OP_AASSIGN) goto nomod;
3081         kid = cUNOPo->op_first;
3082       kid_2lvref:
3083         {
3084             const U8 ec = PL_parser ? PL_parser->error_count : 0;
3085             S_lvref(aTHX_ kid, type);
3086             if (!PL_parser || PL_parser->error_count == ec) {
3087                 if (!FEATURE_REFALIASING_IS_ENABLED)
3088                     Perl_croak(aTHX_
3089                        "Experimental aliasing via reference not enabled");
3090                 Perl_ck_warner_d(aTHX_
3091                                  packWARN(WARN_EXPERIMENTAL__REFALIASING),
3092                                 "Aliasing via reference is experimental");
3093             }
3094         }
3095         if (o->op_type == OP_REFGEN)
3096             op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
3097         op_null(o);
3098         return o;
3099
3100     case OP_SPLIT:
3101         kid = cLISTOPo->op_first;
3102         if (kid && kid->op_type == OP_PUSHRE &&
3103                 (  kid->op_targ
3104                 || o->op_flags & OPf_STACKED
3105 #ifdef USE_ITHREADS
3106                 || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
3107 #else
3108                 || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
3109 #endif
3110         )) {
3111             /* This is actually @array = split.  */
3112             PL_modcount = RETURN_UNLIMITED_NUMBER;
3113             break;
3114         }
3115         goto nomod;
3116
3117     case OP_SCALAR:
3118         op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
3119         goto nomod;
3120     }
3121
3122     /* [20011101.069] File test operators interpret OPf_REF to mean that
3123        their argument is a filehandle; thus \stat(".") should not set
3124        it. AMS 20011102 */
3125     if (type == OP_REFGEN &&
3126         PL_check[o->op_type] == Perl_ck_ftst)
3127         return o;
3128
3129     if (type != OP_LEAVESUBLV)
3130         o->op_flags |= OPf_MOD;
3131
3132     if (type == OP_AASSIGN || type == OP_SASSIGN)
3133         o->op_flags |= OPf_SPECIAL|OPf_REF;
3134     else if (!type) { /* local() */
3135         switch (localize) {
3136         case 1:
3137             o->op_private |= OPpLVAL_INTRO;
3138             o->op_flags &= ~OPf_SPECIAL;
3139             PL_hints |= HINT_BLOCK_SCOPE;
3140             break;
3141         case 0:
3142             break;
3143         case -1:
3144             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
3145                            "Useless localization of %s", OP_DESC(o));
3146         }
3147     }
3148     else if (type != OP_GREPSTART && type != OP_ENTERSUB
3149              && type != OP_LEAVESUBLV)
3150         o->op_flags |= OPf_REF;
3151     return o;
3152 }
3153
3154 STATIC bool
3155 S_scalar_mod_type(const OP *o, I32 type)
3156 {
3157     switch (type) {
3158     case OP_POS:
3159     case OP_SASSIGN:
3160         if (o && o->op_type == OP_RV2GV)
3161             return FALSE;
3162         /* FALLTHROUGH */
3163     case OP_PREINC:
3164     case OP_PREDEC:
3165     case OP_POSTINC:
3166     case OP_POSTDEC:
3167     case OP_I_PREINC:
3168     case OP_I_PREDEC:
3169     case OP_I_POSTINC:
3170     case OP_I_POSTDEC:
3171     case OP_POW:
3172     case OP_MULTIPLY:
3173     case OP_DIVIDE:
3174     case OP_MODULO:
3175     case OP_REPEAT:
3176     case OP_ADD:
3177     case OP_SUBTRACT:
3178     case OP_I_MULTIPLY:
3179     case OP_I_DIVIDE:
3180     case OP_I_MODULO:
3181     case OP_I_ADD:
3182     case OP_I_SUBTRACT:
3183     case OP_LEFT_SHIFT:
3184     case OP_RIGHT_SHIFT:
3185     case OP_BIT_AND:
3186     case OP_BIT_XOR:
3187     case OP_BIT_OR:
3188     case OP_CONCAT:
3189     case OP_SUBST:
3190     case OP_TRANS:
3191     case OP_TRANSR:
3192     case OP_READ:
3193     case OP_SYSREAD:
3194     case OP_RECV:
3195     case OP_ANDASSIGN:
3196     case OP_ORASSIGN:
3197     case OP_DORASSIGN:
3198         return TRUE;
3199     default:
3200         return FALSE;
3201     }
3202 }
3203
3204 STATIC bool
3205 S_is_handle_constructor(const OP *o, I32 numargs)
3206 {
3207     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
3208
3209     switch (o->op_type) {
3210     case OP_PIPE_OP:
3211     case OP_SOCKPAIR:
3212         if (numargs == 2)
3213             return TRUE;
3214         /* FALLTHROUGH */
3215     case OP_SYSOPEN:
3216     case OP_OPEN:
3217     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
3218     case OP_SOCKET:
3219     case OP_OPEN_DIR:
3220     case OP_ACCEPT:
3221         if (numargs == 1)
3222             return TRUE;
3223         /* FALLTHROUGH */
3224     default:
3225         return FALSE;
3226     }
3227 }
3228
3229 static OP *
3230 S_refkids(pTHX_ OP *o, I32 type)
3231 {
3232     if (o && o->op_flags & OPf_KIDS) {
3233         OP *kid;
3234         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3235             ref(kid, type);
3236     }
3237     return o;
3238 }
3239
3240 OP *
3241 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
3242 {
3243     dVAR;
3244     OP *kid;
3245
3246     PERL_ARGS_ASSERT_DOREF;
3247
3248     if (PL_parser && PL_parser->error_count)
3249         return o;
3250
3251     switch (o->op_type) {
3252     case OP_ENTERSUB:
3253         if ((type == OP_EXISTS || type == OP_DEFINED) &&
3254             !(o->op_flags & OPf_STACKED)) {
3255             OpTYPE_set(o, OP_RV2CV);             /* entersub => rv2cv */
3256             assert(cUNOPo->op_first->op_type == OP_NULL);
3257             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
3258             o->op_flags |= OPf_SPECIAL;
3259         }
3260         else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
3261             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3262                               : type == OP_RV2HV ? OPpDEREF_HV
3263                               : OPpDEREF_SV);
3264             o->op_flags |= OPf_MOD;
3265         }
3266
3267         break;
3268
3269     case OP_COND_EXPR:
3270         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
3271             doref(kid, type, set_op_ref);
3272         break;
3273     case OP_RV2SV:
3274         if (type == OP_DEFINED)
3275             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
3276         doref(cUNOPo->op_first, o->op_type, set_op_ref);
3277         /* FALLTHROUGH */
3278     case OP_PADSV:
3279         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3280             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3281                               : type == OP_RV2HV ? OPpDEREF_HV
3282                               : OPpDEREF_SV);
3283             o->op_flags |= OPf_MOD;
3284         }
3285         break;
3286
3287     case OP_RV2AV:
3288     case OP_RV2HV:
3289         if (set_op_ref)
3290             o->op_flags |= OPf_REF;
3291         /* FALLTHROUGH */
3292     case OP_RV2GV:
3293         if (type == OP_DEFINED)
3294             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
3295         doref(cUNOPo->op_first, o->op_type, set_op_ref);
3296         break;
3297
3298     case OP_PADAV:
3299     case OP_PADHV:
3300         if (set_op_ref)
3301             o->op_flags |= OPf_REF;
3302         break;
3303
3304     case OP_SCALAR:
3305     case OP_NULL:
3306         if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
3307             break;
3308         doref(cBINOPo->op_first, type, set_op_ref);
3309         break;
3310     case OP_AELEM:
3311     case OP_HELEM:
3312         doref(cBINOPo->op_first, o->op_type, set_op_ref);
3313         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3314             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3315                               : type == OP_RV2HV ? OPpDEREF_HV
3316                               : OPpDEREF_SV);
3317             o->op_flags |= OPf_MOD;
3318         }
3319         break;
3320
3321     case OP_SCOPE:
3322     case OP_LEAVE:
3323         set_op_ref = FALSE;
3324         /* FALLTHROUGH */
3325     case OP_ENTER:
3326     case OP_LIST:
3327         if (!(o->op_flags & OPf_KIDS))
3328             break;
3329         doref(cLISTOPo->op_last, type, set_op_ref);
3330         break;
3331     default:
3332         break;
3333     }
3334     return scalar(o);
3335
3336 }
3337
3338 STATIC OP *
3339 S_dup_attrlist(pTHX_ OP *o)
3340 {
3341     OP *rop;
3342
3343     PERL_ARGS_ASSERT_DUP_ATTRLIST;
3344
3345     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
3346      * where the first kid is OP_PUSHMARK and the remaining ones
3347      * are OP_CONST.  We need to push the OP_CONST values.
3348      */
3349     if (o->op_type == OP_CONST)
3350         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
3351     else {
3352         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
3353         rop = NULL;
3354         for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
3355             if (o->op_type == OP_CONST)
3356                 rop = op_append_elem(OP_LIST, rop,
3357                                   newSVOP(OP_CONST, o->op_flags,
3358                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
3359         }
3360     }
3361     return rop;
3362 }
3363
3364 STATIC void
3365 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
3366 {
3367     PERL_ARGS_ASSERT_APPLY_ATTRS;
3368     {
3369         SV * const stashsv = newSVhek(HvNAME_HEK(stash));
3370
3371         /* fake up C<use attributes $pkg,$rv,@attrs> */
3372
3373 #define ATTRSMODULE "attributes"
3374 #define ATTRSMODULE_PM "attributes.pm"
3375
3376         Perl_load_module(
3377           aTHX_ PERL_LOADMOD_IMPORT_OPS,
3378           newSVpvs(ATTRSMODULE),
3379           NULL,
3380           op_prepend_elem(OP_LIST,
3381                           newSVOP(OP_CONST, 0, stashsv),
3382                           op_prepend_elem(OP_LIST,
3383                                           newSVOP(OP_CONST, 0,
3384                                                   newRV(target)),
3385                                           dup_attrlist(attrs))));
3386     }
3387 }
3388
3389 STATIC void
3390 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
3391 {
3392     OP *pack, *imop, *arg;
3393     SV *meth, *stashsv, **svp;
3394
3395     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
3396
3397     if (!attrs)
3398         return;
3399
3400     assert(target->op_type == OP_PADSV ||
3401            target->op_type == OP_PADHV ||
3402            target->op_type == OP_PADAV);
3403
3404     /* Ensure that attributes.pm is loaded. */
3405     /* Don't force the C<use> if we don't need it. */
3406     svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
3407     if (svp && *svp != &PL_sv_undef)
3408         NOOP;   /* already in %INC */
3409     else
3410         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
3411                                newSVpvs(ATTRSMODULE), NULL);
3412
3413     /* Need package name for method call. */
3414     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
3415
3416     /* Build up the real arg-list. */
3417     stashsv = newSVhek(HvNAME_HEK(stash));
3418
3419     arg = newOP(OP_PADSV, 0);
3420     arg->op_targ = target->op_targ;
3421     arg = op_prepend_elem(OP_LIST,
3422                        newSVOP(OP_CONST, 0, stashsv),
3423                        op_prepend_elem(OP_LIST,
3424                                     newUNOP(OP_REFGEN, 0,
3425                                             arg),
3426                                     dup_attrlist(attrs)));
3427
3428     /* Fake up a method call to import */
3429     meth = newSVpvs_share("import");
3430     imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
3431                    op_append_elem(OP_LIST,
3432                                op_prepend_elem(OP_LIST, pack, arg),
3433                                newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
3434
3435     /* Combine the ops. */
3436     *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
3437 }
3438
3439 /*
3440 =notfor apidoc apply_attrs_string
3441
3442 Attempts to apply a list of attributes specified by the C<attrstr> and
3443 C<len> arguments to the subroutine identified by the C<cv> argument which
3444 is expected to be associated with the package identified by the C<stashpv>
3445 argument (see L<attributes>).  It gets this wrong, though, in that it
3446 does not correctly identify the boundaries of the individual attribute
3447 specifications within C<attrstr>.  This is not really intended for the
3448 public API, but has to be listed here for systems such as AIX which
3449 need an explicit export list for symbols.  (It's called from XS code
3450 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
3451 to respect attribute syntax properly would be welcome.
3452
3453 =cut
3454 */
3455
3456 void
3457 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
3458                         const char *attrstr, STRLEN len)
3459 {
3460     OP *attrs = NULL;
3461
3462     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
3463
3464     if (!len) {
3465         len = strlen(attrstr);
3466     }
3467
3468     while (len) {
3469         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
3470         if (len) {
3471             const char * const sstr = attrstr;
3472             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
3473             attrs = op_append_elem(OP_LIST, attrs,
3474                                 newSVOP(OP_CONST, 0,
3475                                         newSVpvn(sstr, attrstr-sstr)));
3476         }
3477     }
3478
3479     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3480                      newSVpvs(ATTRSMODULE),
3481                      NULL, op_prepend_elem(OP_LIST,
3482                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
3483                                   op_prepend_elem(OP_LIST,
3484                                                newSVOP(OP_CONST, 0,
3485                                                        newRV(MUTABLE_SV(cv))),
3486                                                attrs)));
3487 }
3488
3489 STATIC void
3490 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
3491 {
3492     OP *new_proto = NULL;
3493     STRLEN pvlen;
3494     char *pv;
3495     OP *o;
3496
3497     PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
3498
3499     if (!*attrs)
3500         return;
3501
3502     o = *attrs;
3503     if (o->op_type == OP_CONST) {
3504         pv = SvPV(cSVOPo_sv, pvlen);
3505         if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3506             SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3507             SV ** const tmpo = cSVOPx_svp(o);
3508             SvREFCNT_dec(cSVOPo_sv);
3509             *tmpo = tmpsv;
3510             new_proto = o;
3511             *attrs = NULL;
3512         }
3513     } else if (o->op_type == OP_LIST) {
3514         OP * lasto;
3515         assert(o->op_flags & OPf_KIDS);
3516         lasto = cLISTOPo->op_first;
3517         assert(lasto->op_type == OP_PUSHMARK);
3518         for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
3519             if (o->op_type == OP_CONST) {
3520                 pv = SvPV(cSVOPo_sv, pvlen);
3521                 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3522                     SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3523                     SV ** const tmpo = cSVOPx_svp(o);
3524                     SvREFCNT_dec(cSVOPo_sv);
3525                     *tmpo = tmpsv;
3526                     if (new_proto && ckWARN(WARN_MISC)) {
3527                         STRLEN new_len;
3528                         const char * newp = SvPV(cSVOPo_sv, new_len);
3529                         Perl_warner(aTHX_ packWARN(WARN_MISC),
3530                             "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub",
3531                             UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
3532                         op_free(new_proto);
3533                     }
3534                     else if (new_proto)
3535                         op_free(new_proto);
3536                     new_proto = o;
3537                     /* excise new_proto from the list */
3538                     op_sibling_splice(*attrs, lasto, 1, NULL);
3539                     o = lasto;
3540                     continue;
3541                 }
3542             }
3543             lasto = o;
3544         }
3545         /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
3546            would get pulled in with no real need */
3547         if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
3548             op_free(*attrs);
3549             *attrs = NULL;
3550         }
3551     }
3552
3553     if (new_proto) {
3554         SV *svname;
3555         if (isGV(name)) {
3556             svname = sv_newmortal();
3557             gv_efullname3(svname, name, NULL);
3558         }
3559         else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
3560             svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
3561         else
3562             svname = (SV *)name;
3563         if (ckWARN(WARN_ILLEGALPROTO))
3564             (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
3565         if (*proto && ckWARN(WARN_PROTOTYPE)) {
3566             STRLEN old_len, new_len;
3567             const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
3568             const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
3569
3570             Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3571                 "Prototype '%"UTF8f"' overridden by attribute 'prototype(%"UTF8f")'"
3572                 " in %"SVf,
3573                 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
3574                 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
3575                 SVfARG(svname));
3576         }
3577         if (*proto)
3578             op_free(*proto);
3579         *proto = new_proto;
3580     }
3581 }
3582
3583 static void
3584 S_cant_declare(pTHX_ OP *o)
3585 {
3586     if (o->op_type == OP_NULL
3587      && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
3588         o = cUNOPo->op_first;
3589     yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
3590                              o->op_type == OP_NULL
3591                                && o->op_flags & OPf_SPECIAL
3592                                  ? "do block"
3593                                  : OP_DESC(o),
3594                              PL_parser->in_my == KEY_our   ? "our"   :
3595                              PL_parser->in_my == KEY_state ? "state" :
3596                                                              "my"));
3597 }
3598
3599 STATIC OP *
3600 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
3601 {
3602     I32 type;
3603     const bool stately = PL_parser && PL_parser->in_my == KEY_state;
3604
3605     PERL_ARGS_ASSERT_MY_KID;
3606
3607     if (!o || (PL_parser && PL_parser->error_count))
3608         return o;
3609
3610     type = o->op_type;
3611
3612     if (type == OP_LIST) {
3613         OP *kid;
3614         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3615             my_kid(kid, attrs, imopsp);
3616         return o;
3617     } else if (type == OP_UNDEF || type == OP_STUB) {
3618         return o;
3619     } else if (type == OP_RV2SV ||      /* "our" declaration */
3620                type == OP_RV2AV ||
3621                type == OP_RV2HV) { /* XXX does this let anything illegal in? */
3622         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
3623             S_cant_declare(aTHX_ o);
3624         } else if (attrs) {
3625             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
3626             assert(PL_parser);
3627             PL_parser->in_my = FALSE;
3628             PL_parser->in_my_stash = NULL;
3629             apply_attrs(GvSTASH(gv),
3630                         (type == OP_RV2SV ? GvSV(gv) :
3631                          type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
3632                          type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
3633                         attrs);
3634         }
3635         o->op_private |= OPpOUR_INTRO;
3636         return o;
3637     }
3638     else if (type != OP_PADSV &&
3639              type != OP_PADAV &&
3640              type != OP_PADHV &&
3641              type != OP_PUSHMARK)
3642     {
3643         S_cant_declare(aTHX_ o);
3644         return o;
3645     }
3646     else if (attrs && type != OP_PUSHMARK) {
3647         HV *stash;
3648
3649         assert(PL_parser);
3650         PL_parser->in_my = FALSE;
3651         PL_parser->in_my_stash = NULL;
3652
3653         /* check for C<my Dog $spot> when deciding package */
3654         stash = PAD_COMPNAME_TYPE(o->op_targ);
3655         if (!stash)
3656             stash = PL_curstash;
3657         apply_attrs_my(stash, o, attrs, imopsp);
3658     }
3659     o->op_flags |= OPf_MOD;
3660     o->op_private |= OPpLVAL_INTRO;
3661     if (stately)
3662         o->op_private |= OPpPAD_STATE;
3663     return o;
3664 }
3665
3666 OP *
3667 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
3668 {
3669     OP *rops;
3670     int maybe_scalar = 0;
3671
3672     PERL_ARGS_ASSERT_MY_ATTRS;
3673
3674 /* [perl #17376]: this appears to be premature, and results in code such as
3675    C< our(%x); > executing in list mode rather than void mode */
3676 #if 0
3677     if (o->op_flags & OPf_PARENS)
3678         list(o);
3679     else
3680         maybe_scalar = 1;
3681 #else
3682     maybe_scalar = 1;
3683 #endif
3684     if (attrs)
3685         SAVEFREEOP(attrs);
3686     rops = NULL;
3687     o = my_kid(o, attrs, &rops);
3688     if (rops) {
3689         if (maybe_scalar && o->op_type == OP_PADSV) {
3690             o = scalar(op_append_list(OP_LIST, rops, o));
3691             o->op_private |= OPpLVAL_INTRO;
3692         }
3693         else {
3694             /* The listop in rops might have a pushmark at the beginning,
3695                which will mess up list assignment. */
3696             LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
3697             if (rops->op_type == OP_LIST &&
3698                 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
3699             {
3700                 OP * const pushmark = lrops->op_first;
3701                 /* excise pushmark */
3702                 op_sibling_splice(rops, NULL, 1, NULL);
3703                 op_free(pushmark);
3704             }
3705             o = op_append_list(OP_LIST, o, rops);
3706         }
3707     }
3708     PL_parser->in_my = FALSE;
3709     PL_parser->in_my_stash = NULL;
3710     return o;
3711 }
3712
3713 OP *
3714 Perl_sawparens(pTHX_ OP *o)
3715 {
3716     PERL_UNUSED_CONTEXT;
3717     if (o)
3718         o->op_flags |= OPf_PARENS;
3719     return o;
3720 }
3721
3722 OP *
3723 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
3724 {
3725     OP *o;
3726     bool ismatchop = 0;
3727     const OPCODE ltype = left->op_type;
3728     const OPCODE rtype = right->op_type;
3729
3730     PERL_ARGS_ASSERT_BIND_MATCH;
3731
3732     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
3733           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
3734     {
3735       const char * const desc
3736           = PL_op_desc[(
3737                           rtype == OP_SUBST || rtype == OP_TRANS
3738                        || rtype == OP_TRANSR
3739                        )
3740                        ? (int)rtype : OP_MATCH];
3741       const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
3742       SV * const name =
3743         S_op_varname(aTHX_ left);
3744       if (name)
3745         Perl_warner(aTHX_ packWARN(WARN_MISC),
3746              "Applying %s to %"SVf" will act on scalar(%"SVf")",
3747              desc, SVfARG(name), SVfARG(name));
3748       else {
3749         const char * const sample = (isary
3750              ? "@array" : "%hash");
3751         Perl_warner(aTHX_ packWARN(WARN_MISC),
3752              "Applying %s to %s will act on scalar(%s)",
3753              desc, sample, sample);
3754       }
3755     }
3756
3757     if (rtype == OP_CONST &&
3758         cSVOPx(right)->op_private & OPpCONST_BARE &&
3759         cSVOPx(right)->op_private & OPpCONST_STRICT)
3760     {
3761         no_bareword_allowed(right);
3762     }
3763
3764     /* !~ doesn't make sense with /r, so error on it for now */
3765     if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
3766         type == OP_NOT)
3767         /* diag_listed_as: Using !~ with %s doesn't make sense */
3768         yyerror("Using !~ with s///r doesn't make sense");
3769     if (rtype == OP_TRANSR && type == OP_NOT)
3770         /* diag_listed_as: Using !~ with %s doesn't make sense */
3771         yyerror("Using !~ with tr///r doesn't make sense");
3772
3773     ismatchop = (rtype == OP_MATCH ||
3774                  rtype == OP_SUBST ||
3775                  rtype == OP_TRANS || rtype == OP_TRANSR)
3776              && !(right->op_flags & OPf_SPECIAL);
3777     if (ismatchop && right->op_private & OPpTARGET_MY) {
3778         right->op_targ = 0;
3779         right->op_private &= ~OPpTARGET_MY;
3780     }
3781     if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
3782         if (left->op_type == OP_PADSV
3783          && !(left->op_private & OPpLVAL_INTRO))
3784         {
3785             right->op_targ = left->op_targ;
3786             op_free(left);
3787             o = right;
3788         }
3789         else {
3790             right->op_flags |= OPf_STACKED;
3791             if (rtype != OP_MATCH && rtype != OP_TRANSR &&
3792             ! (rtype == OP_TRANS &&
3793                right->op_private & OPpTRANS_IDENTICAL) &&
3794             ! (rtype == OP_SUBST &&
3795                (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3796                 left = op_lvalue(left, rtype);
3797             if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
3798                 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
3799             else
3800                 o = op_prepend_elem(rtype, scalar(left), right);
3801         }
3802         if (type == OP_NOT)
3803             return newUNOP(OP_NOT, 0, scalar(o));
3804         return o;
3805     }
3806     else
3807         return bind_match(type, left,
3808                 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
3809 }
3810
3811 OP *
3812 Perl_invert(pTHX_ OP *o)
3813 {
3814     if (!o)
3815         return NULL;
3816     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
3817 }
3818
3819 /*
3820 =for apidoc Amx|OP *|op_scope|OP *o
3821
3822 Wraps up an op tree with some additional ops so that at runtime a dynamic
3823 scope will be created.  The original ops run in the new dynamic scope,
3824 and then, provided that they exit normally, the scope will be unwound.
3825 The additional ops used to create and unwind the dynamic scope will
3826 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
3827 instead if the ops are simple enough to not need the full dynamic scope
3828 structure.
3829
3830 =cut
3831 */
3832
3833 OP *
3834 Perl_op_scope(pTHX_ OP *o)
3835 {
3836     dVAR;
3837     if (o) {
3838         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
3839             o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
3840             OpTYPE_set(o, OP_LEAVE);
3841         }
3842         else if (o->op_type == OP_LINESEQ) {
3843             OP *kid;
3844             OpTYPE_set(o, OP_SCOPE);
3845             kid = ((LISTOP*)o)->op_first;
3846             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
3847                 op_null(kid);
3848
3849                 /* The following deals with things like 'do {1 for 1}' */
3850                 kid = OpSIBLING(kid);
3851                 if (kid &&
3852                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
3853                     op_null(kid);
3854             }
3855         }
3856         else
3857             o = newLISTOP(OP_SCOPE, 0, o, NULL);
3858     }
3859     return o;
3860 }
3861
3862 OP *
3863 Perl_op_unscope(pTHX_ OP *o)
3864 {
3865     if (o && o->op_type == OP_LINESEQ) {
3866         OP *kid = cLISTOPo->op_first;
3867         for(; kid; kid = OpSIBLING(kid))
3868             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
3869                 op_null(kid);
3870     }
3871     return o;
3872 }
3873
3874 /*
3875 =for apidoc Am|int|block_start|int full
3876
3877 Handles compile-time scope entry.
3878 Arranges for hints to be restored on block
3879 exit and also handles pad sequence numbers to make lexical variables scope
3880 right.  Returns a savestack index for use with C<block_end>.
3881
3882 =cut
3883 */
3884
3885 int
3886 Perl_block_start(pTHX_ int full)
3887 {
3888     const int retval = PL_savestack_ix;
3889
3890     PL_compiling.cop_seq = PL_cop_seqmax;
3891     COP_SEQMAX_INC;
3892     pad_block_start(full);
3893     SAVEHINTS();
3894     PL_hints &= ~HINT_BLOCK_SCOPE;
3895     SAVECOMPILEWARNINGS();
3896     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
3897     SAVEI32(PL_compiling.cop_seq);
3898     PL_compiling.cop_seq = 0;
3899
3900     CALL_BLOCK_HOOKS(bhk_start, full);
3901
3902     return retval;
3903 }
3904
3905 /*
3906 =for apidoc Am|OP *|block_end|I32 floor|OP *seq
3907
3908 Handles compile-time scope exit.  C<floor>
3909 is the savestack index returned by
3910 C<block_start>, and C<seq> is the body of the block.  Returns the block,
3911 possibly modified.
3912
3913 =cut
3914 */
3915
3916 OP*
3917 Perl_block_end(pTHX_ I32 floor, OP *seq)
3918 {
3919     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
3920     OP* retval = scalarseq(seq);
3921     OP *o;
3922
3923     /* XXX Is the null PL_parser check necessary here? */
3924     assert(PL_parser); /* Let’s find out under debugging builds.  */
3925     if (PL_parser && PL_parser->parsed_sub) {
3926         o = newSTATEOP(0, NULL, NULL);
3927         op_null(o);
3928         retval = op_append_elem(OP_LINESEQ, retval, o);
3929     }
3930
3931     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
3932
3933     LEAVE_SCOPE(floor);
3934     if (needblockscope)
3935         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
3936     o = pad_leavemy();
3937
3938     if (o) {
3939         /* pad_leavemy has created a sequence of introcv ops for all my
3940            subs declared in the block.  We have to replicate that list with
3941            clonecv ops, to deal with this situation:
3942
3943                sub {
3944                    my sub s1;
3945                    my sub s2;
3946                    sub s1 { state sub foo { \&s2 } }
3947                }->()
3948
3949            Originally, I was going to have introcv clone the CV and turn
3950            off the stale flag.  Since &s1 is declared before &s2, the
3951            introcv op for &s1 is executed (on sub entry) before the one for
3952            &s2.  But the &foo sub inside &s1 (which is cloned when &s1 is
3953            cloned, since it is a state sub) closes over &s2 and expects
3954            to see it in its outer CV’s pad.  If the introcv op clones &s1,
3955            then &s2 is still marked stale.  Since &s1 is not active, and
3956            &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
3957            ble will not stay shared’ warning.  Because it is the same stub
3958            that will be used when the introcv op for &s2 is executed, clos-
3959            ing over it is safe.  Hence, we have to turn off the stale flag
3960            on all lexical subs in the block before we clone any of them.
3961            Hence, having introcv clone the sub cannot work.  So we create a
3962            list of ops like this:
3963
3964                lineseq
3965                   |
3966                   +-- introcv
3967                   |
3968                   +-- introcv
3969                   |
3970                   +-- introcv
3971                   |
3972                   .
3973                   .
3974                   .
3975                   |
3976                   +-- clonecv
3977                   |
3978                   +-- clonecv
3979                   |
3980                   +-- clonecv
3981                   |
3982                   .
3983                   .
3984                   .
3985          */
3986         OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
3987         OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
3988         for (;; kid = OpSIBLING(kid)) {
3989             OP *newkid = newOP(OP_CLONECV, 0);
3990             newkid->op_targ = kid->op_targ;
3991             o = op_append_elem(OP_LINESEQ, o, newkid);
3992             if (kid == last) break;
3993         }
3994         retval = op_prepend_elem(OP_LINESEQ, o, retval);
3995     }
3996
3997     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
3998
3999     return retval;
4000 }
4001
4002 /*
4003 =head1 Compile-time scope hooks
4004
4005 =for apidoc Aox||blockhook_register
4006
4007 Register a set of hooks to be called when the Perl lexical scope changes
4008 at compile time.  See L<perlguts/"Compile-time scope hooks">.
4009
4010 =cut
4011 */
4012
4013 void
4014 Perl_blockhook_register(pTHX_ BHK *hk)
4015 {
4016     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
4017
4018     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
4019 }
4020
4021 void
4022 Perl_newPROG(pTHX_ OP *o)
4023 {
4024     PERL_ARGS_ASSERT_NEWPROG;
4025
4026     if (PL_in_eval) {
4027         PERL_CONTEXT *cx;
4028         I32 i;
4029         if (PL_eval_root)
4030                 return;
4031         PL_eval_root = newUNOP(OP_LEAVEEVAL,
4032                                ((PL_in_eval & EVAL_KEEPERR)
4033                                 ? OPf_SPECIAL : 0), o);
4034
4035         cx = &cxstack[cxstack_ix];
4036         assert(CxTYPE(cx) == CXt_EVAL);
4037
4038         if ((cx->blk_gimme & G_WANT) == G_VOID)
4039             scalarvoid(PL_eval_root);
4040         else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
4041             list(PL_eval_root);
4042         else
4043             scalar(PL_eval_root);
4044
4045         PL_eval_start = op_linklist(PL_eval_root);
4046         PL_eval_root->op_private |= OPpREFCOUNTED;
4047         OpREFCNT_set(PL_eval_root, 1);
4048         PL_eval_root->op_next = 0;
4049         i = PL_savestack_ix;
4050         SAVEFREEOP(o);
4051         ENTER;
4052         CALL_PEEP(PL_eval_start);
4053         finalize_optree(PL_eval_root);
4054         S_prune_chain_head(&PL_eval_start);
4055         LEAVE;
4056         PL_savestack_ix = i;
4057     }
4058     else {
4059         if (o->op_type == OP_STUB) {
4060             /* This block is entered if nothing is compiled for the main
4061                program. This will be the case for an genuinely empty main
4062                program, or one which only has BEGIN blocks etc, so already
4063                run and freed.
4064
4065                Historically (5.000) the guard above was !o. However, commit
4066                f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
4067                c71fccf11fde0068, changed perly.y so that newPROG() is now
4068                called with the output of block_end(), which returns a new
4069                OP_STUB for the case of an empty optree. ByteLoader (and
4070                maybe other things) also take this path, because they set up
4071                PL_main_start and PL_main_root directly, without generating an
4072                optree.
4073
4074                If the parsing the main program aborts (due to parse errors,
4075                or due to BEGIN or similar calling exit), then newPROG()
4076                isn't even called, and hence this code path and its cleanups
4077                are skipped. This shouldn't make a make a difference:
4078                * a non-zero return from perl_parse is a failure, and
4079                  perl_destruct() should be called immediately.
4080                * however, if exit(0) is called during the parse, then
4081                  perl_parse() returns 0, and perl_run() is called. As
4082                  PL_main_start will be NULL, perl_run() will return
4083                  promptly, and the exit code will remain 0.
4084             */
4085
4086             PL_comppad_name = 0;
4087             PL_compcv = 0;
4088             S_op_destroy(aTHX_ o);
4089             return;
4090         }
4091         PL_main_root = op_scope(sawparens(scalarvoid(o)));
4092         PL_curcop = &PL_compiling;
4093         PL_main_start = LINKLIST(PL_main_root);
4094         PL_main_root->op_private |= OPpREFCOUNTED;
4095         OpREFCNT_set(PL_main_root, 1);
4096         PL_main_root->op_next = 0;
4097         CALL_PEEP(PL_main_start);
4098         finalize_optree(PL_main_root);
4099         S_prune_chain_head(&PL_main_start);
4100         cv_forget_slab(PL_compcv);
4101         PL_compcv = 0;
4102
4103         /* Register with debugger */
4104         if (PERLDB_INTER) {
4105             CV * const cv = get_cvs("DB::postponed", 0);
4106             if (cv) {
4107                 dSP;
4108                 PUSHMARK(SP);
4109                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
4110                 PUTBACK;
4111                 call_sv(MUTABLE_SV(cv), G_DISCARD);
4112             }
4113         }
4114     }
4115 }
4116
4117 OP *
4118 Perl_localize(pTHX_ OP *o, I32 lex)
4119 {
4120     PERL_ARGS_ASSERT_LOCALIZE;
4121
4122     if (o->op_flags & OPf_PARENS)
4123 /* [perl #17376]: this appears to be premature, and results in code such as
4124    C< our(%x); > executing in list mode rather than void mode */
4125 #if 0
4126         list(o);
4127 #else
4128         NOOP;
4129 #endif
4130     else {
4131         if ( PL_parser->bufptr > PL_parser->oldbufptr
4132             && PL_parser->bufptr[-1] == ','
4133             && ckWARN(WARN_PARENTHESIS))
4134         {
4135             char *s = PL_parser->bufptr;
4136             bool sigil = FALSE;
4137
4138             /* some heuristics to detect a potential error */
4139             while (*s && (strchr(", \t\n", *s)))
4140                 s++;
4141
4142             while (1) {
4143                 if (*s && strchr("@$%*", *s) && *++s
4144                        && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
4145                     s++;
4146                     sigil = TRUE;
4147                     while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
4148                         s++;
4149                     while (*s && (strchr(", \t\n", *s)))
4150                         s++;
4151                 }
4152                 else
4153                     break;
4154             }
4155             if (sigil && (*s == ';' || *s == '=')) {
4156                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
4157                                 "Parentheses missing around \"%s\" list",
4158                                 lex
4159                                     ? (PL_parser->in_my == KEY_our
4160                                         ? "our"
4161                                         : PL_parser->in_my == KEY_state
4162                                             ? "state"
4163                                             : "my")
4164                                     : "local");
4165             }
4166         }
4167     }
4168     if (lex)
4169         o = my(o);
4170     else
4171         o = op_lvalue(o, OP_NULL);              /* a bit kludgey */
4172     PL_parser->in_my = FALSE;
4173     PL_parser->in_my_stash = NULL;
4174     return o;
4175 }
4176
4177 OP *
4178 Perl_jmaybe(pTHX_ OP *o)
4179 {
4180     PERL_ARGS_ASSERT_JMAYBE;
4181
4182     if (o->op_type == OP_LIST) {
4183         OP * const o2
4184             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
4185         o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
4186     }
4187     return o;
4188 }
4189
4190 PERL_STATIC_INLINE OP *
4191 S_op_std_init(pTHX_ OP *o)
4192 {
4193     I32 type = o->op_type;
4194
4195     PERL_ARGS_ASSERT_OP_STD_INIT;
4196
4197     if (PL_opargs[type] & OA_RETSCALAR)
4198         scalar(o);
4199     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
4200         o->op_targ = pad_alloc(type, SVs_PADTMP);
4201
4202     return o;
4203 }
4204
4205 PERL_STATIC_INLINE OP *
4206 S_op_integerize(pTHX_ OP *o)
4207 {
4208     I32 type = o->op_type;
4209
4210     PERL_ARGS_ASSERT_OP_INTEGERIZE;
4211
4212     /* integerize op. */
4213     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
4214     {
4215         dVAR;
4216         o->op_ppaddr = PL_ppaddr[++(o->op_type)];
4217     }
4218
4219     if (type == OP_NEGATE)
4220         /* XXX might want a ck_negate() for this */
4221         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
4222
4223     return o;
4224 }
4225
4226 static OP *
4227 S_fold_constants(pTHX_ OP *o)
4228 {
4229     dVAR;
4230     OP * VOL curop;
4231     OP *newop;
4232     VOL I32 type = o->op_type;
4233     bool is_stringify;
4234     SV * VOL sv = NULL;
4235     int ret = 0;
4236     I32 oldscope;
4237     OP *old_next;
4238     SV * const oldwarnhook = PL_warnhook;
4239     SV * const olddiehook  = PL_diehook;
4240     COP not_compiling;
4241     U8 oldwarn = PL_dowarn;
4242     dJMPENV;
4243
4244     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
4245
4246     if (!(PL_opargs[type] & OA_FOLDCONST))
4247         goto nope;
4248
4249     switch (type) {
4250     case OP_UCFIRST:
4251     case OP_LCFIRST:
4252     case OP_UC:
4253     case OP_LC:
4254     case OP_FC:
4255 #ifdef USE_LOCALE_CTYPE
4256         if (IN_LC_COMPILETIME(LC_CTYPE))
4257             goto nope;
4258 #endif
4259         break;
4260     case OP_SLT:
4261     case OP_SGT:
4262     case OP_SLE:
4263     case OP_SGE:
4264     case OP_SCMP:
4265 #ifdef USE_LOCALE_COLLATE
4266         if (IN_LC_COMPILETIME(LC_COLLATE))
4267             goto nope;
4268 #endif
4269         break;
4270     case OP_SPRINTF:
4271         /* XXX what about the numeric ops? */
4272 #ifdef USE_LOCALE_NUMERIC
4273         if (IN_LC_COMPILETIME(LC_NUMERIC))
4274             goto nope;
4275 #endif
4276         break;
4277     case OP_PACK:
4278         if (!OpHAS_SIBLING(cLISTOPo->op_first)
4279           || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
4280             goto nope;
4281         {
4282             SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
4283             if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
4284             {
4285                 const char *s = SvPVX_const(sv);
4286                 while (s < SvEND(sv)) {
4287                     if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
4288                     s++;
4289                 }
4290             }
4291         }
4292         break;
4293     case OP_REPEAT:
4294         if (o->op_private & OPpREPEAT_DOLIST) goto nope;
4295         break;
4296     case OP_SREFGEN:
4297         if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
4298          || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
4299             goto nope;
4300     }
4301
4302     if (PL_parser && PL_parser->error_count)
4303         goto nope;              /* Don't try to run w/ errors */
4304
4305     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4306         const OPCODE type = curop->op_type;
4307         if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
4308             type != OP_LIST &&
4309             type != OP_SCALAR &&
4310             type != OP_NULL &&
4311             type != OP_PUSHMARK)
4312         {
4313             goto nope;
4314         }
4315     }
4316
4317     curop = LINKLIST(o);
4318     old_next = o->op_next;
4319     o->op_next = 0;
4320     PL_op = curop;
4321
4322     oldscope = PL_scopestack_ix;
4323     create_eval_scope(G_FAKINGEVAL);
4324
4325     /* Verify that we don't need to save it:  */
4326     assert(PL_curcop == &PL_compiling);
4327     StructCopy(&PL_compiling, &not_compiling, COP);
4328     PL_curcop = &not_compiling;
4329     /* The above ensures that we run with all the correct hints of the
4330        currently compiling COP, but that IN_PERL_RUNTIME is true. */
4331     assert(IN_PERL_RUNTIME);
4332     PL_warnhook = PERL_WARNHOOK_FATAL;
4333     PL_diehook  = NULL;
4334     JMPENV_PUSH(ret);
4335
4336     /* Effective $^W=1.  */
4337     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
4338         PL_dowarn |= G_WARN_ON;
4339
4340     switch (ret) {
4341     case 0:
4342         CALLRUNOPS(aTHX);
4343         sv = *(PL_stack_sp--);
4344         if (o->op_targ && sv == PAD_SV(o->op_targ)) {   /* grab pad temp? */
4345             pad_swipe(o->op_targ,  FALSE);
4346         }
4347         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
4348             SvREFCNT_inc_simple_void(sv);
4349             SvTEMP_off(sv);
4350         }
4351         else { assert(SvIMMORTAL(sv)); }
4352         break;
4353     case 3:
4354         /* Something tried to die.  Abandon constant folding.  */
4355         /* Pretend the error never happened.  */
4356         CLEAR_ERRSV();
4357         o->op_next = old_next;
4358         break;
4359     default:
4360         JMPENV_POP;
4361         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
4362         PL_warnhook = oldwarnhook;
4363         PL_diehook  = olddiehook;
4364         /* XXX note that this croak may fail as we've already blown away
4365          * the stack - eg any nested evals */
4366         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
4367     }
4368     JMPENV_POP;
4369     PL_dowarn   = oldwarn;
4370     PL_warnhook = oldwarnhook;
4371     PL_diehook  = olddiehook;
4372     PL_curcop = &PL_compiling;
4373
4374     if (PL_scopestack_ix > oldscope)
4375         delete_eval_scope();
4376
4377     if (ret)
4378         goto nope;
4379
4380     /* OP_STRINGIFY and constant folding are used to implement qq.
4381        Here the constant folding is an implementation detail that we
4382        want to hide.  If the stringify op is itself already marked
4383        folded, however, then it is actually a folded join.  */
4384     is_stringify = type == OP_STRINGIFY && !o->op_folded;
4385     op_free(o);
4386     assert(sv);
4387     if (is_stringify)
4388         SvPADTMP_off(sv);
4389     else if (!SvIMMORTAL(sv)) {
4390         SvPADTMP_on(sv);
4391         SvREADONLY_on(sv);
4392     }
4393     newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
4394     if (!is_stringify) newop->op_folded = 1;
4395     return newop;
4396
4397  nope:
4398     return o;
4399 }
4400
4401 static OP *
4402 S_gen_constant_list(pTHX_ OP *o)
4403 {
4404     dVAR;
4405     OP *curop;
4406     const SSize_t oldtmps_floor = PL_tmps_floor;
4407     SV **svp;
4408     AV *av;
4409
4410     list(o);
4411     if (PL_parser && PL_parser->error_count)
4412         return o;               /* Don't attempt to run with errors */
4413
4414     curop = LINKLIST(o);
4415     o->op_next = 0;
4416     CALL_PEEP(curop);
4417     S_prune_chain_head(&curop);
4418     PL_op = curop;
4419     Perl_pp_pushmark(aTHX);
4420     CALLRUNOPS(aTHX);
4421     PL_op = curop;
4422     assert (!(curop->op_flags & OPf_SPECIAL));
4423     assert(curop->op_type == OP_RANGE);
4424     Perl_pp_anonlist(aTHX);
4425     PL_tmps_floor = oldtmps_floor;
4426
4427     OpTYPE_set(o, OP_RV2AV);
4428     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
4429     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
4430     o->op_opt = 0;              /* needs to be revisited in rpeep() */
4431     av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
4432
4433     /* replace subtree with an OP_CONST */
4434     curop = ((UNOP*)o)->op_first;
4435     op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
4436     op_free(curop);
4437
4438     if (AvFILLp(av) != -1)
4439         for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
4440         {
4441             SvPADTMP_on(*svp);
4442             SvREADONLY_on(*svp);
4443         }
4444     LINKLIST(o);
4445     return list(o);
4446 }
4447
4448 /*
4449 =head1 Optree Manipulation Functions
4450 */
4451
4452 /* List constructors */
4453
4454 /*
4455 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
4456
4457 Append an item to the list of ops contained directly within a list-type
4458 op, returning the lengthened list.  C<first> is the list-type op,
4459 and C<last> is the op to append to the list.  C<optype> specifies the
4460 intended opcode for the list.  If C<first> is not already a list of the
4461 right type, it will be upgraded into one.  If either C<first> or C<last>
4462 is null, the other is returned unchanged.
4463
4464 =cut
4465 */
4466
4467 OP *
4468 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
4469 {
4470     if (!first)
4471         return last;
4472
4473     if (!last)
4474         return first;
4475
4476     if (first->op_type != (unsigned)type
4477         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
4478     {
4479         return newLISTOP(type, 0, first, last);
4480     }
4481
4482     op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
4483     first->op_flags |= OPf_KIDS;
4484     return first;
4485 }
4486
4487 /*
4488 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
4489
4490 Concatenate the lists of ops contained directly within two list-type ops,
4491 returning the combined list.  C<first> and C<last> are the list-type ops
4492 to concatenate.  C<optype> specifies the intended opcode for the list.
4493 If either C<first> or C<last> is not already a list of the right type,
4494 it will be upgraded into one.  If either C<first> or C<last> is null,
4495 the other is returned unchanged.
4496
4497 =cut
4498 */
4499
4500 OP *
4501 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
4502 {
4503     if (!first)
4504         return last;
4505
4506     if (!last)
4507         return first;
4508
4509     if (first->op_type != (unsigned)type)
4510         return op_prepend_elem(type, first, last);
4511
4512     if (last->op_type != (unsigned)type)
4513         return op_append_elem(type, first, last);
4514
4515     OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
4516     ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
4517     OpLASTSIB_set(((LISTOP*)first)->op_last, first);
4518     first->op_flags |= (last->op_flags & OPf_KIDS);
4519
4520     S_op_destroy(aTHX_ last);
4521
4522     return first;
4523 }
4524
4525 /*
4526 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
4527
4528 Prepend an item to the list of ops contained directly within a list-type
4529 op, returning the lengthened list.  C<first> is the op to prepend to the
4530 list, and C<last> is the list-type op.  C<optype> specifies the intended
4531 opcode for the list.  If C<last> is not already a list of the right type,
4532 it will be upgraded into one.  If either C<first> or C<last> is null,
4533 the other is returned unchanged.
4534
4535 =cut
4536 */
4537
4538 OP *
4539 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
4540 {
4541     if (!first)
4542         return last;
4543
4544     if (!last)
4545         return first;
4546
4547     if (last->op_type == (unsigned)type) {
4548         if (type == OP_LIST) {  /* already a PUSHMARK there */
4549             /* insert 'first' after pushmark */
4550             op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
4551             if (!(first->op_flags & OPf_PARENS))
4552                 last->op_flags &= ~OPf_PARENS;
4553         }
4554         else
4555             op_sibling_splice(last, NULL, 0, first);
4556         last->op_flags |= OPf_KIDS;
4557         return last;
4558     }
4559
4560     return newLISTOP(type, 0, first, last);
4561 }
4562
4563 /*
4564 =for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
4565
4566 Converts C<o> into a list op if it is not one already, and then converts it
4567 into the specified C<type>, calling its check function, allocating a target if
4568 it needs one, and folding constants.
4569
4570 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
4571 C<op_prepend_elem> and C<op_append_elem>.  Then finally it is passed to
4572 C<op_convert_list> to make it the right type.
4573
4574 =cut
4575 */
4576
4577 OP *
4578 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
4579 {
4580     dVAR;
4581     if (type < 0) type = -type, flags |= OPf_SPECIAL;
4582     if (!o || o->op_type != OP_LIST)
4583         o = force_list(o, 0);
4584     else
4585     {
4586         o->op_flags &= ~OPf_WANT;
4587         o->op_private &= ~OPpLVAL_INTRO;
4588     }
4589
4590     if (!(PL_opargs[type] & OA_MARK))
4591         op_null(cLISTOPo->op_first);
4592     else {
4593         OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
4594         if (kid2 && kid2->op_type == OP_COREARGS) {
4595             op_null(cLISTOPo->op_first);
4596             kid2->op_private |= OPpCOREARGS_PUSHMARK;
4597         }
4598     }
4599
4600     OpTYPE_set(o, type);
4601     o->op_flags |= flags;
4602     if (flags & OPf_FOLDED)
4603         o->op_folded = 1;
4604
4605     o = CHECKOP(type, o);
4606     if (o->op_type != (unsigned)type)
4607         return o;
4608
4609     return fold_constants(op_integerize(op_std_init(o)));
4610 }
4611
4612 /* Constructors */
4613
4614
4615 /*
4616 =head1 Optree construction
4617
4618 =for apidoc Am|OP *|newNULLLIST
4619
4620 Constructs, checks, and returns a new C<stub> op, which represents an
4621 empty list expression.
4622
4623 =cut
4624 */
4625
4626 OP *
4627 Perl_newNULLLIST(pTHX)
4628 {
4629     return newOP(OP_STUB, 0);
4630 }
4631
4632 /* promote o and any siblings to be a list if its not already; i.e.
4633  *
4634  *  o - A - B
4635  *
4636  * becomes
4637  *
4638  *  list
4639  *    |
4640  *  pushmark - o - A - B
4641  *
4642  * If nullit it true, the list op is nulled.
4643  */
4644
4645 static OP *
4646 S_force_list(pTHX_ OP *o, bool nullit)
4647 {
4648     if (!o || o->op_type != OP_LIST) {
4649         OP *rest = NULL;
4650         if (o) {
4651             /* manually detach any siblings then add them back later */
4652             rest = OpSIBLING(o);
4653             OpLASTSIB_set(o, NULL);
4654         }
4655         o = newLISTOP(OP_LIST, 0, o, NULL);
4656         if (rest)
4657             op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
4658     }
4659     if (nullit)
4660         op_null(o);
4661     return o;
4662 }
4663
4664 /*
4665 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
4666
4667 Constructs, checks, and returns an op of any list type.  C<type> is
4668 the opcode.  C<flags> gives the eight bits of C<op_flags>, except that
4669 C<OPf_KIDS> will be set automatically if required.  C<first> and C<last>
4670 supply up to two ops to be direct children of the list op; they are
4671 consumed by this function and become part of the constructed op tree.
4672
4673 For most list operators, the check function expects all the kid ops to be
4674 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
4675 appropriate.  What you want to do in that case is create an op of type
4676 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
4677 See L</op_convert_list> for more information.
4678
4679
4680 =cut
4681 */
4682
4683 OP *
4684 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4685 {
4686     dVAR;
4687     LISTOP *listop;
4688
4689     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
4690         || type == OP_CUSTOM);
4691
4692     NewOp(1101, listop, 1, LISTOP);
4693
4694     OpTYPE_set(listop, type);
4695     if (first || last)
4696         flags |= OPf_KIDS;
4697     listop->op_flags = (U8)flags;
4698
4699     if (!last && first)
4700         last = first;
4701     else if (!first && last)
4702         first = last;
4703     else if (first)
4704         OpMORESIB_set(first, last);
4705     listop->op_first = first;
4706     listop->op_last = last;
4707     if (type == OP_LIST) {
4708         OP* const pushop = newOP(OP_PUSHMARK, 0);
4709         OpMORESIB_set(pushop, first);
4710         listop->op_first = pushop;
4711         listop->op_flags |= OPf_KIDS;
4712         if (!last)
4713             listop->op_last = pushop;
4714     }
4715     if (listop->op_last)
4716         OpLASTSIB_set(listop->op_last, (OP*)listop);
4717
4718     return CHECKOP(type, listop);
4719 }
4720
4721 /*
4722 =for apidoc Am|OP *|newOP|I32 type|I32 flags
4723
4724 Constructs, checks, and returns an op of any base type (any type that
4725 has no extra fields).  C<type> is the opcode.  C<flags> gives the
4726 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
4727 of C<op_private>.
4728
4729 =cut
4730 */
4731
4732 OP *
4733 Perl_newOP(pTHX_ I32 type, I32 flags)
4734 {
4735     dVAR;
4736     OP *o;
4737
4738     if (type == -OP_ENTEREVAL) {
4739         type = OP_ENTEREVAL;
4740         flags |= OPpEVAL_BYTES<<8;
4741     }
4742
4743     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
4744         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4745         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4746         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4747
4748     NewOp(1101, o, 1, OP);
4749     OpTYPE_set(o, type);
4750     o->op_flags = (U8)flags;
4751
4752     o->op_next = o;
4753     o->op_private = (U8)(0 | (flags >> 8));
4754     if (PL_opargs[type] & OA_RETSCALAR)
4755         scalar(o);
4756     if (PL_opargs[type] & OA_TARGET)
4757         o->op_targ = pad_alloc(type, SVs_PADTMP);
4758     return CHECKOP(type, o);
4759 }
4760
4761 /*
4762 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
4763
4764 Constructs, checks, and returns an op of any unary type.  C<type> is
4765 the opcode.  C<flags> gives the eight bits of C<op_flags>, except that
4766 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
4767 bits, the eight bits of C<op_private>, except that the bit with value 1
4768 is automatically set.  C<first> supplies an optional op to be the direct
4769 child of the unary op; it is consumed by this function and become part
4770 of the constructed op tree.
4771
4772 =cut
4773 */
4774
4775 OP *
4776 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
4777 {
4778     dVAR;
4779     UNOP *unop;
4780
4781     if (type == -OP_ENTEREVAL) {
4782         type = OP_ENTEREVAL;
4783         flags |= OPpEVAL_BYTES<<8;
4784     }
4785
4786     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
4787         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4788         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4789         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
4790         || type == OP_SASSIGN
4791         || type == OP_ENTERTRY
4792         || type == OP_CUSTOM
4793         || type == OP_NULL );
4794
4795     if (!first)
4796         first = newOP(OP_STUB, 0);
4797     if (PL_opargs[type] & OA_MARK)
4798         first = force_list(first, 1);
4799
4800     NewOp(1101, unop, 1, UNOP);
4801     OpTYPE_set(unop, type);
4802     unop->op_first = first;
4803     unop->op_flags = (U8)(flags | OPf_KIDS);
4804     unop->op_private = (U8)(1 | (flags >> 8));
4805
4806     if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
4807         OpLASTSIB_set(first, (OP*)unop);
4808
4809     unop = (UNOP*) CHECKOP(type, unop);
4810     if (unop->op_next)
4811         return (OP*)unop;
4812
4813     return fold_constants(op_integerize(op_std_init((OP *) unop)));
4814 }
4815
4816 /*
4817 =for apidoc newUNOP_AUX
4818
4819 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
4820 initialised to C<aux>
4821
4822 =cut
4823 */
4824
4825 OP *
4826 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
4827 {
4828     dVAR;
4829     UNOP_AUX *unop;
4830
4831     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
4832         || type == OP_CUSTOM);
4833
4834     NewOp(1101, unop, 1, UNOP_AUX);
4835     unop->op_type = (OPCODE)type;
4836     unop->op_ppaddr = PL_ppaddr[type];
4837     unop->op_first = first;
4838     unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
4839     unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
4840     unop->op_aux = aux;
4841
4842     if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
4843         OpLASTSIB_set(first, (OP*)unop);
4844
4845     unop = (UNOP_AUX*) CHECKOP(type, unop);
4846
4847     return op_std_init((OP *) unop);
4848 }
4849
4850 /*
4851 =for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
4852
4853 Constructs, checks, and returns an op of method type with a method name
4854 evaluated at runtime.  C<type> is the opcode.  C<flags> gives the eight
4855 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
4856 and, shifted up eight bits, the eight bits of C<op_private>, except that
4857 the bit with value 1 is automatically set.  C<dynamic_meth> supplies an
4858 op which evaluates method name; it is consumed by this function and
4859 become part of the constructed op tree.
4860 Supported optypes: C<OP_METHOD>.
4861
4862 =cut
4863 */
4864
4865 static OP*
4866 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
4867     dVAR;
4868     METHOP *methop;
4869
4870     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
4871         || type == OP_CUSTOM);
4872
4873     NewOp(1101, methop, 1, METHOP);
4874     if (dynamic_meth) {
4875         if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
4876         methop->op_flags = (U8)(flags | OPf_KIDS);
4877         methop->op_u.op_first = dynamic_meth;
4878         methop->op_private = (U8)(1 | (flags >> 8));
4879
4880         if (!OpHAS_SIBLING(dynamic_meth))
4881             OpLASTSIB_set(dynamic_meth, (OP*)methop);
4882     }
4883     else {
4884         assert(const_meth);
4885         methop->op_flags = (U8)(flags & ~OPf_KIDS);
4886         methop->op_u.op_meth_sv = const_meth;
4887         methop->op_private = (U8)(0 | (flags >> 8));
4888         methop->op_next = (OP*)methop;
4889     }
4890
4891 #ifdef USE_ITHREADS
4892     methop->op_rclass_targ = 0;
4893 #else
4894     methop->op_rclass_sv = NULL;
4895 #endif
4896
4897     OpTYPE_set(methop, type);
4898     return CHECKOP(type, methop);
4899 }
4900
4901 OP *
4902 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
4903     PERL_ARGS_ASSERT_NEWMETHOP;
4904     return newMETHOP_internal(type, flags, dynamic_meth, NULL);
4905 }
4906
4907 /*
4908 =for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
4909
4910 Constructs, checks, and returns an op of method type with a constant
4911 method name.  C<type> is the opcode.  C<flags> gives the eight bits of
4912 C<op_flags>, and, shifted up eight bits, the eight bits of
4913 C<op_private>.  C<const_meth> supplies a constant method name;
4914 it must be a shared COW string.
4915 Supported optypes: C<OP_METHOD_NAMED>.
4916
4917 =cut
4918 */
4919
4920 OP *
4921 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
4922     PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
4923     return newMETHOP_internal(type, flags, NULL, const_meth);
4924 }
4925
4926 /*
4927 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
4928
4929 Constructs, checks, and returns an op of any binary type.  C<type>
4930 is the opcode.  C<flags> gives the eight bits of C<op_flags>, except
4931 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4932 the eight bits of C<op_private>, except that the bit with value 1 or
4933 2 is automatically set as required.  C<first> and C<last> supply up to
4934 two ops to be the direct children of the binary op; they are consumed
4935 by this function and become part of the constructed op tree.
4936
4937 =cut
4938 */
4939
4940 OP *
4941 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4942 {
4943     dVAR;
4944     BINOP *binop;
4945
4946     ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
4947         || type == OP_SASSIGN || type == OP_NULL || type == OP_CUSTOM);
4948
4949     NewOp(1101, binop, 1, BINOP);
4950
4951     if (!first)
4952         first = newOP(OP_NULL, 0);
4953
4954     OpTYPE_set(binop, type);
4955     binop->op_first = first;
4956     binop->op_flags = (U8)(flags | OPf_KIDS);
4957     if (!last) {
4958         last = first;
4959         binop->op_private = (U8)(1 | (flags >> 8));
4960     }
4961     else {
4962         binop->op_private = (U8)(2 | (flags >> 8));
4963         OpMORESIB_set(first, last);
4964     }
4965
4966     if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
4967         OpLASTSIB_set(last, (OP*)binop);
4968
4969     binop->op_last = OpSIBLING(binop->op_first);
4970     if (binop->op_last)
4971         OpLASTSIB_set(binop->op_last, (OP*)binop);
4972
4973     binop = (BINOP*)CHECKOP(type, binop);
4974     if (binop->op_next || binop->op_type != (OPCODE)type)
4975         return (OP*)binop;
4976
4977     return fold_constants(op_integerize(op_std_init((OP *)binop)));
4978 }
4979
4980 static int uvcompare(const void *a, const void *b)
4981     __attribute__nonnull__(1)
4982     __attribute__nonnull__(2)
4983     __attribute__pure__;
4984 static int uvcompare(const void *a, const void *b)
4985 {
4986     if (*((const UV *)a) < (*(const UV *)b))
4987         return -1;
4988     if (*((const UV *)a) > (*(const UV *)b))
4989         return 1;
4990     if (*((const UV *)a+1) < (*(const UV *)b+1))
4991         return -1;
4992     if (*((const UV *)a+1) > (*(const UV *)b+1))
4993         return 1;
4994     return 0;
4995 }
4996
4997 static OP *
4998 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
4999 {
5000     SV * const tstr = ((SVOP*)expr)->op_sv;
5001     SV * const rstr =
5002                               ((SVOP*)repl)->op_sv;
5003     STRLEN tlen;
5004     STRLEN rlen;
5005     const U8 *t = (U8*)SvPV_const(tstr, tlen);
5006     const U8 *r = (U8*)SvPV_const(rstr, rlen);
5007     I32 i;
5008     I32 j;
5009     I32 grows = 0;
5010     short *tbl;
5011
5012     const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
5013     const I32 squash     = o->op_private & OPpTRANS_SQUASH;
5014     I32 del              = o->op_private & OPpTRANS_DELETE;
5015     SV* swash;
5016
5017     PERL_ARGS_ASSERT_PMTRANS;
5018
5019     PL_hints |= HINT_BLOCK_SCOPE;
5020
5021     if (SvUTF8(tstr))
5022         o->op_private |= OPpTRANS_FROM_UTF;
5023
5024     if (SvUTF8(rstr))
5025         o->op_private |= OPpTRANS_TO_UTF;
5026
5027     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
5028         SV* const listsv = newSVpvs("# comment\n");
5029         SV* transv = NULL;
5030         const U8* tend = t + tlen;
5031         const U8* rend = r + rlen;
5032         STRLEN ulen;
5033         UV tfirst = 1;
5034         UV tlast = 0;
5035         IV tdiff;
5036         STRLEN tcount = 0;
5037         UV rfirst = 1;
5038         UV rlast = 0;
5039         IV rdiff;
5040         STRLEN rcount = 0;
5041         IV diff;
5042         I32 none = 0;
5043         U32 max = 0;
5044         I32 bits;
5045         I32 havefinal = 0;
5046         U32 final = 0;
5047         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
5048         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
5049         U8* tsave = NULL;
5050         U8* rsave = NULL;
5051         const U32 flags = UTF8_ALLOW_DEFAULT;
5052
5053         if (!from_utf) {
5054             STRLEN len = tlen;
5055             t = tsave = bytes_to_utf8(t, &len);
5056             tend = t + len;
5057         }
5058         if (!to_utf && rlen) {
5059             STRLEN len = rlen;
5060             r = rsave = bytes_to_utf8(r, &len);
5061             rend = r + len;
5062         }
5063
5064 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
5065  * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
5066  * odd.  */
5067
5068         if (complement) {
5069             U8 tmpbuf[UTF8_MAXBYTES+1];
5070             UV *cp;
5071             UV nextmin = 0;
5072             Newx(cp, 2*tlen, UV);
5073             i = 0;
5074             transv = newSVpvs("");
5075             while (t < tend) {
5076                 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
5077                 t += ulen;
5078                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
5079                     t++;
5080                     cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
5081                     t += ulen;
5082                 }
5083                 else {
5084                  cp[2*i+1] = cp[2*i];
5085                 }
5086                 i++;
5087             }
5088             qsort(cp, i, 2*sizeof(UV), uvcompare);
5089             for (j = 0; j < i; j++) {
5090                 UV  val = cp[2*j];
5091                 diff = val - nextmin;
5092                 if (diff > 0) {
5093                     t = uvchr_to_utf8(tmpbuf,nextmin);
5094                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5095                     if (diff > 1) {
5096                         U8  range_mark = ILLEGAL_UTF8_BYTE;
5097                         t = uvchr_to_utf8(tmpbuf, val - 1);
5098                         sv_catpvn(transv, (char *)&range_mark, 1);
5099                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5100                     }
5101                 }
5102                 val = cp[2*j+1];
5103                 if (val >= nextmin)
5104                     nextmin = val + 1;
5105             }
5106             t = uvchr_to_utf8(tmpbuf,nextmin);
5107             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5108             {
5109                 U8 range_mark = ILLEGAL_UTF8_BYTE;
5110                 sv_catpvn(transv, (char *)&range_mark, 1);
5111             }
5112             t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
5113             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5114             t = (const U8*)SvPVX_const(transv);
5115             tlen = SvCUR(transv);
5116             tend = t + tlen;
5117             Safefree(cp);
5118         }
5119         else if (!rlen && !del) {
5120             r = t; rlen = tlen; rend = tend;
5121         }
5122         if (!squash) {
5123                 if ((!rlen && !del) || t == r ||
5124                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
5125                 {
5126                     o->op_private |= OPpTRANS_IDENTICAL;
5127                 }
5128         }
5129
5130         while (t < tend || tfirst <= tlast) {
5131             /* see if we need more "t" chars */
5132             if (tfirst > tlast) {
5133                 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
5134                 t += ulen;
5135                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {      /* illegal utf8 val indicates range */
5136                     t++;
5137                     tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
5138                     t += ulen;
5139                 }
5140                 else
5141                     tlast = tfirst;
5142             }
5143
5144             /* now see if we need more "r" chars */
5145             if (rfirst > rlast) {
5146                 if (r < rend) {
5147                     rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
5148                     r += ulen;
5149                     if (r < rend && *r == ILLEGAL_UTF8_BYTE) {  /* illegal utf8 val indicates range */
5150                         r++;
5151                         rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
5152                         r += ulen;
5153                     }
5154                     else
5155                         rlast = rfirst;
5156                 }
5157                 else {
5158                     if (!havefinal++)
5159                         final = rlast;
5160                     rfirst = rlast = 0xffffffff;
5161                 }
5162             }
5163
5164             /* now see which range will peter out first, if either. */
5165             tdiff = tlast - tfirst;
5166             rdiff = rlast - rfirst;
5167             tcount += tdiff + 1;
5168             rcount += rdiff + 1;
5169
5170             if (tdiff <= rdiff)
5171                 diff = tdiff;
5172             else
5173                 diff = rdiff;
5174
5175             if (rfirst == 0xffffffff) {
5176                 diff = tdiff;   /* oops, pretend rdiff is infinite */
5177                 if (diff > 0)
5178                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
5179                                    (long)tfirst, (long)tlast);
5180                 else
5181                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
5182             }
5183             else {
5184                 if (diff > 0)
5185                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
5186                                    (long)tfirst, (long)(tfirst + diff),
5187                                    (long)rfirst);
5188                 else
5189                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
5190                                    (long)tfirst, (long)rfirst);
5191
5192                 if (rfirst + diff > max)
5193                     max = rfirst + diff;
5194                 if (!grows)
5195                     grows = (tfirst < rfirst &&
5196                              UVCHR_SKIP(tfirst) < UVCHR_SKIP(rfirst + diff));
5197                 rfirst += diff + 1;
5198             }
5199             tfirst += diff + 1;
5200         }
5201
5202         none = ++max;
5203         if (del)
5204             del = ++max;
5205
5206         if (max > 0xffff)
5207             bits = 32;
5208         else if (max > 0xff)
5209             bits = 16;
5210         else
5211             bits = 8;
5212
5213         swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
5214 #ifdef USE_ITHREADS
5215         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
5216         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
5217         PAD_SETSV(cPADOPo->op_padix, swash);
5218         SvPADTMP_on(swash);
5219         SvREADONLY_on(swash);
5220 #else
5221         cSVOPo->op_sv = swash;
5222 #endif
5223         SvREFCNT_dec(listsv);
5224         SvREFCNT_dec(transv);
5225
5226         if (!del && havefinal && rlen)
5227             (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
5228                            newSVuv((UV)final), 0);
5229
5230         Safefree(tsave);
5231         Safefree(rsave);
5232
5233         tlen = tcount;
5234         rlen = rcount;
5235         if (r < rend)
5236             rlen++;
5237         else if (rlast == 0xffffffff)
5238             rlen = 0;
5239
5240         goto warnins;
5241     }
5242
5243     tbl = (short*)PerlMemShared_calloc(
5244         (o->op_private & OPpTRANS_COMPLEMENT) &&
5245             !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
5246         sizeof(short));
5247     cPVOPo->op_pv = (char*)tbl;
5248     if (complement) {
5249         for (i = 0; i < (I32)tlen; i++)
5250             tbl[t[i]] = -1;
5251         for (i = 0, j = 0; i < 256; i++) {
5252             if (!tbl[i]) {
5253                 if (j >= (I32)rlen) {
5254                     if (del)
5255                         tbl[i] = -2;
5256                     else if (rlen)
5257                         tbl[i] = r[j-1];
5258                     else
5259                         tbl[i] = (short)i;
5260                 }
5261                 else {
5262                     if (i < 128 && r[j] >= 128)
5263                         grows = 1;
5264                     tbl[i] = r[j++];
5265                 }
5266             }
5267         }
5268         if (!del) {
5269             if (!rlen) {
5270                 j = rlen;
5271                 if (!squash)
5272                     o->op_private |= OPpTRANS_IDENTICAL;
5273             }
5274             else if (j >= (I32)rlen)
5275                 j = rlen - 1;
5276             else {
5277                 tbl =
5278                     (short *)
5279                     PerlMemShared_realloc(tbl,
5280                                           (0x101+rlen-j) * sizeof(short));
5281                 cPVOPo->op_pv = (char*)tbl;
5282             }
5283             tbl[0x100] = (short)(rlen - j);
5284             for (i=0; i < (I32)rlen - j; i++)
5285                 tbl[0x101+i] = r[j+i];
5286         }
5287     }
5288     else {
5289         if (!rlen && !del) {
5290             r = t; rlen = tlen;
5291             if (!squash)
5292                 o->op_private |= OPpTRANS_IDENTICAL;
5293         }
5294         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
5295             o->op_private |= OPpTRANS_IDENTICAL;
5296         }
5297         for (i = 0; i < 256; i++)
5298             tbl[i] = -1;
5299         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
5300             if (j >= (I32)rlen) {
5301                 if (del) {
5302                     if (tbl[t[i]] == -1)
5303                         tbl[t[i]] = -2;
5304                     continue;
5305                 }
5306                 --j;
5307             }
5308             if (tbl[t[i]] == -1) {
5309                 if (t[i] < 128 && r[j] >= 128)
5310                     grows = 1;
5311                 tbl[t[i]] = r[j];
5312             }
5313         }
5314     }
5315
5316   warnins:
5317     if(del && rlen == tlen) {
5318         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
5319     } else if(rlen > tlen && !complement) {
5320         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
5321     }
5322
5323     if (grows)
5324         o->op_private |= OPpTRANS_GROWS;
5325     op_free(expr);
5326     op_free(repl);
5327
5328     return o;
5329 }
5330
5331 /*
5332 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
5333
5334 Constructs, checks, and returns an op of any pattern matching type.
5335 C<type> is the opcode.  C<flags> gives the eight bits of C<op_flags>
5336 and, shifted up eight bits, the eight bits of C<op_private>.
5337
5338 =cut
5339 */
5340
5341 OP *
5342 Perl_newPMOP(pTHX_ I32 type, I32 flags)
5343 {
5344     dVAR;
5345     PMOP *pmop;
5346
5347     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
5348         || type == OP_CUSTOM);
5349
5350     NewOp(1101, pmop, 1, PMOP);
5351     OpTYPE_set(pmop, type);
5352     pmop->op_flags = (U8)flags;
5353     pmop->op_private = (U8)(0 | (flags >> 8));
5354     if (PL_opargs[type] & OA_RETSCALAR)
5355         scalar((OP *)pmop);
5356
5357     if (PL_hints & HINT_RE_TAINT)
5358         pmop->op_pmflags |= PMf_RETAINT;
5359 #ifdef USE_LOCALE_CTYPE
5360     if (IN_LC_COMPILETIME(LC_CTYPE)) {
5361         set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
5362     }
5363     else
5364 #endif
5365          if (IN_UNI_8_BIT) {
5366         set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
5367     }
5368     if (PL_hints & HINT_RE_FLAGS) {
5369         SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5370          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
5371         );
5372         if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
5373         reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5374          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
5375         );
5376         if (reflags && SvOK(reflags)) {
5377             set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
5378         }
5379     }
5380
5381
5382 #ifdef USE_ITHREADS
5383     assert(SvPOK(PL_regex_pad[0]));
5384     if (SvCUR(PL_regex_pad[0])) {
5385         /* Pop off the "packed" IV from the end.  */
5386         SV *const repointer_list = PL_regex_pad[0];
5387         const char *p = SvEND(repointer_list) - sizeof(IV);
5388         const IV offset = *((IV*)p);
5389
5390         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
5391
5392         SvEND_set(repointer_list, p);
5393
5394         pmop->op_pmoffset = offset;
5395         /* This slot should be free, so assert this:  */
5396         assert(PL_regex_pad[offset] == &PL_sv_undef);
5397     } else {
5398         SV * const repointer = &PL_sv_undef;
5399         av_push(PL_regex_padav, repointer);
5400         pmop->op_pmoffset = av_tindex(PL_regex_padav);
5401         PL_regex_pad = AvARRAY(PL_regex_padav);
5402     }
5403 #endif
5404
5405     return CHECKOP(type, pmop);
5406 }
5407
5408 static void
5409 S_set_haseval(pTHX)
5410 {
5411     PADOFFSET i = 1;
5412     PL_cv_has_eval = 1;
5413     /* Any pad names in scope are potentially lvalues.  */
5414     for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
5415         PADNAME *pn = PAD_COMPNAME_SV(i);
5416         if (!pn || !PadnameLEN(pn))
5417             continue;
5418         if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
5419             S_mark_padname_lvalue(aTHX_ pn);
5420     }
5421 }
5422
5423 /* Given some sort of match op o, and an expression expr containing a
5424  * pattern, either compile expr into a regex and attach it to o (if it's
5425  * constant), or convert expr into a runtime regcomp op sequence (if it's
5426  * not)
5427  *
5428  * isreg indicates that the pattern is part of a regex construct, eg
5429  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
5430  * split "pattern", which aren't. In the former case, expr will be a list
5431  * if the pattern contains more than one term (eg /a$b/).
5432  *
5433  * When the pattern has been compiled within a new anon CV (for
5434  * qr/(?{...})/ ), then floor indicates the savestack level just before
5435  * the new sub was created
5436  */
5437
5438 OP *
5439 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, bool isreg, I32 floor)
5440 {
5441     PMOP *pm;
5442     LOGOP *rcop;
5443     I32 repl_has_vars = 0;
5444     bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
5445     bool is_compiletime;
5446     bool has_code;
5447
5448     PERL_ARGS_ASSERT_PMRUNTIME;
5449
5450     if (is_trans) {
5451         return pmtrans(o, expr, repl);
5452     }
5453
5454     /* find whether we have any runtime or code elements;
5455      * at the same time, temporarily set the op_next of each DO block;
5456      * then when we LINKLIST, this will cause the DO blocks to be excluded
5457      * from the op_next chain (and from having LINKLIST recursively
5458      * applied to them). We fix up the DOs specially later */
5459
5460     is_compiletime = 1;
5461     has_code = 0;
5462     if (expr->op_type == OP_LIST) {
5463         OP *o;
5464         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
5465             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
5466                 has_code = 1;
5467                 assert(!o->op_next);
5468                 if (UNLIKELY(!OpHAS_SIBLING(o))) {
5469                     assert(PL_parser && PL_parser->error_count);
5470                     /* This can happen with qr/ (?{(^{})/.  Just fake up
5471                        the op we were expecting to see, to avoid crashing
5472                        elsewhere.  */
5473                     op_sibling_splice(expr, o, 0,
5474                                       newSVOP(OP_CONST, 0, &PL_sv_no));
5475                 }
5476                 o->op_next = OpSIBLING(o);
5477             }
5478             else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
5479                 is_compiletime = 0;
5480         }
5481     }
5482     else if (expr->op_type != OP_CONST)
5483         is_compiletime = 0;
5484
5485     LINKLIST(expr);
5486
5487     /* fix up DO blocks; treat each one as a separate little sub;
5488      * also, mark any arrays as LIST/REF */
5489
5490     if (expr->op_type == OP_LIST) {
5491         OP *o;
5492         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
5493
5494             if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
5495                 assert( !(o->op_flags  & OPf_WANT));
5496                 /* push the array rather than its contents. The regex
5497                  * engine will retrieve and join the elements later */
5498                 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
5499                 continue;
5500             }
5501
5502             if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
5503                 continue;
5504             o->op_next = NULL; /* undo temporary hack from above */
5505             scalar(o);
5506             LINKLIST(o);
5507             if (cLISTOPo->op_first->op_type == OP_LEAVE) {
5508                 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
5509                 /* skip ENTER */
5510                 assert(leaveop->op_first->op_type == OP_ENTER);
5511                 assert(OpHAS_SIBLING(leaveop->op_first));
5512                 o->op_next = OpSIBLING(leaveop->op_first);
5513                 /* skip leave */
5514                 assert(leaveop->op_flags & OPf_KIDS);
5515                 assert(leaveop->op_last->op_next == (OP*)leaveop);
5516                 leaveop->op_next = NULL; /* stop on last op */
5517                 op_null((OP*)leaveop);
5518             }
5519             else {
5520                 /* skip SCOPE */
5521                 OP *scope = cLISTOPo->op_first;
5522                 assert(scope->op_type == OP_SCOPE);
5523                 assert(scope->op_flags & OPf_KIDS);
5524                 scope->op_next = NULL; /* stop on last op */
5525                 op_null(scope);
5526             }
5527             /* have to peep the DOs individually as we've removed it from
5528              * the op_next chain */
5529             CALL_PEEP(o);
5530             S_prune_chain_head(&(o->op_next));
5531             if (is_compiletime)
5532                 /* runtime finalizes as part of finalizing whole tree */
5533                 finalize_optree(o);
5534         }
5535     }
5536     else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
5537         assert( !(expr->op_flags  & OPf_WANT));
5538         /* push the array rather than its contents. The regex
5539          * engine will retrieve and join the elements later */
5540         expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
5541     }
5542
5543     PL_hints |= HINT_BLOCK_SCOPE;
5544     pm = (PMOP*)o;
5545     assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
5546
5547     if (is_compiletime) {
5548         U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
5549         regexp_engine const *eng = current_re_engine();
5550
5551         if (o->op_flags & OPf_SPECIAL)
5552             rx_flags |= RXf_SPLIT;
5553
5554         if (!has_code || !eng->op_comp) {
5555             /* compile-time simple constant pattern */
5556
5557             if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
5558                 /* whoops! we guessed that a qr// had a code block, but we
5559                  * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
5560                  * that isn't required now. Note that we have to be pretty
5561                  * confident that nothing used that CV's pad while the
5562                  * regex was parsed, except maybe op targets for \Q etc.
5563                  * If there were any op targets, though, they should have
5564                  * been stolen by constant folding.
5565                  */
5566 #ifdef DEBUGGING
5567                 SSize_t i = 0;
5568                 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
5569                 while (++i <= AvFILLp(PL_comppad)) {
5570                     assert(!PL_curpad[i]);
5571                 }
5572 #endif
5573                 /* But we know that one op is using this CV's slab. */
5574                 cv_forget_slab(PL_compcv);
5575                 LEAVE_SCOPE(floor);
5576                 pm->op_pmflags &= ~PMf_HAS_CV;
5577             }
5578
5579             PM_SETRE(pm,
5580                 eng->op_comp
5581                     ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5582                                         rx_flags, pm->op_pmflags)
5583                     : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5584                                         rx_flags, pm->op_pmflags)
5585             );
5586             op_free(expr);
5587         }
5588         else {
5589             /* compile-time pattern that includes literal code blocks */
5590             REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5591                         rx_flags,
5592                         (pm->op_pmflags |
5593                             ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
5594                     );
5595             PM_SETRE(pm, re);
5596             if (pm->op_pmflags & PMf_HAS_CV) {
5597                 CV *cv;
5598                 /* this QR op (and the anon sub we embed it in) is never
5599                  * actually executed. It's just a placeholder where we can
5600                  * squirrel away expr in op_code_list without the peephole
5601                  * optimiser etc processing it for a second time */
5602                 OP *qr = newPMOP(OP_QR, 0);
5603                 ((PMOP*)qr)->op_code_list = expr;
5604
5605                 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
5606                 SvREFCNT_inc_simple_void(PL_compcv);
5607                 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
5608                 ReANY(re)->qr_anoncv = cv;
5609
5610                 /* attach the anon CV to the pad so that
5611                  * pad_fixup_inner_anons() can find it */
5612                 (void)pad_add_anon(cv, o->op_type);
5613                 SvREFCNT_inc_simple_void(cv);
5614             }
5615             else {
5616                 pm->op_code_list = expr;
5617             }
5618         }
5619     }
5620     else {
5621         /* runtime pattern: build chain of regcomp etc ops */
5622         bool reglist;
5623         PADOFFSET cv_targ = 0;
5624
5625         reglist = isreg && expr->op_type == OP_LIST;
5626         if (reglist)
5627             op_null(expr);
5628
5629         if (has_code) {
5630             pm->op_code_list = expr;
5631             /* don't free op_code_list; its ops are embedded elsewhere too */
5632             pm->op_pmflags |= PMf_CODELIST_PRIVATE;
5633         }
5634
5635         if (o->op_flags & OPf_SPECIAL)
5636             pm->op_pmflags |= PMf_SPLIT;
5637
5638         /* the OP_REGCMAYBE is a placeholder in the non-threaded case
5639          * to allow its op_next to be pointed past the regcomp and
5640          * preceding stacking ops;
5641          * OP_REGCRESET is there to reset taint before executing the
5642          * stacking ops */
5643         if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
5644             expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
5645
5646         if (pm->op_pmflags & PMf_HAS_CV) {
5647             /* we have a runtime qr with literal code. This means
5648              * that the qr// has been wrapped in a new CV, which
5649              * means that runtime consts, vars etc will have been compiled
5650              * against a new pad. So... we need to execute those ops
5651              * within the environment of the new CV. So wrap them in a call
5652              * to a new anon sub. i.e. for
5653              *
5654              *     qr/a$b(?{...})/,
5655              *
5656              * we build an anon sub that looks like
5657              *
5658              *     sub { "a", $b, '(?{...})' }
5659              *
5660              * and call it, passing the returned list to regcomp.
5661              * Or to put it another way, the list of ops that get executed
5662              * are:
5663              *
5664              *     normal              PMf_HAS_CV
5665              *     ------              -------------------
5666              *                         pushmark (for regcomp)
5667              *                         pushmark (for entersub)
5668              *                         anoncode
5669              *                         srefgen
5670              *                         entersub
5671              *     regcreset                  regcreset
5672              *     pushmark                   pushmark
5673              *     const("a")                 const("a")
5674              *     gvsv(b)                    gvsv(b)
5675              *     const("(?{...})")          const("(?{...})")
5676              *                                leavesub
5677              *     regcomp             regcomp
5678              */
5679
5680             SvREFCNT_inc_simple_void(PL_compcv);
5681             CvLVALUE_on(PL_compcv);
5682             /* these lines are just an unrolled newANONATTRSUB */
5683             expr = newSVOP(OP_ANONCODE, 0,
5684                     MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
5685             cv_targ = expr->op_targ;
5686             expr = newUNOP(OP_REFGEN, 0, expr);
5687
5688             expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
5689         }
5690
5691         rcop = S_alloc_LOGOP(aTHX_ OP_REGCOMP, scalar(expr), o);
5692         rcop->op_flags |=  ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
5693                            | (reglist ? OPf_STACKED : 0);
5694         rcop->op_targ = cv_targ;
5695
5696         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
5697         if (PL_hints & HINT_RE_EVAL)
5698             S_set_haseval(aTHX);
5699
5700         /* establish postfix order */
5701         if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
5702             LINKLIST(expr);
5703             rcop->op_next = expr;
5704             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
5705         }
5706         else {
5707             rcop->op_next = LINKLIST(expr);
5708             expr->op_next = (OP*)rcop;
5709         }
5710
5711         op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
5712     }
5713
5714     if (repl) {
5715         OP *curop = repl;
5716         bool konst;
5717         /* If we are looking at s//.../e with a single statement, get past
5718            the implicit do{}. */
5719         if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
5720              && cUNOPx(curop)->op_first->op_type == OP_SCOPE
5721              && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
5722          {
5723             OP *sib;
5724             OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
5725             if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
5726              && !OpHAS_SIBLING(sib))
5727                 curop = sib;
5728         }
5729         if (curop->op_type == OP_CONST)
5730             konst = TRUE;
5731         else if (( (curop->op_type == OP_RV2SV ||
5732                     curop->op_type == OP_RV2AV ||
5733                     curop->op_type == OP_RV2HV ||
5734                     curop->op_type == OP_RV2GV)
5735                    && cUNOPx(curop)->op_first
5736                    && cUNOPx(curop)->op_first->op_type == OP_GV )
5737                 || curop->op_type == OP_PADSV
5738                 || curop->op_type == OP_PADAV
5739                 || curop->op_type == OP_PADHV
5740                 || curop->op_type == OP_PADANY) {
5741             repl_has_vars = 1;
5742             konst = TRUE;
5743         }
5744         else konst = FALSE;
5745         if (konst
5746             && !(repl_has_vars
5747                  && (!PM_GETRE(pm)
5748                      || !RX_PRELEN(PM_GETRE(pm))
5749                      || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
5750         {
5751             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
5752             op_prepend_elem(o->op_type, scalar(repl), o);
5753         }
5754         else {
5755             rcop = S_alloc_LOGOP(aTHX_ OP_SUBSTCONT, scalar(repl), o);
5756             rcop->op_private = 1;
5757
5758             /* establish postfix order */
5759             rcop->op_next = LINKLIST(repl);
5760             repl->op_next = (OP*)rcop;
5761
5762             pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
5763             assert(!(pm->op_pmflags & PMf_ONCE));
5764             pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
5765             rcop->op_next = 0;
5766         }
5767     }
5768
5769     return (OP*)pm;
5770 }
5771
5772 /*
5773 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
5774
5775 Constructs, checks, and returns an op of any type that involves an
5776 embedded SV.  C<type> is the opcode.  C<flags> gives the eight bits
5777 of C<op_flags>.  C<sv> gives the SV to embed in the op; this function
5778 takes ownership of one reference to it.
5779
5780 =cut
5781 */
5782
5783 OP *
5784 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
5785 {
5786     dVAR;
5787     SVOP *svop;
5788
5789     PERL_ARGS_ASSERT_NEWSVOP;
5790
5791     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5792         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5793         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5794         || type == OP_CUSTOM);
5795
5796     NewOp(1101, svop, 1, SVOP);
5797     OpTYPE_set(svop, type);
5798     svop->op_sv = sv;
5799     svop->op_next = (OP*)svop;
5800     svop->op_flags = (U8)flags;
5801     svop->op_private = (U8)(0 | (flags >> 8));
5802     if (PL_opargs[type] & OA_RETSCALAR)
5803         scalar((OP*)svop);
5804     if (PL_opargs[type] & OA_TARGET)
5805         svop->op_targ = pad_alloc(type, SVs_PADTMP);
5806     return CHECKOP(type, svop);
5807 }
5808
5809 /*
5810 =for apidoc Am|OP *|newDEFSVOP|
5811
5812 Constructs and returns an op to access C<$_>, either as a lexical
5813 variable (if declared as C<my $_>) in the current scope, or the
5814 global C<$_>.
5815
5816 =cut
5817 */
5818
5819 OP *
5820 Perl_newDEFSVOP(pTHX)
5821 {
5822     const PADOFFSET offset = pad_findmy_pvs("$_", 0);
5823     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5824         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
5825     }
5826     else {
5827         OP * const o = newOP(OP_PADSV, 0);
5828         o->op_targ = offset;
5829         return o;
5830     }
5831 }
5832
5833 #ifdef USE_ITHREADS
5834
5835 /*
5836 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
5837
5838 Constructs, checks, and returns an op of any type that involves a
5839 reference to a pad element.  C<type> is the opcode.  C<flags> gives the
5840 eight bits of C<op_flags>.  A pad slot is automatically allocated, and
5841 is populated with C<sv>; this function takes ownership of one reference
5842 to it.
5843
5844 This function only exists if Perl has been compiled to use ithreads.
5845
5846 =cut
5847 */
5848
5849 OP *
5850 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
5851 {
5852     dVAR;
5853     PADOP *padop;
5854
5855     PERL_ARGS_ASSERT_NEWPADOP;
5856
5857     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5858         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5859         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5860         || type == OP_CUSTOM);
5861
5862     NewOp(1101, padop, 1, PADOP);
5863     OpTYPE_set(padop, type);
5864     padop->op_padix =
5865         pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
5866     SvREFCNT_dec(PAD_SVl(padop->op_padix));
5867     PAD_SETSV(padop->op_padix, sv);
5868     assert(sv);
5869     padop->op_next = (OP*)padop;
5870     padop->op_flags = (U8)flags;
5871     if (PL_opargs[type] & OA_RETSCALAR)
5872         scalar((OP*)padop);
5873     if (PL_opargs[type] & OA_TARGET)
5874         padop->op_targ = pad_alloc(type, SVs_PADTMP);
5875     return CHECKOP(type, padop);
5876 }
5877
5878 #endif /* USE_ITHREADS */
5879
5880 /*
5881 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
5882
5883 Constructs, checks, and returns an op of any type that involves an
5884 embedded reference to a GV.  C<type> is the opcode.  C<flags> gives the
5885 eight bits of C<op_flags>.  C<gv> identifies the GV that the op should
5886 reference; calling this function does not transfer ownership of any
5887 reference to it.
5888
5889 =cut
5890 */
5891
5892 OP *
5893 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
5894 {
5895     PERL_ARGS_ASSERT_NEWGVOP;
5896
5897 #ifdef USE_ITHREADS
5898     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5899 #else
5900     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5901 #endif
5902 }
5903
5904 /*
5905 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
5906
5907 Constructs, checks, and returns an op of any type that involves an
5908 embedded C-level pointer (PV).  C<type> is the opcode.  C<flags> gives
5909 the eight bits of C<op_flags>.  C<pv> supplies the C-level pointer, which
5910 must have been allocated using C<PerlMemShared_malloc>; the memory will
5911 be freed when the op is destroyed.
5912
5913 =cut
5914 */
5915
5916 OP *
5917 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
5918 {
5919     dVAR;
5920     const bool utf8 = cBOOL(flags & SVf_UTF8);
5921     PVOP *pvop;
5922
5923     flags &= ~SVf_UTF8;
5924
5925     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5926         || type == OP_RUNCV || type == OP_CUSTOM
5927         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5928
5929     NewOp(1101, pvop, 1, PVOP);
5930     OpTYPE_set(pvop, type);
5931     pvop->op_pv = pv;
5932     pvop->op_next = (OP*)pvop;
5933     pvop->op_flags = (U8)flags;
5934     pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
5935     if (PL_opargs[type] & OA_RETSCALAR)
5936         scalar((OP*)pvop);
5937     if (PL_opargs[type] & OA_TARGET)
5938         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
5939     return CHECKOP(type, pvop);
5940 }
5941
5942 void
5943 Perl_package(pTHX_ OP *o)
5944 {
5945     SV *const sv = cSVOPo->op_sv;
5946
5947     PERL_ARGS_ASSERT_PACKAGE;
5948
5949     SAVEGENERICSV(PL_curstash);
5950     save_item(PL_curstname);
5951
5952     PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
5953
5954     sv_setsv(PL_curstname, sv);
5955
5956     PL_hints |= HINT_BLOCK_SCOPE;
5957     PL_parser->copline = NOLINE;
5958
5959     op_free(o);
5960 }
5961
5962 void
5963 Perl_package_version( pTHX_ OP *v )
5964 {
5965     U32 savehints = PL_hints;
5966     PERL_ARGS_ASSERT_PACKAGE_VERSION;
5967     PL_hints &= ~HINT_STRICT_VARS;
5968     sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
5969     PL_hints = savehints;
5970     op_free(v);
5971 }
5972
5973 void
5974 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
5975 {
5976     OP *pack;
5977     OP *imop;
5978     OP *veop;
5979     SV *use_version = NULL;
5980
5981     PERL_ARGS_ASSERT_UTILIZE;
5982
5983     if (idop->op_type != OP_CONST)
5984         Perl_croak(aTHX_ "Module name must be constant");
5985
5986     veop = NULL;
5987
5988     if (version) {
5989         SV * const vesv = ((SVOP*)version)->op_sv;
5990
5991         if (!arg && !SvNIOKp(vesv)) {
5992             arg = version;
5993         }
5994         else {
5995             OP *pack;
5996             SV *meth;
5997
5998             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
5999                 Perl_croak(aTHX_ "Version number must be a constant number");
6000
6001             /* Make copy of idop so we don't free it twice */
6002             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
6003
6004             /* Fake up a method call to VERSION */
6005             meth = newSVpvs_share("VERSION");
6006             veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
6007                             op_append_elem(OP_LIST,
6008                                         op_prepend_elem(OP_LIST, pack, version),
6009                                         newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
6010         }
6011     }
6012
6013     /* Fake up an import/unimport */
6014     if (arg && arg->op_type == OP_STUB) {
6015         imop = arg;             /* no import on explicit () */
6016     }
6017     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
6018         imop = NULL;            /* use 5.0; */
6019         if (aver)
6020             use_version = ((SVOP*)idop)->op_sv;
6021         else
6022             idop->op_private |= OPpCONST_NOVER;
6023     }
6024     else {
6025         SV *meth;
6026
6027         /* Make copy of idop so we don't free it twice */
6028         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
6029
6030         /* Fake up a method call to import/unimport */
6031         meth = aver
6032             ? newSVpvs_share("import") : newSVpvs_share("unimport");
6033         imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
6034                        op_append_elem(OP_LIST,
6035                                    op_prepend_elem(OP_LIST, pack, arg),
6036                                    newMETHOP_named(OP_METHOD_NAMED, 0, meth)
6037                        ));
6038     }
6039
6040     /* Fake up the BEGIN {}, which does its thing immediately. */
6041     newATTRSUB(floor,
6042         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
6043         NULL,
6044         NULL,
6045         op_append_elem(OP_LINESEQ,
6046             op_append_elem(OP_LINESEQ,
6047                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
6048                 newSTATEOP(0, NULL, veop)),
6049             newSTATEOP(0, NULL, imop) ));
6050
6051     if (use_version) {
6052         /* Enable the
6053          * feature bundle that corresponds to the required version. */
6054         use_version = sv_2mortal(new_version(use_version));
6055         S_enable_feature_bundle(aTHX_ use_version);
6056
6057         /* If a version >= 5.11.0 is requested, strictures are on by default! */
6058         if (vcmp(use_version,
6059                  sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
6060             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
6061                 PL_hints |= HINT_STRICT_REFS;
6062             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
6063                 PL_hints |= HINT_STRICT_SUBS;
6064             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
6065                 PL_hints |= HINT_STRICT_VARS;
6066         }
6067         /* otherwise they are off */
6068         else {
6069             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
6070                 PL_hints &= ~HINT_STRICT_REFS;
6071             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
6072                 PL_hints &= ~HINT_STRICT_SUBS;
6073             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
6074                 PL_hints &= ~HINT_STRICT_VARS;
6075         }
6076     }
6077
6078     /* The "did you use incorrect case?" warning used to be here.
6079      * The problem is that on case-insensitive filesystems one
6080      * might get false positives for "use" (and "require"):
6081      * "use Strict" or "require CARP" will work.  This causes
6082      * portability problems for the script: in case-strict
6083      * filesystems the script will stop working.
6084      *
6085      * The "incorrect case" warning checked whether "use Foo"
6086      * imported "Foo" to your namespace, but that is wrong, too:
6087      * there is no requirement nor promise in the language that
6088      * a Foo.pm should or would contain anything in package "Foo".
6089      *
6090      * There is very little Configure-wise that can be done, either:
6091      * the case-sensitivity of the build filesystem of Perl does not
6092      * help in guessing the case-sensitivity of the runtime environment.
6093      */
6094
6095     PL_hints |= HINT_BLOCK_SCOPE;
6096     PL_parser->copline = NOLINE;
6097     COP_SEQMAX_INC; /* Purely for B::*'s benefit */
6098 }
6099
6100 /*
6101 =head1 Embedding Functions
6102
6103 =for apidoc load_module
6104
6105 Loads the module whose name is pointed to by the string part of name.
6106 Note that the actual module name, not its filename, should be given.
6107 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
6108 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
6109 (or 0 for no flags).  ver, if specified
6110 and not NULL, provides version semantics
6111 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
6112 arguments can be used to specify arguments to the module's C<import()>
6113 method, similar to C<use Foo::Bar VERSION LIST>.  They must be
6114 terminated with a final C<NULL> pointer.  Note that this list can only
6115 be omitted when the C<PERL_LOADMOD_NOIMPORT> flag has been used.
6116 Otherwise at least a single C<NULL> pointer to designate the default
6117 import list is required.
6118
6119 The reference count for each specified C<SV*> parameter is decremented.
6120
6121 =cut */
6122
6123 void
6124 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
6125 {
6126     va_list args;
6127
6128     PERL_ARGS_ASSERT_LOAD_MODULE;
6129
6130     va_start(args, ver);
6131     vload_module(flags, name, ver, &args);
6132     va_end(args);
6133 }
6134
6135 #ifdef PERL_IMPLICIT_CONTEXT
6136 void
6137 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
6138 {
6139     dTHX;
6140     va_list args;
6141     PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
6142     va_start(args, ver);
6143     vload_module(flags, name, ver, &args);
6144     va_end(args);
6145 }
6146 #endif
6147
6148 void
6149 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
6150 {
6151     OP *veop, *imop;
6152     OP * const modname = newSVOP(OP_CONST, 0, name);
6153
6154     PERL_ARGS_ASSERT_VLOAD_MODULE;
6155
6156     modname->op_private |= OPpCONST_BARE;
6157     if (ver) {
6158         veop = newSVOP(OP_CONST, 0, ver);
6159     }
6160     else
6161         veop = NULL;
6162     if (flags & PERL_LOADMOD_NOIMPORT) {
6163         imop = sawparens(newNULLLIST());
6164     }
6165     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
6166         imop = va_arg(*args, OP*);
6167     }
6168     else {
6169         SV *sv;
6170         imop = NULL;
6171         sv = va_arg(*args, SV*);
6172         while (sv) {
6173             imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
6174             sv = va_arg(*args, SV*);
6175         }
6176     }
6177
6178     /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
6179      * that it has a PL_parser to play with while doing that, and also
6180      * that it doesn't mess with any existing parser, by creating a tmp
6181      * new parser with lex_start(). This won't actually be used for much,
6182      * since pp_require() will create another parser for the real work.
6183      * The ENTER/LEAVE pair protect callers from any side effects of use.  */
6184
6185     ENTER;
6186     SAVEVPTR(PL_curcop);
6187     lex_start(NULL, NULL, LEX_START_SAME_FILTER);
6188     utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
6189             veop, modname, imop);
6190     LEAVE;
6191 }
6192
6193 PERL_STATIC_INLINE OP *
6194 S_new_entersubop(pTHX_ GV *gv, OP *arg)
6195 {
6196     return newUNOP(OP_ENTERSUB, OPf_STACKED,
6197                    newLISTOP(OP_LIST, 0, arg,
6198                              newUNOP(OP_RV2CV, 0,
6199                                      newGVOP(OP_GV, 0, gv))));
6200 }
6201
6202 OP *
6203 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
6204 {
6205     OP *doop;
6206     GV *gv;
6207
6208     PERL_ARGS_ASSERT_DOFILE;
6209
6210     if (!force_builtin && (gv = gv_override("do", 2))) {
6211         doop = S_new_entersubop(aTHX_ gv, term);
6212     }
6213     else {
6214         doop = newUNOP(OP_DOFILE, 0, scalar(term));
6215     }
6216     return doop;
6217 }
6218
6219 /*
6220 =head1 Optree construction
6221
6222 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
6223
6224 Constructs, checks, and returns an C<lslice> (list slice) op.  C<flags>
6225 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
6226 be set automatically, and, shifted up eight bits, the eight bits of
6227 C<op_private>, except that the bit with value 1 or 2 is automatically
6228 set as required.  C<listval> and C<subscript> supply the parameters of
6229 the slice; they are consumed by this function and become part of the
6230 constructed op tree.
6231
6232 =cut
6233 */
6234
6235 OP *
6236 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
6237 {
6238     return newBINOP(OP_LSLICE, flags,
6239             list(force_list(subscript, 1)),
6240             list(force_list(listval,   1)) );
6241 }
6242
6243 #define ASSIGN_LIST   1
6244 #define ASSIGN_REF    2
6245
6246 STATIC I32
6247 S_assignment_type(pTHX_ const OP *o)
6248 {
6249     unsigned type;
6250     U8 flags;
6251     U8 ret;
6252
6253     if (!o)
6254         return TRUE;
6255
6256     if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
6257         o = cUNOPo->op_first;
6258
6259     flags = o->op_flags;
6260     type = o->op_type;
6261     if (type == OP_COND_EXPR) {
6262         OP * const sib = OpSIBLING(cLOGOPo->op_first);
6263         const I32 t = assignment_type(sib);
6264         const I32 f = assignment_type(OpSIBLING(sib));
6265
6266         if (t == ASSIGN_LIST && f == ASSIGN_LIST)
6267             return ASSIGN_LIST;
6268         if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
6269             yyerror("Assignment to both a list and a scalar");
6270         return FALSE;
6271     }
6272
6273     if (type == OP_SREFGEN)
6274     {
6275         OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
6276         type = kid->op_type;
6277         flags |= kid->op_flags;
6278         if (!(flags & OPf_PARENS)
6279           && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
6280               kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
6281             return ASSIGN_REF;
6282         ret = ASSIGN_REF;
6283     }
6284     else ret = 0;
6285
6286     if (type == OP_LIST &&
6287         (flags & OPf_WANT) == OPf_WANT_SCALAR &&
6288         o->op_private & OPpLVAL_INTRO)
6289         return ret;
6290
6291     if (type == OP_LIST || flags & OPf_PARENS ||
6292         type == OP_RV2AV || type == OP_RV2HV ||
6293         type == OP_ASLICE || type == OP_HSLICE ||
6294         type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
6295         return TRUE;
6296
6297     if (type == OP_PADAV || type == OP_PADHV)
6298         return TRUE;
6299
6300     if (type == OP_RV2SV)
6301         return ret;
6302
6303     return ret;
6304 }
6305
6306
6307 /*
6308 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
6309
6310 Constructs, checks, and returns an assignment op.  C<left> and C<right>
6311 supply the parameters of the assignment; they are consumed by this
6312 function and become part of the constructed op tree.
6313
6314 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
6315 a suitable conditional optree is constructed.  If C<optype> is the opcode
6316 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
6317 performs the binary operation and assigns the result to the left argument.
6318 Either way, if C<optype> is non-zero then C<flags> has no effect.
6319
6320 If C<optype> is zero, then a plain scalar or list assignment is
6321 constructed.  Which type of assignment it is is automatically determined.
6322 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6323 will be set automatically, and, shifted up eight bits, the eight bits
6324 of C<op_private>, except that the bit with value 1 or 2 is automatically
6325 set as required.
6326
6327 =cut
6328 */
6329
6330 OP *
6331 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
6332 {
6333     OP *o;
6334     I32 assign_type;
6335
6336     if (optype) {
6337         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
6338             return newLOGOP(optype, 0,
6339                 op_lvalue(scalar(left), optype),
6340                 newUNOP(OP_SASSIGN, 0, scalar(right)));
6341         }
6342         else {
6343             return newBINOP(optype, OPf_STACKED,
6344                 op_lvalue(scalar(left), optype), scalar(right));
6345         }
6346     }
6347
6348     if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
6349         static const char no_list_state[] = "Initialization of state variables"
6350             " in list context currently forbidden";
6351         OP *curop;
6352
6353         if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
6354             left->op_private &= ~ OPpSLICEWARNING;
6355
6356         PL_modcount = 0;
6357         left = op_lvalue(left, OP_AASSIGN);
6358         curop = list(force_list(left, 1));
6359         o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
6360         o->op_private = (U8)(0 | (flags >> 8));
6361
6362         if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
6363         {
6364             OP* lop = ((LISTOP*)left)->op_first;
6365             while (lop) {
6366                 if ((lop->op_type == OP_PADSV ||
6367                      lop->op_type == OP_PADAV ||
6368                      lop->op_type == OP_PADHV ||
6369                      lop->op_type == OP_PADANY)
6370                   && (lop->op_private & OPpPAD_STATE)
6371                 )
6372                     yyerror(no_list_state);
6373                 lop = OpSIBLING(lop);
6374             }
6375         }
6376         else if (  (left->op_private & OPpLVAL_INTRO)
6377                 && (left->op_private & OPpPAD_STATE)
6378                 && (   left->op_type == OP_PADSV
6379                     || left->op_type == OP_PADAV
6380                     || left->op_type == OP_PADHV
6381                     || left->op_type == OP_PADANY)
6382         ) {
6383                 /* All single variable list context state assignments, hence
6384                    state ($a) = ...
6385                    (state $a) = ...
6386                    state @a = ...
6387                    state (@a) = ...
6388                    (state @a) = ...
6389                    state %a = ...
6390                    state (%a) = ...
6391                    (state %a) = ...
6392                 */
6393                 yyerror(no_list_state);
6394         }
6395
6396         if (right && right->op_type == OP_SPLIT
6397          && !(right->op_flags & OPf_STACKED)) {
6398             OP* tmpop = ((LISTOP*)right)->op_first;
6399             PMOP * const pm = (PMOP*)tmpop;
6400             assert (tmpop && (tmpop->op_type == OP_PUSHRE));
6401             if (
6402 #ifdef USE_ITHREADS
6403                     !pm->op_pmreplrootu.op_pmtargetoff
6404 #else
6405                     !pm->op_pmreplrootu.op_pmtargetgv
6406 #endif
6407                  && !pm->op_targ
6408                 ) {
6409                     if (!(left->op_private & OPpLVAL_INTRO) &&
6410                         ( (left->op_type == OP_RV2AV &&
6411                           (tmpop=((UNOP*)left)->op_first)->op_type==OP_GV)
6412                         || left->op_type == OP_PADAV )
6413                         ) {
6414                         if (tmpop != (OP *)pm) {
6415 #ifdef USE_ITHREADS
6416                           pm->op_pmreplrootu.op_pmtargetoff
6417                             = cPADOPx(tmpop)->op_padix;
6418                           cPADOPx(tmpop)->op_padix = 0; /* steal it */
6419 #else
6420                           pm->op_pmreplrootu.op_pmtargetgv
6421                             = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
6422                           cSVOPx(tmpop)->op_sv = NULL;  /* steal it */
6423 #endif
6424                           right->op_private |=
6425                             left->op_private & OPpOUR_INTRO;
6426                         }
6427                         else {
6428                             pm->op_targ = left->op_targ;
6429                             left->op_targ = 0; /* filch it */
6430                         }
6431                       detach_split:
6432                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
6433                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
6434                         /* detach rest of siblings from o subtree,
6435                          * and free subtree */
6436                         op_sibling_splice(cUNOPo->op_first, tmpop, -1, NULL);
6437                         op_free(o);                     /* blow off assign */
6438                         right->op_flags &= ~OPf_WANT;
6439                                 /* "I don't know and I don't care." */
6440                         return right;
6441                     }
6442                     else if (left->op_type == OP_RV2AV
6443                           || left->op_type == OP_PADAV)
6444                     {
6445                         /* Detach the array.  */
6446 #ifdef DEBUGGING
6447                         OP * const ary =
6448 #endif
6449                         op_sibling_splice(cBINOPo->op_last,
6450                                           cUNOPx(cBINOPo->op_last)
6451                                                 ->op_first, 1, NULL);
6452                         assert(ary == left);
6453                         /* Attach it to the split.  */
6454                         op_sibling_splice(right, cLISTOPx(right)->op_last,
6455                                           0, left);
6456                         right->op_flags |= OPf_STACKED;
6457                         /* Detach split and expunge aassign as above.  */
6458                         goto detach_split;
6459                     }
6460                     else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
6461                             ((LISTOP*)right)->op_last->op_type == OP_CONST)
6462                     {
6463                         SV ** const svp =
6464                             &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
6465                         SV * const sv = *svp;
6466                         if (SvIOK(sv) && SvIVX(sv) == 0)
6467                         {
6468                           if (right->op_private & OPpSPLIT_IMPLIM) {
6469                             /* our own SV, created in ck_split */
6470                             SvREADONLY_off(sv);
6471                             sv_setiv(sv, PL_modcount+1);
6472                           }
6473                           else {
6474                             /* SV may belong to someone else */
6475                             SvREFCNT_dec(sv);
6476                             *svp = newSViv(PL_modcount+1);
6477                           }
6478                         }
6479                     }
6480             }
6481         }
6482         return o;
6483     }
6484     if (assign_type == ASSIGN_REF)
6485         return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
6486     if (!right)
6487         right = newOP(OP_UNDEF, 0);
6488     if (right->op_type == OP_READLINE) {
6489         right->op_flags |= OPf_STACKED;
6490         return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
6491                 scalar(right));
6492     }
6493     else {
6494         o = newBINOP(OP_SASSIGN, flags,
6495             scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
6496     }
6497     return o;
6498 }
6499
6500 /*
6501 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
6502
6503 Constructs a state op (COP).  The state op is normally a C<nextstate> op,
6504 but will be a C<dbstate> op if debugging is enabled for currently-compiled
6505 code.  The state op is populated from C<PL_curcop> (or C<PL_compiling>).
6506 If C<label> is non-null, it supplies the name of a label to attach to
6507 the state op; this function takes ownership of the memory pointed at by
6508 C<label>, and will free it.  C<flags> gives the eight bits of C<op_flags>
6509 for the state op.
6510
6511 If C<o> is null, the state op is returned.  Otherwise the state op is
6512 combined with C<o> into a C<lineseq> list op, which is returned.  C<o>
6513 is consumed by this function and becomes part of the returned op tree.
6514
6515 =cut
6516 */
6517
6518 OP *
6519 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
6520 {
6521     dVAR;
6522     const U32 seq = intro_my();
6523     const U32 utf8 = flags & SVf_UTF8;
6524     COP *cop;
6525
6526     PL_parser->parsed_sub = 0;
6527
6528     flags &= ~SVf_UTF8;
6529
6530     NewOp(1101, cop, 1, COP);
6531     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
6532         OpTYPE_set(cop, OP_DBSTATE);
6533     }
6534     else {
6535         OpTYPE_set(cop, OP_NEXTSTATE);
6536     }
6537     cop->op_flags = (U8)flags;
6538     CopHINTS_set(cop, PL_hints);
6539 #ifdef VMS
6540     if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
6541 #endif
6542     cop->op_next = (OP*)cop;
6543
6544     cop->cop_seq = seq;
6545     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
6546     CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
6547     if (label) {
6548         Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
6549
6550         PL_hints |= HINT_BLOCK_SCOPE;
6551         /* It seems that we need to defer freeing this pointer, as other parts
6552            of the grammar end up wanting to copy it after this op has been
6553            created. */
6554         SAVEFREEPV(label);
6555     }
6556
6557     if (PL_parser->preambling != NOLINE) {
6558         CopLINE_set(cop, PL_parser->preambling);
6559         PL_parser->copline = NOLINE;
6560     }
6561     else if (PL_parser->copline == NOLINE)
6562         CopLINE_set(cop, CopLINE(PL_curcop));
6563     else {
6564         CopLINE_set(cop, PL_parser->copline);
6565         PL_parser->copline = NOLINE;
6566     }
6567 #ifdef USE_ITHREADS
6568     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
6569 #else
6570     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
6571 #endif
6572     CopSTASH_set(cop, PL_curstash);
6573
6574     if (cop->op_type == OP_DBSTATE) {
6575         /* this line can have a breakpoint - store the cop in IV */
6576         AV *av = CopFILEAVx(PL_curcop);
6577         if (av) {
6578             SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
6579             if (svp && *svp != &PL_sv_undef ) {
6580                 (void)SvIOK_on(*svp);
6581                 SvIV_set(*svp, PTR2IV(cop));
6582             }
6583         }
6584     }
6585
6586     if (flags & OPf_SPECIAL)
6587         op_null((OP*)cop);
6588     return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
6589 }
6590
6591 /*
6592 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
6593
6594 Constructs, checks, and returns a logical (flow control) op.  C<type>
6595 is the opcode.  C<flags> gives the eight bits of C<op_flags>, except
6596 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6597 the eight bits of C<op_private>, except that the bit with value 1 is
6598 automatically set.  C<first> supplies the expression controlling the
6599 flow, and C<other> supplies the side (alternate) chain of ops; they are
6600 consumed by this function and become part of the constructed op tree.
6601
6602 =cut
6603 */
6604
6605 OP *
6606 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
6607 {
6608     PERL_ARGS_ASSERT_NEWLOGOP;
6609
6610     return new_logop(type, flags, &first, &other);
6611 }
6612
6613 STATIC OP *
6614 S_search_const(pTHX_ OP *o)
6615 {
6616     PERL_ARGS_ASSERT_SEARCH_CONST;
6617
6618     switch (o->op_type) {
6619         case OP_CONST:
6620             return o;
6621         case OP_NULL:
6622             if (o->op_flags & OPf_KIDS)
6623                 return search_const(cUNOPo->op_first);
6624             break;
6625         case OP_LEAVE:
6626         case OP_SCOPE:
6627         case OP_LINESEQ:
6628         {
6629             OP *kid;
6630             if (!(o->op_flags & OPf_KIDS))
6631                 return NULL;
6632             kid = cLISTOPo->op_first;
6633             do {
6634                 switch (kid->op_type) {
6635                     case OP_ENTER:
6636                     case OP_NULL:
6637                     case OP_NEXTSTATE:
6638                         kid = OpSIBLING(kid);
6639                         break;
6640                     default:
6641                         if (kid != cLISTOPo->op_last)
6642                             return NULL;
6643                         goto last;
6644                 }
6645             } while (kid);
6646             if (!kid)
6647                 kid = cLISTOPo->op_last;
6648           last:
6649             return search_const(kid);
6650         }
6651     }
6652
6653     return NULL;
6654 }
6655
6656 STATIC OP *
6657 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
6658 {
6659     dVAR;
6660     LOGOP *logop;
6661     OP *o;
6662     OP *first;
6663     OP *other;
6664     OP *cstop = NULL;
6665     int prepend_not = 0;
6666
6667     PERL_ARGS_ASSERT_NEW_LOGOP;
6668
6669     first = *firstp;
6670     other = *otherp;
6671
6672     /* [perl #59802]: Warn about things like "return $a or $b", which
6673        is parsed as "(return $a) or $b" rather than "return ($a or
6674        $b)".  NB: This also applies to xor, which is why we do it
6675        here.
6676      */
6677     switch (first->op_type) {
6678     case OP_NEXT:
6679     case OP_LAST:
6680     case OP_REDO:
6681         /* XXX: Perhaps we should emit a stronger warning for these.
6682            Even with the high-precedence operator they don't seem to do
6683            anything sensible.
6684
6685            But until we do, fall through here.
6686          */
6687     case OP_RETURN:
6688     case OP_EXIT:
6689     case OP_DIE:
6690     case OP_GOTO:
6691         /* XXX: Currently we allow people to "shoot themselves in the
6692            foot" by explicitly writing "(return $a) or $b".
6693
6694            Warn unless we are looking at the result from folding or if
6695            the programmer explicitly grouped the operators like this.
6696            The former can occur with e.g.
6697
6698                 use constant FEATURE => ( $] >= ... );
6699                 sub { not FEATURE and return or do_stuff(); }
6700          */
6701         if (!first->op_folded && !(first->op_flags & OPf_PARENS))
6702             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6703                            "Possible precedence issue with control flow operator");
6704         /* XXX: Should we optimze this to "return $a;" (i.e. remove
6705            the "or $b" part)?
6706         */
6707         break;
6708     }
6709
6710     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
6711         return newBINOP(type, flags, scalar(first), scalar(other));
6712
6713     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
6714         || type == OP_CUSTOM);
6715
6716     scalarboolean(first);
6717     /* optimize AND and OR ops that have NOTs as children */
6718     if (first->op_type == OP_NOT
6719         && (first->op_flags & OPf_KIDS)
6720         && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
6721             || (other->op_type == OP_NOT))  /* if (!$x && !$y) { } */
6722         ) {
6723         if (type == OP_AND || type == OP_OR) {
6724             if (type == OP_AND)
6725                 type = OP_OR;
6726             else
6727                 type = OP_AND;
6728             op_null(first);
6729             if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
6730                 op_null(other);
6731                 prepend_not = 1; /* prepend a NOT op later */
6732             }
6733         }
6734     }
6735     /* search for a constant op that could let us fold the test */
6736     if ((cstop = search_const(first))) {
6737         if (cstop->op_private & OPpCONST_STRICT)
6738             no_bareword_allowed(cstop);
6739         else if ((cstop->op_private & OPpCONST_BARE))
6740                 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
6741         if ((type == OP_AND &&  SvTRUE(((SVOP*)cstop)->op_sv)) ||
6742             (type == OP_OR  && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
6743             (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
6744             *firstp = NULL;
6745             if (other->op_type == OP_CONST)
6746                 other->op_private |= OPpCONST_SHORTCIRCUIT;
6747             op_free(first);
6748             if (other->op_type == OP_LEAVE)
6749                 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
6750             else if (other->op_type == OP_MATCH
6751                   || other->op_type == OP_SUBST
6752                   || other->op_type == OP_TRANSR
6753                   || other->op_type == OP_TRANS)
6754                 /* Mark the op as being unbindable with =~ */
6755                 other->op_flags |= OPf_SPECIAL;
6756
6757             other->op_folded = 1;
6758             return other;
6759         }
6760         else {
6761             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
6762             const OP *o2 = other;
6763             if ( ! (o2->op_type == OP_LIST
6764                     && (( o2 = cUNOPx(o2)->op_first))
6765                     && o2->op_type == OP_PUSHMARK
6766                     && (( o2 = OpSIBLING(o2))) )
6767             )
6768                 o2 = other;
6769             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
6770                         || o2->op_type == OP_PADHV)
6771                 && o2->op_private & OPpLVAL_INTRO
6772                 && !(o2->op_private & OPpPAD_STATE))
6773             {
6774                 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6775                                  "Deprecated use of my() in false conditional");
6776             }
6777
6778             *otherp = NULL;
6779             if (cstop->op_type == OP_CONST)
6780                 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
6781                 op_free(other);
6782             return first;
6783         }
6784     }
6785     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
6786         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
6787     {
6788         const OP * const k1 = ((UNOP*)first)->op_first;
6789         const OP * const k2 = OpSIBLING(k1);
6790         OPCODE warnop = 0;
6791         switch (first->op_type)
6792         {
6793         case OP_NULL:
6794             if (k2 && k2->op_type == OP_READLINE
6795                   && (k2->op_flags & OPf_STACKED)
6796                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6797             {
6798                 warnop = k2->op_type;
6799             }
6800             break;
6801
6802         case OP_SASSIGN:
6803             if (k1->op_type == OP_READDIR
6804                   || k1->op_type == OP_GLOB
6805                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6806                  || k1->op_type == OP_EACH
6807                  || k1->op_type == OP_AEACH)
6808             {
6809                 warnop = ((k1->op_type == OP_NULL)
6810                           ? (OPCODE)k1->op_targ : k1->op_type);
6811             }
6812             break;
6813         }
6814         if (warnop) {
6815             const line_t oldline = CopLINE(PL_curcop);
6816             /* This ensures that warnings are reported at the first line
6817                of the construction, not the last.  */
6818             CopLINE_set(PL_curcop, PL_parser->copline);
6819             Perl_warner(aTHX_ packWARN(WARN_MISC),
6820                  "Value of %s%s can be \"0\"; test with defined()",
6821                  PL_op_desc[warnop],
6822                  ((warnop == OP_READLINE || warnop == OP_GLOB)
6823                   ? " construct" : "() operator"));
6824             CopLINE_set(PL_curcop, oldline);
6825         }
6826     }
6827
6828     if (!other)
6829         return first;
6830
6831     if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
6832         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
6833
6834     logop = S_alloc_LOGOP(aTHX_ type, first, LINKLIST(other));
6835     logop->op_flags |= (U8)flags;
6836     logop->op_private = (U8)(1 | (flags >> 8));
6837
6838     /* establish postfix order */
6839     logop->op_next = LINKLIST(first);
6840     first->op_next = (OP*)logop;
6841     assert(!OpHAS_SIBLING(first));
6842     op_sibling_splice((OP*)logop, first, 0, other);
6843
6844     CHECKOP(type,logop);
6845
6846     o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
6847                 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
6848                 (OP*)logop);
6849     other->op_next = o;
6850
6851     return o;
6852 }
6853
6854 /*
6855 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
6856
6857 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
6858 op.  C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6859 will be set automatically, and, shifted up eight bits, the eight bits of
6860 C<op_private>, except that the bit with value 1 is automatically set.
6861 C<first> supplies the expression selecting between the two branches,
6862 and C<trueop> and C<falseop> supply the branches; they are consumed by
6863 this function and become part of the constructed op tree.
6864
6865 =cut
6866 */
6867
6868 OP *
6869 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
6870 {
6871     dVAR;
6872     LOGOP *logop;
6873     OP *start;
6874     OP *o;
6875     OP *cstop;
6876
6877     PERL_ARGS_ASSERT_NEWCONDOP;
6878
6879     if (!falseop)
6880         return newLOGOP(OP_AND, 0, first, trueop);
6881     if (!trueop)
6882         return newLOGOP(OP_OR, 0, first, falseop);
6883
6884     scalarboolean(first);
6885     if ((cstop = search_const(first))) {
6886         /* Left or right arm of the conditional?  */
6887         const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
6888         OP *live = left ? trueop : falseop;
6889         OP *const dead = left ? falseop : trueop;
6890         if (cstop->op_private & OPpCONST_BARE &&
6891             cstop->op_private & OPpCONST_STRICT) {
6892             no_bareword_allowed(cstop);
6893         }
6894         op_free(first);
6895         op_free(dead);
6896         if (live->op_type == OP_LEAVE)
6897             live = newUNOP(OP_NULL, OPf_SPECIAL, live);
6898         else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
6899               || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
6900             /* Mark the op as being unbindable with =~ */
6901             live->op_flags |= OPf_SPECIAL;
6902         live->op_folded = 1;
6903         return live;
6904     }
6905     logop = S_alloc_LOGOP(aTHX_ OP_COND_EXPR, first, LINKLIST(trueop));
6906     logop->op_flags |= (U8)flags;
6907     logop->op_private = (U8)(1 | (flags >> 8));
6908     logop->op_next = LINKLIST(falseop);
6909
6910     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
6911             logop);
6912
6913     /* establish postfix order */
6914     start = LINKLIST(first);
6915     first->op_next = (OP*)logop;
6916
6917     /* make first, trueop, falseop siblings */
6918     op_sibling_splice((OP*)logop, first,  0, trueop);
6919     op_sibling_splice((OP*)logop, trueop, 0, falseop);
6920
6921     o = newUNOP(OP_NULL, 0, (OP*)logop);
6922
6923     trueop->op_next = falseop->op_next = o;
6924
6925     o->op_next = start;
6926     return o;
6927 }
6928
6929 /*
6930 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
6931
6932 Constructs and returns a C<range> op, with subordinate C<flip> and
6933 C<flop> ops.  C<flags> gives the eight bits of C<op_flags> for the
6934 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
6935 for both the C<flip> and C<range> ops, except that the bit with value
6936 1 is automatically set.  C<left> and C<right> supply the expressions
6937 controlling the endpoints of the range; they are consumed by this function
6938 and become part of the constructed op tree.
6939
6940 =cut
6941 */
6942
6943 OP *
6944 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
6945 {
6946     LOGOP *range;
6947     OP *flip;
6948     OP *flop;
6949     OP *leftstart;
6950     OP *o;
6951
6952     PERL_ARGS_ASSERT_NEWRANGE;
6953
6954     range = S_alloc_LOGOP(aTHX_ OP_RANGE, left, LINKLIST(right));
6955     range->op_flags = OPf_KIDS;
6956     leftstart = LINKLIST(left);
6957     range->op_private = (U8)(1 | (flags >> 8));
6958
6959     /* make left and right siblings */
6960     op_sibling_splice((OP*)range, left, 0, right);
6961
6962     range->op_next = (OP*)range;
6963     flip = newUNOP(OP_FLIP, flags, (OP*)range);
6964     flop = newUNOP(OP_FLOP, 0, flip);
6965     o = newUNOP(OP_NULL, 0, flop);
6966     LINKLIST(flop);
6967     range->op_next = leftstart;
6968
6969     left->op_next = flip;
6970     right->op_next = flop;
6971
6972     range->op_targ =
6973         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
6974     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
6975     flip->op_targ =
6976         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
6977     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
6978     SvPADTMP_on(PAD_SV(flip->op_targ));
6979
6980     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6981     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6982
6983     /* check barewords before they might be optimized aways */
6984     if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
6985         no_bareword_allowed(left);
6986     if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
6987         no_bareword_allowed(right);
6988
6989     flip->op_next = o;
6990     if (!flip->op_private || !flop->op_private)
6991         LINKLIST(o);            /* blow off optimizer unless constant */
6992
6993     return o;
6994 }
6995
6996 /*
6997 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
6998
6999 Constructs, checks, and returns an op tree expressing a loop.  This is
7000 only a loop in the control flow through the op tree; it does not have
7001 the heavyweight loop structure that allows exiting the loop by C<last>
7002 and suchlike.  C<flags> gives the eight bits of C<op_flags> for the
7003 top-level op, except that some bits will be set automatically as required.
7004 C<expr> supplies the expression controlling loop iteration, and C<block>
7005 supplies the body of the loop; they are consumed by this function and
7006 become part of the constructed op tree.  C<debuggable> is currently
7007 unused and should always be 1.
7008
7009 =cut
7010 */
7011
7012 OP *
7013 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
7014 {
7015     OP* listop;
7016     OP* o;
7017     const bool once = block && block->op_flags & OPf_SPECIAL &&
7018                       block->op_type == OP_NULL;
7019
7020     PERL_UNUSED_ARG(debuggable);
7021
7022     if (expr) {
7023         if (once && (
7024               (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
7025            || (  expr->op_type == OP_NOT
7026               && cUNOPx(expr)->op_first->op_type == OP_CONST
7027               && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
7028               )
7029            ))
7030             /* Return the block now, so that S_new_logop does not try to
7031                fold it away. */
7032             return block;       /* do {} while 0 does once */
7033         if (expr->op_type == OP_READLINE
7034             || expr->op_type == OP_READDIR
7035             || expr->op_type == OP_GLOB
7036             || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
7037             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
7038             expr = newUNOP(OP_DEFINED, 0,
7039                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
7040         } else if (expr->op_flags & OPf_KIDS) {
7041             const OP * const k1 = ((UNOP*)expr)->op_first;
7042             const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
7043             switch (expr->op_type) {
7044               case OP_NULL:
7045                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
7046                       && (k2->op_flags & OPf_STACKED)
7047                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7048                     expr = newUNOP(OP_DEFINED, 0, expr);
7049                 break;
7050
7051               case OP_SASSIGN:
7052                 if (k1 && (k1->op_type == OP_READDIR
7053                       || k1->op_type == OP_GLOB
7054                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7055                      || k1->op_type == OP_EACH
7056                      || k1->op_type == OP_AEACH))
7057                     expr = newUNOP(OP_DEFINED, 0, expr);
7058                 break;
7059             }
7060         }
7061     }
7062
7063     /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
7064      * op, in listop. This is wrong. [perl #27024] */
7065     if (!block)
7066         block = newOP(OP_NULL, 0);
7067     listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
7068     o = new_logop(OP_AND, 0, &expr, &listop);
7069
7070     if (once) {
7071         ASSUME(listop);
7072     }
7073
7074     if (listop)
7075         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
7076
7077     if (once && o != listop)
7078     {
7079         assert(cUNOPo->op_first->op_type == OP_AND
7080             || cUNOPo->op_first->op_type == OP_OR);
7081         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
7082     }
7083
7084     if (o == listop)
7085         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
7086
7087     o->op_flags |= flags;
7088     o = op_scope(o);
7089     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
7090     return o;
7091 }
7092
7093 /*
7094 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
7095
7096 Constructs, checks, and returns an op tree expressing a C<while> loop.
7097 This is a heavyweight loop, with structure that allows exiting the loop
7098 by C<last> and suchlike.
7099
7100 C<loop> is an optional preconstructed C<enterloop> op to use in the
7101 loop; if it is null then a suitable op will be constructed automatically.
7102 C<expr> supplies the loop's controlling expression.  C<block> supplies the
7103 main body of the loop, and C<cont> optionally supplies a C<continue> block
7104 that operates as a second half of the body.  All of these optree inputs
7105 are consumed by this function and become part of the constructed op tree.
7106
7107 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7108 op and, shifted up eight bits, the eight bits of C<op_private> for
7109 the C<leaveloop> op, except that (in both cases) some bits will be set
7110 automatically.  C<debuggable> is currently unused and should always be 1.
7111 C<has_my> can be supplied as true to force the
7112 loop body to be enclosed in its own scope.
7113
7114 =cut
7115 */
7116
7117 OP *
7118 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
7119         OP *expr, OP *block, OP *cont, I32 has_my)
7120 {
7121     dVAR;
7122     OP *redo;
7123     OP *next = NULL;
7124     OP *listop;
7125     OP *o;
7126     U8 loopflags = 0;
7127
7128     PERL_UNUSED_ARG(debuggable);
7129
7130     if (expr) {
7131         if (expr->op_type == OP_READLINE
7132          || expr->op_type == OP_READDIR
7133          || expr->op_type == OP_GLOB
7134          || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
7135                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
7136             expr = newUNOP(OP_DEFINED, 0,
7137                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
7138         } else if (expr->op_flags & OPf_KIDS) {
7139             const OP * const k1 = ((UNOP*)expr)->op_first;
7140             const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
7141             switch (expr->op_type) {
7142               case OP_NULL:
7143                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
7144                       && (k2->op_flags & OPf_STACKED)
7145                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7146                     expr = newUNOP(OP_DEFINED, 0, expr);
7147                 break;
7148
7149               case OP_SASSIGN:
7150                 if (k1 && (k1->op_type == OP_READDIR
7151                       || k1->op_type == OP_GLOB
7152                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7153                      || k1->op_type == OP_EACH
7154                      || k1->op_type == OP_AEACH))
7155                     expr = newUNOP(OP_DEFINED, 0, expr);
7156                 break;
7157             }
7158         }
7159     }
7160
7161     if (!block)
7162         block = newOP(OP_NULL, 0);
7163     else if (cont || has_my) {
7164         block = op_scope(block);
7165     }
7166
7167     if (cont) {
7168         next = LINKLIST(cont);
7169     }
7170     if (expr) {
7171         OP * const unstack = newOP(OP_UNSTACK, 0);
7172         if (!next)
7173             next = unstack;
7174         cont = op_append_elem(OP_LINESEQ, cont, unstack);
7175     }
7176
7177     assert(block);
7178     listop = op_append_list(OP_LINESEQ, block, cont);
7179     assert(listop);
7180     redo = LINKLIST(listop);
7181
7182     if (expr) {
7183         scalar(listop);
7184         o = new_logop(OP_AND, 0, &expr, &listop);
7185         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
7186             op_free((OP*)loop);
7187             return expr;                /* listop already freed by new_logop */
7188         }
7189         if (listop)
7190             ((LISTOP*)listop)->op_last->op_next =
7191                 (o == listop ? redo : LINKLIST(o));
7192     }
7193     else
7194         o = listop;
7195
7196     if (!loop) {
7197         NewOp(1101,loop,1,LOOP);
7198         OpTYPE_set(loop, OP_ENTERLOOP);
7199         loop->op_private = 0;
7200         loop->op_next = (OP*)loop;
7201     }
7202
7203     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
7204
7205     loop->op_redoop = redo;
7206     loop->op_lastop = o;
7207     o->op_private |= loopflags;
7208
7209     if (next)
7210         loop->op_nextop = next;
7211     else
7212         loop->op_nextop = o;
7213
7214     o->op_flags |= flags;
7215     o->op_private |= (flags >> 8);
7216     return o;
7217 }
7218
7219 /*
7220 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
7221
7222 Constructs, checks, and returns an op tree expressing a C<foreach>
7223 loop (iteration through a list of values).  This is a heavyweight loop,
7224 with structure that allows exiting the loop by C<last> and suchlike.
7225
7226 C<sv> optionally supplies the variable that will be aliased to each
7227 item in turn; if null, it defaults to C<$_> (either lexical or global).
7228 C<expr> supplies the list of values to iterate over.  C<block> supplies
7229 the main body of the loop, and C<cont> optionally supplies a C<continue>
7230 block that operates as a second half of the body.  All of these optree
7231 inputs are consumed by this function and become part of the constructed
7232 op tree.
7233
7234 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7235 op and, shifted up eight bits, the eight bits of C<op_private> for
7236 the C<leaveloop> op, except that (in both cases) some bits will be set
7237 automatically.
7238
7239 =cut
7240 */
7241
7242 OP *
7243 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
7244 {
7245     dVAR;
7246     LOOP *loop;
7247     OP *wop;
7248     PADOFFSET padoff = 0;
7249     I32 iterflags = 0;
7250     I32 iterpflags = 0;
7251
7252     PERL_ARGS_ASSERT_NEWFOROP;
7253
7254     if (sv) {
7255         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
7256             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
7257             OpTYPE_set(sv, OP_RV2GV);
7258
7259             /* The op_type check is needed to prevent a possible segfault
7260              * if the loop variable is undeclared and 'strict vars' is in
7261              * effect. This is illegal but is nonetheless parsed, so we
7262              * may reach this point with an OP_CONST where we're expecting
7263              * an OP_GV.
7264              */
7265             if (cUNOPx(sv)->op_first->op_type == OP_GV
7266              && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
7267                 iterpflags |= OPpITER_DEF;
7268         }
7269         else if (sv->op_type == OP_PADSV) { /* private variable */
7270             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
7271             padoff = sv->op_targ;
7272             sv->op_targ = 0;
7273             op_free(sv);
7274             sv = NULL;
7275             PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
7276         }
7277         else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
7278             NOOP;
7279         else
7280             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
7281         if (padoff) {
7282             PADNAME * const pn = PAD_COMPNAME(padoff);
7283             const char * const name = PadnamePV(pn);
7284
7285             if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
7286                 iterpflags |= OPpITER_DEF;
7287         }
7288     }
7289     else {
7290         const PADOFFSET offset = pad_findmy_pvs("$_", 0);
7291         if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7292             sv = newGVOP(OP_GV, 0, PL_defgv);
7293         }
7294         else {
7295             padoff = offset;
7296         }
7297         iterpflags |= OPpITER_DEF;
7298     }
7299
7300     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
7301         expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
7302         iterflags |= OPf_STACKED;
7303     }
7304     else if (expr->op_type == OP_NULL &&
7305              (expr->op_flags & OPf_KIDS) &&
7306              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
7307     {
7308         /* Basically turn for($x..$y) into the same as for($x,$y), but we
7309          * set the STACKED flag to indicate that these values are to be
7310          * treated as min/max values by 'pp_enteriter'.
7311          */
7312         const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
7313         LOGOP* const range = (LOGOP*) flip->op_first;
7314         OP* const left  = range->op_first;
7315         OP* const right = OpSIBLING(left);
7316         LISTOP* listop;
7317
7318         range->op_flags &= ~OPf_KIDS;
7319         /* detach range's children */
7320         op_sibling_splice((OP*)range, NULL, -1, NULL);
7321
7322         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
7323         listop->op_first->op_next = range->op_next;
7324         left->op_next = range->op_other;
7325         right->op_next = (OP*)listop;
7326         listop->op_next = listop->op_first;
7327
7328         op_free(expr);
7329         expr = (OP*)(listop);
7330         op_null(expr);
7331         iterflags |= OPf_STACKED;
7332     }
7333     else {
7334         expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
7335     }
7336
7337     loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
7338                                   op_append_elem(OP_LIST, list(expr),
7339                                                  scalar(sv)));
7340     assert(!loop->op_next);
7341     /* for my  $x () sets OPpLVAL_INTRO;
7342      * for our $x () sets OPpOUR_INTRO */
7343     loop->op_private = (U8)iterpflags;
7344     if (loop->op_slabbed
7345      && DIFF(loop, OpSLOT(loop)->opslot_next)
7346          < SIZE_TO_PSIZE(sizeof(LOOP)))
7347     {
7348         LOOP *tmp;
7349         NewOp(1234,tmp,1,LOOP);
7350         Copy(loop,tmp,1,LISTOP);
7351 #ifdef PERL_OP_PARENT
7352         assert(loop->op_last->op_sibparent == (OP*)loop);
7353         OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
7354 #endif
7355         S_op_destroy(aTHX_ (OP*)loop);
7356         loop = tmp;
7357     }
7358     else if (!loop->op_slabbed)
7359     {
7360         loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
7361 #ifdef PERL_OP_PARENT
7362         OpLASTSIB_set(loop->op_last, (OP*)loop);
7363 #endif
7364     }
7365     loop->op_targ = padoff;
7366     wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
7367     return wop;
7368 }
7369
7370 /*
7371 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
7372
7373 Constructs, checks, and returns a loop-exiting op (such as C<goto>
7374 or C<last>).  C<type> is the opcode.  C<label> supplies the parameter
7375 determining the target of the op; it is consumed by this function and
7376 becomes part of the constructed op tree.
7377
7378 =cut
7379 */
7380
7381 OP*
7382 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
7383 {
7384     OP *o = NULL;
7385
7386     PERL_ARGS_ASSERT_NEWLOOPEX;
7387
7388     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
7389         || type == OP_CUSTOM);
7390
7391     if (type != OP_GOTO) {
7392         /* "last()" means "last" */
7393         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
7394             o = newOP(type, OPf_SPECIAL);
7395         }
7396     }
7397     else {
7398         /* Check whether it's going to be a goto &function */
7399         if (label->op_type == OP_ENTERSUB
7400                 && !(label->op_flags & OPf_STACKED))
7401             label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
7402     }
7403
7404     /* Check for a constant argument */
7405     if (label->op_type == OP_CONST) {
7406             SV * const sv = ((SVOP *)label)->op_sv;
7407             STRLEN l;
7408             const char *s = SvPV_const(sv,l);
7409             if (l == strlen(s)) {
7410                 o = newPVOP(type,
7411                             SvUTF8(((SVOP*)label)->op_sv),
7412                             savesharedpv(
7413                                 SvPV_nolen_const(((SVOP*)label)->op_sv)));
7414             }
7415     }
7416
7417     /* If we have already created an op, we do not need the label. */
7418     if (o)
7419                 op_free(label);
7420     else o = newUNOP(type, OPf_STACKED, label);
7421
7422     PL_hints |= HINT_BLOCK_SCOPE;
7423     return o;
7424 }
7425
7426 /* if the condition is a literal array or hash
7427    (or @{ ... } etc), make a reference to it.
7428  */
7429 STATIC OP *
7430 S_ref_array_or_hash(pTHX_ OP *cond)
7431 {
7432     if (cond
7433     && (cond->op_type == OP_RV2AV
7434     ||  cond->op_type == OP_PADAV
7435     ||  cond->op_type == OP_RV2HV
7436     ||  cond->op_type == OP_PADHV))
7437
7438         return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
7439
7440     else if(cond
7441     && (cond->op_type == OP_ASLICE
7442     ||  cond->op_type == OP_KVASLICE
7443     ||  cond->op_type == OP_HSLICE
7444     ||  cond->op_type == OP_KVHSLICE)) {
7445
7446         /* anonlist now needs a list from this op, was previously used in
7447          * scalar context */
7448         cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
7449         cond->op_flags |= OPf_WANT_LIST;
7450
7451         return newANONLIST(op_lvalue(cond, OP_ANONLIST));
7452     }
7453
7454     else
7455         return cond;
7456 }
7457
7458 /* These construct the optree fragments representing given()
7459    and when() blocks.
7460
7461    entergiven and enterwhen are LOGOPs; the op_other pointer
7462    points up to the associated leave op. We need this so we
7463    can put it in the context and make break/continue work.
7464    (Also, of course, pp_enterwhen will jump straight to
7465    op_other if the match fails.)
7466  */
7467
7468 STATIC OP *
7469 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
7470                    I32 enter_opcode, I32 leave_opcode,
7471                    PADOFFSET entertarg)
7472 {
7473     dVAR;
7474     LOGOP *enterop;
7475     OP *o;
7476
7477     PERL_ARGS_ASSERT_NEWGIVWHENOP;
7478
7479     enterop = S_alloc_LOGOP(aTHX_ enter_opcode, block, NULL);
7480     enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
7481     enterop->op_private = 0;
7482
7483     o = newUNOP(leave_opcode, 0, (OP *) enterop);
7484
7485     if (cond) {
7486         /* prepend cond if we have one */
7487         op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
7488
7489         o->op_next = LINKLIST(cond);
7490         cond->op_next = (OP *) enterop;
7491     }
7492     else {
7493         /* This is a default {} block */
7494         enterop->op_flags |= OPf_SPECIAL;
7495         o      ->op_flags |= OPf_SPECIAL;
7496
7497         o->op_next = (OP *) enterop;
7498     }
7499
7500     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
7501                                        entergiven and enterwhen both
7502                                        use ck_null() */
7503
7504     enterop->op_next = LINKLIST(block);
7505     block->op_next = enterop->op_other = o;
7506
7507     return o;
7508 }
7509
7510 /* Does this look like a boolean operation? For these purposes
7511    a boolean operation is:
7512      - a subroutine call [*]
7513      - a logical connective
7514      - a comparison operator
7515      - a filetest operator, with the exception of -s -M -A -C
7516      - defined(), exists() or eof()
7517      - /$re/ or $foo =~ /$re/
7518
7519    [*] possibly surprising
7520  */
7521 STATIC bool
7522 S_looks_like_bool(pTHX_ const OP *o)
7523 {
7524     PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
7525
7526     switch(o->op_type) {
7527         case OP_OR:
7528         case OP_DOR:
7529             return looks_like_bool(cLOGOPo->op_first);
7530
7531         case OP_AND:
7532         {
7533             OP* sibl = OpSIBLING(cLOGOPo->op_first);
7534             ASSUME(sibl);
7535             return (
7536                 looks_like_bool(cLOGOPo->op_first)
7537              && looks_like_bool(sibl));
7538         }
7539
7540         case OP_NULL:
7541         case OP_SCALAR:
7542             return (
7543                 o->op_flags & OPf_KIDS
7544             && looks_like_bool(cUNOPo->op_first));
7545
7546         case OP_ENTERSUB:
7547
7548         case OP_NOT:    case OP_XOR:
7549
7550         case OP_EQ:     case OP_NE:     case OP_LT:
7551         case OP_GT:     case OP_LE:     case OP_GE:
7552
7553         case OP_I_EQ:   case OP_I_NE:   case OP_I_LT:
7554         case OP_I_GT:   case OP_I_LE:   case OP_I_GE:
7555
7556         case OP_SEQ:    case OP_SNE:    case OP_SLT:
7557         case OP_SGT:    case OP_SLE:    case OP_SGE:
7558
7559         case OP_SMARTMATCH:
7560
7561         case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
7562         case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
7563         case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
7564         case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
7565         case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
7566         case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
7567         case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
7568         case OP_FTTEXT:   case OP_FTBINARY:
7569
7570         case OP_DEFINED: case OP_EXISTS:
7571         case OP_MATCH:   case OP_EOF:
7572
7573         case OP_FLOP:
7574
7575             return TRUE;
7576
7577         case OP_CONST:
7578             /* Detect comparisons that have been optimized away */
7579             if (cSVOPo->op_sv == &PL_sv_yes
7580             ||  cSVOPo->op_sv == &PL_sv_no)
7581
7582                 return TRUE;
7583             else
7584                 return FALSE;
7585
7586         /* FALLTHROUGH */
7587         default:
7588             return FALSE;
7589     }
7590 }
7591
7592 /*
7593 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
7594
7595 Constructs, checks, and returns an op tree expressing a C<given> block.
7596 C<cond> supplies the expression that will be locally assigned to a lexical
7597 variable, and C<block> supplies the body of the C<given> construct; they
7598 are consumed by this function and become part of the constructed op tree.
7599 C<defsv_off> is the pad offset of the scalar lexical variable that will
7600 be affected.  If it is 0, the global C<$_> will be used.
7601
7602 =cut
7603 */
7604
7605 OP *
7606 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
7607 {
7608     PERL_ARGS_ASSERT_NEWGIVENOP;
7609     return newGIVWHENOP(
7610         ref_array_or_hash(cond),
7611         block,
7612         OP_ENTERGIVEN, OP_LEAVEGIVEN,
7613         defsv_off);
7614 }
7615
7616 /*
7617 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
7618
7619 Constructs, checks, and returns an op tree expressing a C<when> block.
7620 C<cond> supplies the test expression, and C<block> supplies the block
7621 that will be executed if the test evaluates to true; they are consumed
7622 by this function and become part of the constructed op tree.  C<cond>
7623 will be interpreted DWIMically, often as a comparison against C<$_>,
7624 and may be null to generate a C<default> block.
7625
7626 =cut
7627 */
7628
7629 OP *
7630 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
7631 {
7632     const bool cond_llb = (!cond || looks_like_bool(cond));
7633     OP *cond_op;
7634
7635     PERL_ARGS_ASSERT_NEWWHENOP;
7636
7637     if (cond_llb)
7638         cond_op = cond;
7639     else {
7640         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
7641                 newDEFSVOP(),
7642                 scalar(ref_array_or_hash(cond)));
7643     }
7644
7645     return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
7646 }
7647
7648 /* must not conflict with SVf_UTF8 */
7649 #define CV_CKPROTO_CURSTASH     0x1
7650
7651 void
7652 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
7653                     const STRLEN len, const U32 flags)
7654 {
7655     SV *name = NULL, *msg;
7656     const char * cvp = SvROK(cv)
7657                         ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
7658                            ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
7659                            : ""
7660                         : CvPROTO(cv);
7661     STRLEN clen = CvPROTOLEN(cv), plen = len;
7662
7663     PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
7664
7665     if (p == NULL && cvp == NULL)
7666         return;
7667
7668     if (!ckWARN_d(WARN_PROTOTYPE))
7669         return;
7670
7671     if (p && cvp) {
7672         p = S_strip_spaces(aTHX_ p, &plen);
7673         cvp = S_strip_spaces(aTHX_ cvp, &clen);
7674         if ((flags & SVf_UTF8) == SvUTF8(cv)) {
7675             if (plen == clen && memEQ(cvp, p, plen))
7676                 return;
7677         } else {
7678             if (flags & SVf_UTF8) {
7679                 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
7680                     return;
7681             }
7682             else {
7683                 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
7684                     return;
7685             }
7686         }
7687     }
7688
7689     msg = sv_newmortal();
7690
7691     if (gv)
7692     {
7693         if (isGV(gv))
7694             gv_efullname3(name = sv_newmortal(), gv, NULL);
7695         else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
7696             name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
7697         else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
7698             name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
7699             sv_catpvs(name, "::");
7700             if (SvROK(gv)) {
7701                 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
7702                 assert (CvNAMED(SvRV_const(gv)));
7703                 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
7704             }
7705             else sv_catsv(name, (SV *)gv);
7706         }
7707         else name = (SV *)gv;
7708     }
7709     sv_setpvs(msg, "Prototype mismatch:");
7710     if (name)
7711         Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
7712     if (cvp)
7713         Perl_sv_catpvf(aTHX_ msg, " (%"UTF8f")",
7714             UTF8fARG(SvUTF8(cv),clen,cvp)
7715         );
7716     else
7717         sv_catpvs(msg, ": none");
7718     sv_catpvs(msg, " vs ");
7719     if (p)
7720         Perl_sv_catpvf(aTHX_ msg, "(%"UTF8f")", UTF8fARG(flags & SVf_UTF8,len,p));
7721     else
7722         sv_catpvs(msg, "none");
7723     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
7724 }
7725
7726 static void const_sv_xsub(pTHX_ CV* cv);
7727 static void const_av_xsub(pTHX_ CV* cv);
7728
7729 /*
7730
7731 =head1 Optree Manipulation Functions
7732
7733 =for apidoc cv_const_sv
7734
7735 If C<cv> is a constant sub eligible for inlining, returns the constant
7736 value returned by the sub.  Otherwise, returns C<NULL>.
7737
7738 Constant subs can be created with C<newCONSTSUB> or as described in
7739 L<perlsub/"Constant Functions">.
7740
7741 =cut
7742 */
7743 SV *
7744 Perl_cv_const_sv(const CV *const cv)
7745 {
7746     SV *sv;
7747     if (!cv)
7748         return NULL;
7749     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
7750         return NULL;
7751     sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7752     if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
7753     return sv;
7754 }
7755
7756 SV *
7757 Perl_cv_const_sv_or_av(const CV * const cv)
7758 {
7759     if (!cv)
7760         return NULL;
7761     if (SvROK(cv)) return SvRV((SV *)cv);
7762     assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
7763     return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7764 }
7765
7766 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
7767  * Can be called in 2 ways:
7768  *
7769  * !allow_lex
7770  *      look for a single OP_CONST with attached value: return the value
7771  *
7772  * allow_lex && !CvCONST(cv);
7773  *
7774  *      examine the clone prototype, and if contains only a single
7775  *      OP_CONST, return the value; or if it contains a single PADSV ref-
7776  *      erencing an outer lexical, turn on CvCONST to indicate the CV is
7777  *      a candidate for "constizing" at clone time, and return NULL.
7778  */
7779
7780 static SV *
7781 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
7782 {
7783     SV *sv = NULL;
7784     bool padsv = FALSE;
7785
7786     assert(o);
7787     assert(cv);
7788
7789     for (; o; o = o->op_next) {
7790         const OPCODE type = o->op_type;
7791
7792         if (type == OP_NEXTSTATE || type == OP_LINESEQ
7793              || type == OP_NULL
7794              || type == OP_PUSHMARK)
7795                 continue;
7796         if (type == OP_DBSTATE)
7797                 continue;
7798         if (type == OP_LEAVESUB)
7799             break;
7800         if (sv)
7801             return NULL;
7802         if (type == OP_CONST && cSVOPo->op_sv)
7803             sv = cSVOPo->op_sv;
7804         else if (type == OP_UNDEF && !o->op_private) {
7805             sv = newSV(0);
7806             SAVEFREESV(sv);
7807         }
7808         else if (allow_lex && type == OP_PADSV) {
7809                 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
7810                 {
7811                     sv = &PL_sv_undef; /* an arbitrary non-null value */
7812                     padsv = TRUE;
7813                 }
7814                 else
7815                     return NULL;
7816         }
7817         else {
7818             return NULL;
7819         }
7820     }
7821     if (padsv) {
7822         CvCONST_on(cv);
7823         return NULL;
7824     }
7825     return sv;
7826 }
7827
7828 static bool
7829 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
7830                         PADNAME * const name, SV ** const const_svp)
7831 {
7832     assert (cv);
7833     assert (o || name);
7834     assert (const_svp);
7835     if ((!block
7836          )) {
7837         if (CvFLAGS(PL_compcv)) {
7838             /* might have had built-in attrs applied */
7839             const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
7840             if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
7841              && ckWARN(WARN_MISC))
7842             {
7843                 /* protect against fatal warnings leaking compcv */
7844                 SAVEFREESV(PL_compcv);
7845                 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
7846                 SvREFCNT_inc_simple_void_NN(PL_compcv);
7847             }
7848             CvFLAGS(cv) |=
7849                 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
7850                   & ~(CVf_LVALUE * pureperl));
7851         }
7852         return FALSE;
7853     }
7854
7855     /* redundant check for speed: */
7856     if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
7857         const line_t oldline = CopLINE(PL_curcop);
7858         SV *namesv = o
7859             ? cSVOPo->op_sv
7860             : sv_2mortal(newSVpvn_utf8(
7861                 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
7862               ));
7863         if (PL_parser && PL_parser->copline != NOLINE)
7864             /* This ensures that warnings are reported at the first
7865                line of a redefinition, not the last.  */
7866             CopLINE_set(PL_curcop, PL_parser->copline);
7867         /* protect against fatal warnings leaking compcv */
7868         SAVEFREESV(PL_compcv);
7869         report_redefined_cv(namesv, cv, const_svp);
7870         SvREFCNT_inc_simple_void_NN(PL_compcv);
7871         CopLINE_set(PL_curcop, oldline);
7872     }
7873     SAVEFREESV(cv);
7874     return TRUE;
7875 }
7876
7877 CV *
7878 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
7879 {
7880     CV **spot;
7881     SV **svspot;
7882     const char *ps;
7883     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
7884     U32 ps_utf8 = 0;
7885     CV *cv = NULL;
7886     CV *compcv = PL_compcv;
7887     SV *const_sv;
7888     PADNAME *name;
7889     PADOFFSET pax = o->op_targ;
7890     CV *outcv = CvOUTSIDE(PL_compcv);
7891     CV *clonee = NULL;
7892     HEK *hek = NULL;
7893     bool reusable = FALSE;
7894     OP *start = NULL;
7895 #ifdef PERL_DEBUG_READONLY_OPS
7896     OPSLAB *slab = NULL;
7897 #endif
7898
7899     PERL_ARGS_ASSERT_NEWMYSUB;
7900
7901     /* Find the pad slot for storing the new sub.
7902        We cannot use PL_comppad, as it is the pad owned by the new sub.  We
7903        need to look in CvOUTSIDE and find the pad belonging to the enclos-
7904        ing sub.  And then we need to dig deeper if this is a lexical from
7905        outside, as in:
7906            my sub foo; sub { sub foo { } }
7907      */
7908    redo:
7909     name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
7910     if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
7911         pax = PARENT_PAD_INDEX(name);
7912         outcv = CvOUTSIDE(outcv);
7913         assert(outcv);
7914         goto redo;
7915     }
7916     svspot =
7917         &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
7918                         [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
7919     spot = (CV **)svspot;
7920
7921     if (!(PL_parser && PL_parser->error_count))
7922         move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name));
7923
7924     if (proto) {
7925         assert(proto->op_type == OP_CONST);
7926         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
7927         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
7928     }
7929     else
7930         ps = NULL;
7931
7932     if (proto)
7933         SAVEFREEOP(proto);
7934     if (attrs)
7935         SAVEFREEOP(attrs);
7936
7937     if (PL_parser && PL_parser->error_count) {
7938         op_free(block);
7939         SvREFCNT_dec(PL_compcv);
7940         PL_compcv = 0;
7941         goto done;
7942     }
7943
7944     if (CvDEPTH(outcv) && CvCLONE(compcv)) {
7945         cv = *spot;
7946         svspot = (SV **)(spot = &clonee);
7947     }
7948     else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
7949         cv = *spot;
7950     else {
7951         assert (SvTYPE(*spot) == SVt_PVCV);
7952         if (CvNAMED(*spot))
7953             hek = CvNAME_HEK(*spot);
7954         else {
7955             dVAR;
7956             U32 hash;
7957             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
7958             CvNAME_HEK_set(*spot, hek =
7959                 share_hek(
7960                     PadnamePV(name)+1,
7961                     (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
7962                     hash
7963                 )
7964             );
7965             CvLEXICAL_on(*spot);
7966         }
7967         cv = PadnamePROTOCV(name);
7968         svspot = (SV **)(spot = &PadnamePROTOCV(name));
7969     }
7970
7971     if (block) {
7972         /* This makes sub {}; work as expected.  */
7973         if (block->op_type == OP_STUB) {
7974             const line_t l = PL_parser->copline;
7975             op_free(block);
7976             block = newSTATEOP(0, NULL, 0);
7977             PL_parser->copline = l;
7978         }
7979         block = CvLVALUE(compcv)
7980              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
7981                    ? newUNOP(OP_LEAVESUBLV, 0,
7982                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
7983                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
7984         start = LINKLIST(block);
7985         block->op_next = 0;
7986         if (ps && !*ps && !attrs && !CvLVALUE(compcv))
7987             const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
7988         else
7989             const_sv = NULL;
7990     }
7991     else
7992         const_sv = NULL;
7993
7994     if (cv) {
7995         const bool exists = CvROOT(cv) || CvXSUB(cv);
7996
7997         /* if the subroutine doesn't exist and wasn't pre-declared
7998          * with a prototype, assume it will be AUTOLOADed,
7999          * skipping the prototype check
8000          */
8001         if (exists || SvPOK(cv))
8002             cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
8003                                  ps_utf8);
8004         /* already defined? */
8005         if (exists) {
8006             if (S_already_defined(aTHX_ cv,block,NULL,name,&const_sv))
8007                 cv = NULL;
8008             else {
8009                 if (attrs) goto attrs;
8010                 /* just a "sub foo;" when &foo is already defined */
8011                 SAVEFREESV(compcv);
8012                 goto done;
8013             }
8014         }
8015         else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
8016             cv = NULL;
8017             reusable = TRUE;
8018         }
8019     }
8020     if (const_sv) {
8021         SvREFCNT_inc_simple_void_NN(const_sv);
8022         SvFLAGS(const_sv) |= SVs_PADTMP;
8023         if (cv) {
8024             assert(!CvROOT(cv) && !CvCONST(cv));
8025             cv_forget_slab(cv);
8026         }
8027         else {
8028             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8029             CvFILE_set_from_cop(cv, PL_curcop);
8030             CvSTASH_set(cv, PL_curstash);
8031             *spot = cv;
8032         }
8033         sv_setpvs(MUTABLE_SV(cv), "");  /* prototype is "" */
8034         CvXSUBANY(cv).any_ptr = const_sv;
8035         CvXSUB(cv) = const_sv_xsub;
8036         CvCONST_on(cv);
8037         CvISXSUB_on(cv);
8038         PoisonPADLIST(cv);
8039         CvFLAGS(cv) |= CvMETHOD(compcv);
8040         op_free(block);
8041         SvREFCNT_dec(compcv);
8042         PL_compcv = NULL;
8043         goto setname;
8044     }
8045     /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
8046        determine whether this sub definition is in the same scope as its
8047        declaration.  If this sub definition is inside an inner named pack-
8048        age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
8049        the package sub.  So check PadnameOUTER(name) too.
8050      */
8051     if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
8052         assert(!CvWEAKOUTSIDE(compcv));
8053         SvREFCNT_dec(CvOUTSIDE(compcv));
8054         CvWEAKOUTSIDE_on(compcv);
8055     }
8056     /* XXX else do we have a circular reference? */
8057     if (cv) {   /* must reuse cv in case stub is referenced elsewhere */
8058         /* transfer PL_compcv to cv */
8059         if (block
8060         ) {
8061             cv_flags_t preserved_flags =
8062                 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
8063             PADLIST *const temp_padl = CvPADLIST(cv);
8064             CV *const temp_cv = CvOUTSIDE(cv);
8065             const cv_flags_t other_flags =
8066                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8067             OP * const cvstart = CvSTART(cv);
8068
8069             SvPOK_off(cv);
8070             CvFLAGS(cv) =
8071                 CvFLAGS(compcv) | preserved_flags;
8072             CvOUTSIDE(cv) = CvOUTSIDE(compcv);
8073             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
8074             CvPADLIST_set(cv, CvPADLIST(compcv));
8075             CvOUTSIDE(compcv) = temp_cv;
8076             CvPADLIST_set(compcv, temp_padl);
8077             CvSTART(cv) = CvSTART(compcv);
8078             CvSTART(compcv) = cvstart;
8079             CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8080             CvFLAGS(compcv) |= other_flags;
8081
8082             if (CvFILE(cv) && CvDYNFILE(cv)) {
8083                 Safefree(CvFILE(cv));
8084             }
8085
8086             /* inner references to compcv must be fixed up ... */
8087             pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
8088             if (PERLDB_INTER)/* Advice debugger on the new sub. */
8089               ++PL_sub_generation;
8090         }
8091         else {
8092             /* Might have had built-in attributes applied -- propagate them. */
8093             CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
8094         }
8095         /* ... before we throw it away */
8096         SvREFCNT_dec(compcv);
8097         PL_compcv = compcv = cv;
8098     }
8099     else {
8100         cv = compcv;
8101         *spot = cv;
8102     }
8103    setname:
8104     CvLEXICAL_on(cv);
8105     if (!CvNAME_HEK(cv)) {
8106         if (hek) (void)share_hek_hek(hek);
8107         else {
8108             dVAR;
8109             U32 hash;
8110             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
8111             hek = share_hek(PadnamePV(name)+1,
8112                       (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
8113                       hash);
8114         }
8115         CvNAME_HEK_set(cv, hek);
8116     }
8117     if (const_sv) goto clone;
8118
8119     CvFILE_set_from_cop(cv, PL_curcop);
8120     CvSTASH_set(cv, PL_curstash);
8121
8122     if (ps) {
8123         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8124         if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
8125     }
8126
8127     if (!block)
8128         goto attrs;
8129
8130     /* If we assign an optree to a PVCV, then we've defined a subroutine that
8131        the debugger could be able to set a breakpoint in, so signal to
8132        pp_entereval that it should not throw away any saved lines at scope
8133        exit.  */
8134
8135     PL_breakable_sub_gen++;
8136     CvROOT(cv) = block;
8137     CvROOT(cv)->op_private |= OPpREFCOUNTED;
8138     OpREFCNT_set(CvROOT(cv), 1);
8139     /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8140        itself has a refcount. */
8141     CvSLABBED_off(cv);
8142     OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8143 #ifdef PERL_DEBUG_READONLY_OPS
8144     slab = (OPSLAB *)CvSTART(cv);
8145 #endif
8146     CvSTART(cv) = start;
8147     CALL_PEEP(start);
8148     finalize_optree(CvROOT(cv));
8149     S_prune_chain_head(&CvSTART(cv));
8150
8151     /* now that optimizer has done its work, adjust pad values */
8152
8153     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8154
8155   attrs:
8156     if (attrs) {
8157         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8158         apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
8159     }
8160
8161     if (block) {
8162         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8163             SV * const tmpstr = sv_newmortal();
8164             GV * const db_postponed = gv_fetchpvs("DB::postponed",
8165                                                   GV_ADDMULTI, SVt_PVHV);
8166             HV *hv;
8167             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8168                                           CopFILE(PL_curcop),
8169                                           (long)PL_subline,
8170                                           (long)CopLINE(PL_curcop));
8171             if (HvNAME_HEK(PL_curstash)) {
8172                 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
8173                 sv_catpvs(tmpstr, "::");
8174             }
8175             else sv_setpvs(tmpstr, "__ANON__::");
8176             sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
8177                             PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
8178             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8179                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8180             hv = GvHVn(db_postponed);
8181             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8182                 CV * const pcv = GvCV(db_postponed);
8183                 if (pcv) {
8184                     dSP;
8185                     PUSHMARK(SP);
8186                     XPUSHs(tmpstr);
8187                     PUTBACK;
8188                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
8189                 }
8190             }
8191         }
8192     }
8193
8194   clone:
8195     if (clonee) {
8196         assert(CvDEPTH(outcv));
8197         spot = (CV **)
8198             &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
8199         if (reusable) cv_clone_into(clonee, *spot);
8200         else *spot = cv_clone(clonee);
8201         SvREFCNT_dec_NN(clonee);
8202         cv = *spot;
8203     }
8204     if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
8205         PADOFFSET depth = CvDEPTH(outcv);
8206         while (--depth) {
8207             SV *oldcv;
8208             svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
8209             oldcv = *svspot;
8210             *svspot = SvREFCNT_inc_simple_NN(cv);
8211             SvREFCNT_dec(oldcv);
8212         }
8213     }
8214
8215   done:
8216     if (PL_parser)
8217         PL_parser->copline = NOLINE;
8218     LEAVE_SCOPE(floor);
8219 #ifdef PERL_DEBUG_READONLY_OPS
8220     if (slab)
8221         Slab_to_ro(slab);
8222 #endif
8223     op_free(o);
8224     return cv;
8225 }
8226
8227 /* _x = extended */
8228 CV *
8229 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
8230                             OP *block, bool o_is_gv)
8231 {
8232     GV *gv;
8233     const char *ps;
8234     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
8235     U32 ps_utf8 = 0;
8236     CV *cv = NULL;
8237     SV *const_sv;
8238     const bool ec = PL_parser && PL_parser->error_count;
8239     /* If the subroutine has no body, no attributes, and no builtin attributes
8240        then it's just a sub declaration, and we may be able to get away with
8241        storing with a placeholder scalar in the symbol table, rather than a
8242        full CV.  If anything is present then it will take a full CV to
8243        store it.  */
8244     const I32 gv_fetch_flags
8245         = ec ? GV_NOADD_NOINIT :
8246         (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
8247         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
8248     STRLEN namlen = 0;
8249     const char * const name =
8250          o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
8251     bool has_name;
8252     bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
8253     bool evanescent = FALSE;
8254     OP *start = NULL;
8255 #ifdef PERL_DEBUG_READONLY_OPS
8256     OPSLAB *slab = NULL;
8257 #endif
8258
8259     if (o_is_gv) {
8260         gv = (GV*)o;
8261         o = NULL;
8262         has_name = TRUE;
8263     } else if (name) {
8264         /* Try to optimise and avoid creating a GV.  Instead, the CV’s name
8265            hek and CvSTASH pointer together can imply the GV.  If the name
8266            contains a package name, then GvSTASH(CvGV(cv)) may differ from
8267            CvSTASH, so forego the optimisation if we find any.
8268            Also, we may be called from load_module at run time, so
8269            PL_curstash (which sets CvSTASH) may not point to the stash the
8270            sub is stored in.  */
8271         const I32 flags =
8272            ec ? GV_NOADD_NOINIT
8273               :   PL_curstash != CopSTASH(PL_curcop)
8274                || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
8275                     ? gv_fetch_flags
8276                     : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
8277         gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
8278         has_name = TRUE;
8279     } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
8280         SV * const sv = sv_newmortal();
8281         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
8282                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
8283                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
8284         gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
8285         has_name = TRUE;
8286     } else if (PL_curstash) {
8287         gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
8288         has_name = FALSE;
8289     } else {
8290         gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
8291         has_name = FALSE;
8292     }
8293     if (!ec) {
8294         if (isGV(gv)) {
8295             move_proto_attr(&proto, &attrs, gv);
8296         } else {
8297             assert(cSVOPo);
8298             move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv);
8299         }
8300     }
8301
8302     if (proto) {
8303         assert(proto->op_type == OP_CONST);
8304         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
8305         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
8306     }
8307     else
8308         ps = NULL;
8309
8310     if (o)
8311         SAVEFREEOP(o);
8312     if (proto)
8313         SAVEFREEOP(proto);
8314     if (attrs)
8315         SAVEFREEOP(attrs);
8316
8317     if (ec) {
8318         op_free(block);
8319         if (name) SvREFCNT_dec(PL_compcv);
8320         else cv = PL_compcv;
8321         PL_compcv = 0;
8322         if (name && block) {
8323             const char *s = strrchr(name, ':');
8324             s = s ? s+1 : name;
8325             if (strEQ(s, "BEGIN")) {
8326                 if (PL_in_eval & EVAL_KEEPERR)
8327                     Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
8328                 else {
8329                     SV * const errsv = ERRSV;
8330                     /* force display of errors found but not reported */
8331                     sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
8332                     Perl_croak_nocontext("%"SVf, SVfARG(errsv));
8333                 }
8334             }
8335         }
8336         goto done;
8337     }
8338
8339     if (!block && SvTYPE(gv) != SVt_PVGV) {
8340       /* If we are not defining a new sub and the existing one is not a
8341          full GV + CV... */
8342       if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
8343         /* We are applying attributes to an existing sub, so we need it
8344            upgraded if it is a constant.  */
8345         if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
8346             gv_init_pvn(gv, PL_curstash, name, namlen,
8347                         SVf_UTF8 * name_is_utf8);
8348       }
8349       else {                    /* Maybe prototype now, and had at maximum
8350                                    a prototype or const/sub ref before.  */
8351         if (SvTYPE(gv) > SVt_NULL) {
8352             cv_ckproto_len_flags((const CV *)gv,
8353                                  o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8354                                  ps_len, ps_utf8);
8355         }
8356         if (!SvROK(gv)) {
8357           if (ps) {
8358             sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
8359             if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
8360           }
8361           else
8362             sv_setiv(MUTABLE_SV(gv), -1);
8363         }
8364
8365         SvREFCNT_dec(PL_compcv);
8366         cv = PL_compcv = NULL;
8367         goto done;
8368       }
8369     }
8370
8371     cv = (!name || (isGV(gv) && GvCVGEN(gv)))
8372         ? NULL
8373         : isGV(gv)
8374             ? GvCV(gv)
8375             : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
8376                 ? (CV *)SvRV(gv)
8377                 : NULL;
8378
8379     if (block) {
8380         /* This makes sub {}; work as expected.  */
8381         if (block->op_type == OP_STUB) {
8382             const line_t l = PL_parser->copline;
8383             op_free(block);
8384             block = newSTATEOP(0, NULL, 0);
8385             PL_parser->copline = l;
8386         }
8387         block = CvLVALUE(PL_compcv)
8388              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
8389                     && (!isGV(gv) || !GvASSUMECV(gv)))
8390                    ? newUNOP(OP_LEAVESUBLV, 0,
8391                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
8392                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
8393         start = LINKLIST(block);
8394         block->op_next = 0;
8395         if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
8396             const_sv =
8397                 S_op_const_sv(aTHX_ start, PL_compcv, CvCLONE(PL_compcv));
8398         else
8399             const_sv = NULL;
8400     }
8401     else
8402         const_sv = NULL;
8403
8404     if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
8405         assert (block);
8406         cv_ckproto_len_flags((const CV *)gv,
8407                              o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8408                              ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
8409         if (SvROK(gv)) {
8410             /* All the other code for sub redefinition warnings expects the
8411                clobbered sub to be a CV.  Instead of making all those code
8412                paths more complex, just inline the RV version here.  */
8413             const line_t oldline = CopLINE(PL_curcop);
8414             assert(IN_PERL_COMPILETIME);
8415             if (PL_parser && PL_parser->copline != NOLINE)
8416                 /* This ensures that warnings are reported at the first
8417                    line of a redefinition, not the last.  */
8418                 CopLINE_set(PL_curcop, PL_parser->copline);
8419             /* protect against fatal warnings leaking compcv */
8420             SAVEFREESV(PL_compcv);
8421
8422             if (ckWARN(WARN_REDEFINE)
8423              || (  ckWARN_d(WARN_REDEFINE)
8424                 && (  !const_sv || SvRV(gv) == const_sv
8425                    || sv_cmp(SvRV(gv), const_sv)  )))
8426                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8427                           "Constant subroutine %"SVf" redefined",
8428                           SVfARG(cSVOPo->op_sv));
8429
8430             SvREFCNT_inc_simple_void_NN(PL_compcv);
8431             CopLINE_set(PL_curcop, oldline);
8432             SvREFCNT_dec(SvRV(gv));
8433         }
8434     }
8435
8436     if (cv) {
8437         const bool exists = CvROOT(cv) || CvXSUB(cv);
8438
8439         /* if the subroutine doesn't exist and wasn't pre-declared
8440          * with a prototype, assume it will be AUTOLOADed,
8441          * skipping the prototype check
8442          */
8443         if (exists || SvPOK(cv))
8444             cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
8445         /* already defined (or promised)? */
8446         if (exists || (isGV(gv) && GvASSUMECV(gv))) {
8447             if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv))
8448                 cv = NULL;
8449             else {
8450                 if (attrs) goto attrs;
8451                 /* just a "sub foo;" when &foo is already defined */
8452                 SAVEFREESV(PL_compcv);
8453                 goto done;
8454             }
8455         }
8456     }
8457     if (const_sv) {
8458         SvREFCNT_inc_simple_void_NN(const_sv);
8459         SvFLAGS(const_sv) |= SVs_PADTMP;
8460         if (cv) {
8461             assert(!CvROOT(cv) && !CvCONST(cv));
8462             cv_forget_slab(cv);
8463             sv_setpvs(MUTABLE_SV(cv), "");  /* prototype is "" */
8464             CvXSUBANY(cv).any_ptr = const_sv;
8465             CvXSUB(cv) = const_sv_xsub;
8466             CvCONST_on(cv);
8467             CvISXSUB_on(cv);
8468             PoisonPADLIST(cv);
8469             CvFLAGS(cv) |= CvMETHOD(PL_compcv);
8470         }
8471         else {
8472             if (isGV(gv) || CvMETHOD(PL_compcv)) {
8473                 if (name && isGV(gv))
8474                     GvCV_set(gv, NULL);
8475                 cv = newCONSTSUB_flags(
8476                     NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
8477                     const_sv
8478                 );
8479                 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
8480             }
8481             else {
8482                 if (!SvROK(gv)) {
8483                     SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8484                     prepare_SV_for_RV((SV *)gv);
8485                     SvOK_off((SV *)gv);
8486                     SvROK_on(gv);
8487                 }
8488                 SvRV_set(gv, const_sv);
8489             }
8490         }
8491         op_free(block);
8492         SvREFCNT_dec(PL_compcv);
8493         PL_compcv = NULL;
8494         goto done;
8495     }
8496     if (cv) {                           /* must reuse cv if autoloaded */
8497         /* transfer PL_compcv to cv */
8498         if (block
8499         ) {
8500             cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
8501             PADLIST *const temp_av = CvPADLIST(cv);
8502             CV *const temp_cv = CvOUTSIDE(cv);
8503             const cv_flags_t other_flags =
8504                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8505             OP * const cvstart = CvSTART(cv);
8506
8507             if (isGV(gv)) {
8508                 CvGV_set(cv,gv);
8509                 assert(!CvCVGV_RC(cv));
8510                 assert(CvGV(cv) == gv);
8511             }
8512             else {
8513                 dVAR;
8514                 U32 hash;
8515                 PERL_HASH(hash, name, namlen);
8516                 CvNAME_HEK_set(cv,
8517                                share_hek(name,
8518                                          name_is_utf8
8519                                             ? -(SSize_t)namlen
8520                                             :  (SSize_t)namlen,
8521                                          hash));
8522             }
8523
8524             SvPOK_off(cv);
8525             CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
8526                                              | CvNAMED(cv);
8527             CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
8528             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
8529             CvPADLIST_set(cv,CvPADLIST(PL_compcv));
8530             CvOUTSIDE(PL_compcv) = temp_cv;
8531             CvPADLIST_set(PL_compcv, temp_av);
8532             CvSTART(cv) = CvSTART(PL_compcv);
8533             CvSTART(PL_compcv) = cvstart;
8534             CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8535             CvFLAGS(PL_compcv) |= other_flags;
8536
8537             if (CvFILE(cv) && CvDYNFILE(cv)) {
8538                 Safefree(CvFILE(cv));
8539     }
8540             CvFILE_set_from_cop(cv, PL_curcop);
8541             CvSTASH_set(cv, PL_curstash);
8542
8543             /* inner references to PL_compcv must be fixed up ... */
8544             pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
8545             if (PERLDB_INTER)/* Advice debugger on the new sub. */
8546               ++PL_sub_generation;
8547         }
8548         else {
8549             /* Might have had built-in attributes applied -- propagate them. */
8550             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
8551         }
8552         /* ... before we throw it away */
8553         SvREFCNT_dec(PL_compcv);
8554         PL_compcv = cv;
8555     }
8556     else {
8557         cv = PL_compcv;
8558         if (name && isGV(gv)) {
8559             GvCV_set(gv, cv);
8560             GvCVGEN(gv) = 0;
8561             if (HvENAME_HEK(GvSTASH(gv)))
8562                 /* sub Foo::bar { (shift)+1 } */
8563                 gv_method_changed(gv);
8564         }
8565         else if (name) {
8566             if (!SvROK(gv)) {
8567                 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8568                 prepare_SV_for_RV((SV *)gv);
8569                 SvOK_off((SV *)gv);
8570                 SvROK_on(gv);
8571             }
8572             SvRV_set(gv, (SV *)cv);
8573         }
8574     }
8575     if (!CvHASGV(cv)) {
8576         if (isGV(gv)) CvGV_set(cv, gv);
8577         else {
8578             dVAR;
8579             U32 hash;
8580             PERL_HASH(hash, name, namlen);
8581             CvNAME_HEK_set(cv, share_hek(name,
8582                                          name_is_utf8
8583                                             ? -(SSize_t)namlen
8584                                             :  (SSize_t)namlen,
8585                                          hash));
8586         }
8587         CvFILE_set_from_cop(cv, PL_curcop);
8588         CvSTASH_set(cv, PL_curstash);
8589     }
8590
8591     if (ps) {
8592         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8593         if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
8594     }
8595
8596     if (!block)
8597         goto attrs;
8598
8599     /* If we assign an optree to a PVCV, then we've defined a subroutine that
8600        the debugger could be able to set a breakpoint in, so signal to
8601        pp_entereval that it should not throw away any saved lines at scope
8602        exit.  */
8603
8604     PL_breakable_sub_gen++;
8605     CvROOT(cv) = block;
8606     CvROOT(cv)->op_private |= OPpREFCOUNTED;
8607     OpREFCNT_set(CvROOT(cv), 1);
8608     /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8609        itself has a refcount. */
8610     CvSLABBED_off(cv);
8611     OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8612 #ifdef PERL_DEBUG_READONLY_OPS
8613     slab = (OPSLAB *)CvSTART(cv);
8614 #endif
8615     CvSTART(cv) = start;
8616     CALL_PEEP(start);
8617     finalize_optree(CvROOT(cv));
8618     S_prune_chain_head(&CvSTART(cv));
8619
8620     /* now that optimizer has done its work, adjust pad values */
8621
8622     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8623
8624   attrs:
8625     if (attrs) {
8626         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8627         HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
8628                         ? GvSTASH(CvGV(cv))
8629                         : PL_curstash;
8630         if (!name) SAVEFREESV(cv);
8631         apply_attrs(stash, MUTABLE_SV(cv), attrs);
8632         if (!name) SvREFCNT_inc_simple_void_NN(cv);
8633     }
8634
8635     if (block && has_name) {
8636         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8637             SV * const tmpstr = cv_name(cv,NULL,0);
8638             GV * const db_postponed = gv_fetchpvs("DB::postponed",
8639                                                   GV_ADDMULTI, SVt_PVHV);
8640             HV *hv;
8641             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8642                                           CopFILE(PL_curcop),
8643                                           (long)PL_subline,
8644                                           (long)CopLINE(PL_curcop));
8645             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8646                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8647             hv = GvHVn(db_postponed);
8648             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8649                 CV * const pcv = GvCV(db_postponed);
8650                 if (pcv) {
8651                     dSP;
8652                     PUSHMARK(SP);
8653                     XPUSHs(tmpstr);
8654                     PUTBACK;
8655                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
8656                 }
8657             }
8658         }
8659
8660         if (name) {
8661             if (PL_parser && PL_parser->error_count)
8662                 clear_special_blocks(name, gv, cv);
8663             else
8664                 evanescent =
8665                     process_special_blocks(floor, name, gv, cv);
8666         }
8667     }
8668
8669   done:
8670     if (PL_parser)
8671         PL_parser->copline = NOLINE;
8672     LEAVE_SCOPE(floor);
8673     if (!evanescent) {
8674 #ifdef PERL_DEBUG_READONLY_OPS
8675       if (slab)
8676         Slab_to_ro(slab);
8677 #endif
8678       if (cv && name && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
8679         pad_add_weakref(cv);
8680     }
8681     return cv;
8682 }
8683
8684 STATIC void
8685 S_clear_special_blocks(pTHX_ const char *const fullname,
8686                        GV *const gv, CV *const cv) {
8687     const char *colon;
8688     const char *name;
8689
8690     PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
8691
8692     colon = strrchr(fullname,':');
8693     name = colon ? colon + 1 : fullname;
8694
8695     if ((*name == 'B' && strEQ(name, "BEGIN"))
8696         || (*name == 'E' && strEQ(name, "END"))
8697         || (*name == 'U' && strEQ(name, "UNITCHECK"))
8698         || (*name == 'C' && strEQ(name, "CHECK"))
8699         || (*name == 'I' && strEQ(name, "INIT"))) {
8700         if (!isGV(gv)) {
8701             (void)CvGV(cv);
8702             assert(isGV(gv));
8703         }
8704         GvCV_set(gv, NULL);
8705         SvREFCNT_dec_NN(MUTABLE_SV(cv));
8706     }
8707 }
8708
8709 /* Returns true if the sub has been freed.  */
8710 STATIC bool
8711 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
8712                          GV *const gv,
8713                          CV *const cv)
8714 {
8715     const char *const colon = strrchr(fullname,':');
8716     const char *const name = colon ? colon + 1 : fullname;
8717
8718     PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
8719
8720     if (*name == 'B') {
8721         if (strEQ(name, "BEGIN")) {
8722             const I32 oldscope = PL_scopestack_ix;
8723             dSP;
8724             (void)CvGV(cv);
8725             if (floor) LEAVE_SCOPE(floor);
8726             ENTER;
8727             PUSHSTACKi(PERLSI_REQUIRE);
8728             SAVECOPFILE(&PL_compiling);
8729             SAVECOPLINE(&PL_compiling);
8730             SAVEVPTR(PL_curcop);
8731
8732             DEBUG_x( dump_sub(gv) );
8733             Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
8734             GvCV_set(gv,0);             /* cv has been hijacked */
8735             call_list(oldscope, PL_beginav);
8736
8737             POPSTACK;
8738             LEAVE;
8739             return !PL_savebegin;
8740         }
8741         else
8742             return FALSE;
8743     } else {
8744         if (*name == 'E') {
8745             if strEQ(name, "END") {
8746                 DEBUG_x( dump_sub(gv) );
8747                 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
8748             } else
8749                 return FALSE;
8750         } else if (*name == 'U') {
8751             if (strEQ(name, "UNITCHECK")) {
8752                 /* It's never too late to run a unitcheck block */
8753                 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
8754             }
8755             else
8756                 return FALSE;
8757         } else if (*name == 'C') {
8758             if (strEQ(name, "CHECK")) {
8759                 if (PL_main_start)
8760                     /* diag_listed_as: Too late to run %s block */
8761                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8762                                    "Too late to run CHECK block");
8763                 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
8764             }
8765             else
8766                 return FALSE;
8767         } else if (*name == 'I') {
8768             if (strEQ(name, "INIT")) {
8769                 if (PL_main_start)
8770                     /* diag_listed_as: Too late to run %s block */
8771                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8772                                    "Too late to run INIT block");
8773                 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
8774             }
8775             else
8776                 return FALSE;
8777         } else
8778             return FALSE;
8779         DEBUG_x( dump_sub(gv) );
8780         (void)CvGV(cv);
8781         GvCV_set(gv,0);         /* cv has been hijacked */
8782         return FALSE;
8783     }
8784 }
8785
8786 /*
8787 =for apidoc newCONSTSUB
8788
8789 See L</newCONSTSUB_flags>.
8790
8791 =cut
8792 */
8793
8794 CV *
8795 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
8796 {
8797     return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
8798 }
8799
8800 /*
8801 =for apidoc newCONSTSUB_flags
8802
8803 Creates a constant sub equivalent to Perl S<C<sub FOO () { 123 }>> which is
8804 eligible for inlining at compile-time.
8805
8806 Currently, the only useful value for C<flags> is C<SVf_UTF8>.
8807
8808 The newly created subroutine takes ownership of a reference to the passed in
8809 SV.
8810
8811 Passing C<NULL> for SV creates a constant sub equivalent to S<C<sub BAR () {}>>,
8812 which won't be called if used as a destructor, but will suppress the overhead
8813 of a call to C<AUTOLOAD>.  (This form, however, isn't eligible for inlining at
8814 compile time.)
8815
8816 =cut
8817 */
8818
8819 CV *
8820 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
8821                              U32 flags, SV *sv)
8822 {
8823     CV* cv;
8824     const char *const file = CopFILE(PL_curcop);
8825
8826     ENTER;
8827
8828     if (IN_PERL_RUNTIME) {
8829         /* at runtime, it's not safe to manipulate PL_curcop: it may be
8830          * an op shared between threads. Use a non-shared COP for our
8831          * dirty work */
8832          SAVEVPTR(PL_curcop);
8833          SAVECOMPILEWARNINGS();
8834          PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
8835          PL_curcop = &PL_compiling;
8836     }
8837     SAVECOPLINE(PL_curcop);
8838     CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
8839
8840     SAVEHINTS();
8841     PL_hints &= ~HINT_BLOCK_SCOPE;
8842
8843     if (stash) {
8844         SAVEGENERICSV(PL_curstash);
8845         PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
8846     }
8847
8848     /* Protect sv against leakage caused by fatal warnings. */
8849     if (sv) SAVEFREESV(sv);
8850
8851     /* file becomes the CvFILE. For an XS, it's usually static storage,
8852        and so doesn't get free()d.  (It's expected to be from the C pre-
8853        processor __FILE__ directive). But we need a dynamically allocated one,
8854        and we need it to get freed.  */
8855     cv = newXS_len_flags(name, len,
8856                          sv && SvTYPE(sv) == SVt_PVAV
8857                              ? const_av_xsub
8858                              : const_sv_xsub,
8859                          file ? file : "", "",
8860                          &sv, XS_DYNAMIC_FILENAME | flags);
8861     CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
8862     CvCONST_on(cv);
8863
8864     LEAVE;
8865
8866     return cv;
8867 }
8868
8869 /*
8870 =for apidoc U||newXS
8871
8872 Used by C<xsubpp> to hook up XSUBs as Perl subs.  C<filename> needs to be
8873 static storage, as it is used directly as CvFILE(), without a copy being made.
8874
8875 =cut
8876 */
8877
8878 CV *
8879 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
8880 {
8881     PERL_ARGS_ASSERT_NEWXS;
8882     return newXS_len_flags(
8883         name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
8884     );
8885 }
8886
8887 CV *
8888 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
8889                  const char *const filename, const char *const proto,
8890                  U32 flags)
8891 {
8892     PERL_ARGS_ASSERT_NEWXS_FLAGS;
8893     return newXS_len_flags(
8894        name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
8895     );
8896 }
8897
8898 CV *
8899 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
8900 {
8901     PERL_ARGS_ASSERT_NEWXS_DEFFILE;
8902     return newXS_len_flags(
8903         name, strlen(name), subaddr, NULL, NULL, NULL, 0
8904     );
8905 }
8906
8907 CV *
8908 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
8909                            XSUBADDR_t subaddr, const char *const filename,
8910                            const char *const proto, SV **const_svp,
8911                            U32 flags)
8912 {
8913     CV *cv;
8914     bool interleave = FALSE;
8915
8916     PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
8917
8918     {
8919         GV * const gv = gv_fetchpvn(
8920                             name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
8921                             name ? len : PL_curstash ? sizeof("__ANON__") - 1:
8922                                 sizeof("__ANON__::__ANON__") - 1,
8923                             GV_ADDMULTI | flags, SVt_PVCV);
8924
8925         if ((cv = (name ? GvCV(gv) : NULL))) {
8926             if (GvCVGEN(gv)) {
8927                 /* just a cached method */
8928                 SvREFCNT_dec(cv);
8929                 cv = NULL;
8930             }
8931             else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
8932                 /* already defined (or promised) */
8933                 /* Redundant check that allows us to avoid creating an SV
8934                    most of the time: */
8935                 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
8936                     report_redefined_cv(newSVpvn_flags(
8937                                          name,len,(flags&SVf_UTF8)|SVs_TEMP
8938                                         ),
8939                                         cv, const_svp);
8940                 }
8941                 interleave = TRUE;
8942                 ENTER;
8943                 SAVEFREESV(cv);
8944                 cv = NULL;
8945             }
8946         }
8947
8948         if (cv)                         /* must reuse cv if autoloaded */
8949             cv_undef(cv);
8950         else {
8951             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8952             if (name) {
8953                 GvCV_set(gv,cv);
8954                 GvCVGEN(gv) = 0;
8955                 if (HvENAME_HEK(GvSTASH(gv)))
8956                     gv_method_changed(gv); /* newXS */
8957             }
8958         }
8959
8960         CvGV_set(cv, gv);
8961         if(filename) {
8962             /* XSUBs can't be perl lang/perl5db.pl debugged
8963             if (PERLDB_LINE_OR_SAVESRC)
8964                 (void)gv_fetchfile(filename); */
8965             assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
8966             if (flags & XS_DYNAMIC_FILENAME) {
8967                 CvDYNFILE_on(cv);
8968                 CvFILE(cv) = savepv(filename);
8969             } else {
8970             /* NOTE: not copied, as it is expected to be an external constant string */
8971                 CvFILE(cv) = (char *)filename;
8972             }
8973         } else {
8974             assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
8975             CvFILE(cv) = (char*)PL_xsubfilename;
8976         }
8977         CvISXSUB_on(cv);
8978         CvXSUB(cv) = subaddr;
8979 #ifndef PERL_IMPLICIT_CONTEXT
8980         CvHSCXT(cv) = &PL_stack_sp;
8981 #else
8982         PoisonPADLIST(cv);
8983 #endif
8984
8985         if (name)
8986             process_special_blocks(0, name, gv, cv);
8987         else
8988             CvANON_on(cv);
8989     } /* <- not a conditional branch */
8990
8991
8992     sv_setpv(MUTABLE_SV(cv), proto);
8993     if (interleave) LEAVE;
8994     return cv;
8995 }
8996
8997 CV *
8998 Perl_newSTUB(pTHX_ GV *gv, bool fake)
8999 {
9000     CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9001     GV *cvgv;
9002     PERL_ARGS_ASSERT_NEWSTUB;
9003     assert(!GvCVu(gv));
9004     GvCV_set(gv, cv);
9005     GvCVGEN(gv) = 0;
9006     if (!fake && HvENAME_HEK(GvSTASH(gv)))
9007         gv_method_changed(gv);
9008     if (SvFAKE(gv)) {
9009         cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
9010         SvFAKE_off(cvgv);
9011     }
9012     else cvgv = gv;
9013     CvGV_set(cv, cvgv);
9014     CvFILE_set_from_cop(cv, PL_curcop);
9015     CvSTASH_set(cv, PL_curstash);
9016     GvMULTI_on(gv);
9017     return cv;
9018 }
9019
9020 void
9021 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
9022 {
9023     CV *cv;
9024
9025     GV *gv;
9026
9027     if (PL_parser && PL_parser->error_count) {
9028         op_free(block);
9029         goto finish;
9030     }
9031
9032     gv = o
9033         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
9034         : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
9035
9036     GvMULTI_on(gv);
9037     if ((cv = GvFORM(gv))) {
9038         if (ckWARN(WARN_REDEFINE)) {
9039             const line_t oldline = CopLINE(PL_curcop);
9040             if (PL_parser && PL_parser->copline != NOLINE)
9041                 CopLINE_set(PL_curcop, PL_parser->copline);
9042             if (o) {
9043                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9044                             "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
9045             } else {
9046                 /* diag_listed_as: Format %s redefined */
9047                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9048                             "Format STDOUT redefined");
9049             }
9050             CopLINE_set(PL_curcop, oldline);
9051         }
9052         SvREFCNT_dec(cv);
9053     }
9054     cv = PL_compcv;
9055     GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
9056     CvGV_set(cv, gv);
9057     CvFILE_set_from_cop(cv, PL_curcop);
9058
9059
9060     pad_tidy(padtidy_FORMAT);
9061     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
9062     CvROOT(cv)->op_private |= OPpREFCOUNTED;
9063     OpREFCNT_set(CvROOT(cv), 1);
9064     CvSTART(cv) = LINKLIST(CvROOT(cv));
9065     CvROOT(cv)->op_next = 0;
9066     CALL_PEEP(CvSTART(cv));
9067     finalize_optree(CvROOT(cv));
9068     S_prune_chain_head(&CvSTART(cv));
9069     cv_forget_slab(cv);
9070
9071   finish:
9072     op_free(o);
9073     if (PL_parser)
9074         PL_parser->copline = NOLINE;
9075     LEAVE_SCOPE(floor);
9076     PL_compiling.cop_seq = 0;
9077 }
9078
9079 OP *
9080 Perl_newANONLIST(pTHX_ OP *o)
9081 {
9082     return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
9083 }
9084
9085 OP *
9086 Perl_newANONHASH(pTHX_ OP *o)
9087 {
9088     return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
9089 }
9090
9091 OP *
9092 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
9093 {
9094     return newANONATTRSUB(floor, proto, NULL, block);
9095 }
9096
9097 OP *
9098 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
9099 {
9100     SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
9101     OP * anoncode =
9102         newSVOP(OP_ANONCODE, 0,
9103                 cv);
9104     if (CvANONCONST(cv))
9105         anoncode = newUNOP(OP_ANONCONST, 0,
9106                            op_convert_list(OP_ENTERSUB,
9107                                            OPf_STACKED|OPf_WANT_SCALAR,
9108                                            anoncode));
9109     return newUNOP(OP_REFGEN, 0, anoncode);
9110 }
9111
9112 OP *
9113 Perl_oopsAV(pTHX_ OP *o)
9114 {
9115     dVAR;
9116
9117     PERL_ARGS_ASSERT_OOPSAV;
9118
9119     switch (o->op_type) {
9120     case OP_PADSV:
9121     case OP_PADHV:
9122         OpTYPE_set(o, OP_PADAV);
9123         return ref(o, OP_RV2AV);
9124
9125     case OP_RV2SV:
9126     case OP_RV2HV:
9127         OpTYPE_set(o, OP_RV2AV);
9128         ref(o, OP_RV2AV);
9129         break;
9130
9131     default:
9132         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
9133         break;
9134     }
9135     return o;
9136 }
9137
9138 OP *
9139 Perl_oopsHV(pTHX_ OP *o)
9140 {
9141     dVAR;
9142
9143     PERL_ARGS_ASSERT_OOPSHV;
9144
9145     switch (o->op_type) {
9146     case OP_PADSV:
9147     case OP_PADAV:
9148         OpTYPE_set(o, OP_PADHV);
9149         return ref(o, OP_RV2HV);
9150
9151     case OP_RV2SV:
9152     case OP_RV2AV:
9153         OpTYPE_set(o, OP_RV2HV);
9154         ref(o, OP_RV2HV);
9155         break;
9156
9157     default:
9158         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
9159         break;
9160     }
9161     return o;
9162 }
9163
9164 OP *
9165 Perl_newAVREF(pTHX_ OP *o)
9166 {
9167     dVAR;
9168
9169     PERL_ARGS_ASSERT_NEWAVREF;
9170
9171     if (o->op_type == OP_PADANY) {
9172         OpTYPE_set(o, OP_PADAV);
9173         return o;
9174     }
9175     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
9176         Perl_croak(aTHX_ "Can't use an array as a reference");
9177     }
9178     return newUNOP(OP_RV2AV, 0, scalar(o));
9179 }
9180
9181 OP *
9182 Perl_newGVREF(pTHX_ I32 type, OP *o)
9183 {
9184     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
9185         return newUNOP(OP_NULL, 0, o);
9186     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
9187 }
9188
9189 OP *
9190 Perl_newHVREF(pTHX_ OP *o)
9191 {
9192     dVAR;
9193
9194     PERL_ARGS_ASSERT_NEWHVREF;
9195
9196     if (o->op_type == OP_PADANY) {
9197         OpTYPE_set(o, OP_PADHV);
9198         return o;
9199     }
9200     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
9201         Perl_croak(aTHX_ "Can't use a hash as a reference");
9202     }
9203     return newUNOP(OP_RV2HV, 0, scalar(o));
9204 }
9205
9206 OP *
9207 Perl_newCVREF(pTHX_ I32 flags, OP *o)
9208 {
9209     if (o->op_type == OP_PADANY) {
9210         dVAR;
9211         OpTYPE_set(o, OP_PADCV);
9212     }
9213     return newUNOP(OP_RV2CV, flags, scalar(o));
9214 }
9215
9216 OP *
9217 Perl_newSVREF(pTHX_ OP *o)
9218 {
9219     dVAR;
9220
9221     PERL_ARGS_ASSERT_NEWSVREF;
9222
9223     if (o->op_type == OP_PADANY) {
9224         OpTYPE_set(o, OP_PADSV);
9225         scalar(o);
9226         return o;
9227     }
9228     return newUNOP(OP_RV2SV, 0, scalar(o));
9229 }
9230
9231 /* Check routines. See the comments at the top of this file for details
9232  * on when these are called */
9233
9234 OP *
9235 Perl_ck_anoncode(pTHX_ OP *o)
9236 {
9237     PERL_ARGS_ASSERT_CK_ANONCODE;
9238
9239     cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
9240     cSVOPo->op_sv = NULL;
9241     return o;
9242 }
9243
9244 static void
9245 S_io_hints(pTHX_ OP *o)
9246 {
9247 #if O_BINARY != 0 || O_TEXT != 0
9248     HV * const table =
9249         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
9250     if (table) {
9251         SV **svp = hv_fetchs(table, "open_IN", FALSE);
9252         if (svp && *svp) {
9253             STRLEN len = 0;
9254             const char *d = SvPV_const(*svp, len);
9255             const I32 mode = mode_from_discipline(d, len);
9256             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9257 #  if O_BINARY != 0
9258             if (mode & O_BINARY)
9259                 o->op_private |= OPpOPEN_IN_RAW;
9260 #  endif
9261 #  if O_TEXT != 0
9262             if (mode & O_TEXT)
9263                 o->op_private |= OPpOPEN_IN_CRLF;
9264 #  endif
9265         }
9266
9267         svp = hv_fetchs(table, "open_OUT", FALSE);
9268         if (svp && *svp) {
9269             STRLEN len = 0;
9270             const char *d = SvPV_const(*svp, len);
9271             const I32 mode = mode_from_discipline(d, len);
9272             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9273 #  if O_BINARY != 0
9274             if (mode & O_BINARY)
9275                 o->op_private |= OPpOPEN_OUT_RAW;
9276 #  endif
9277 #  if O_TEXT != 0
9278             if (mode & O_TEXT)
9279                 o->op_private |= OPpOPEN_OUT_CRLF;
9280 #  endif
9281         }
9282     }
9283 #else
9284     PERL_UNUSED_CONTEXT;
9285     PERL_UNUSED_ARG(o);
9286 #endif
9287 }
9288
9289 OP *
9290 Perl_ck_backtick(pTHX_ OP *o)
9291 {
9292     GV *gv;
9293     OP *newop = NULL;
9294     OP *sibl;
9295     PERL_ARGS_ASSERT_CK_BACKTICK;
9296     /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
9297     if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
9298      && (gv = gv_override("readpipe",8)))
9299     {
9300         /* detach rest of siblings from o and its first child */
9301         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
9302         newop = S_new_entersubop(aTHX_ gv, sibl);
9303     }
9304     else if (!(o->op_flags & OPf_KIDS))
9305         newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
9306     if (newop) {
9307         op_free(o);
9308         return newop;
9309     }
9310     S_io_hints(aTHX_ o);
9311     return o;
9312 }
9313
9314 OP *
9315 Perl_ck_bitop(pTHX_ OP *o)
9316 {
9317     PERL_ARGS_ASSERT_CK_BITOP;
9318
9319     o->op_private = (U8)(PL_hints & HINT_INTEGER);
9320
9321     if (o->op_type == OP_NBIT_OR     || o->op_type == OP_SBIT_OR
9322      || o->op_type == OP_NBIT_XOR    || o->op_type == OP_SBIT_XOR
9323      || o->op_type == OP_NBIT_AND    || o->op_type == OP_SBIT_AND
9324      || o->op_type == OP_NCOMPLEMENT || o->op_type == OP_SCOMPLEMENT)
9325         Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__BITWISE),
9326                               "The bitwise feature is experimental");
9327     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
9328             && OP_IS_INFIX_BIT(o->op_type))
9329     {
9330         const OP * const left = cBINOPo->op_first;
9331         const OP * const right = OpSIBLING(left);
9332         if ((OP_IS_NUMCOMPARE(left->op_type) &&
9333                 (left->op_flags & OPf_PARENS) == 0) ||
9334             (OP_IS_NUMCOMPARE(right->op_type) &&
9335                 (right->op_flags & OPf_PARENS) == 0))
9336             Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
9337                           "Possible precedence problem on bitwise %s operator",
9338                            o->op_type ==  OP_BIT_OR
9339                          ||o->op_type == OP_NBIT_OR  ? "|"
9340                         :  o->op_type ==  OP_BIT_AND
9341                          ||o->op_type == OP_NBIT_AND ? "&"
9342                         :  o->op_type ==  OP_BIT_XOR
9343                          ||o->op_type == OP_NBIT_XOR ? "^"
9344                         :  o->op_type == OP_SBIT_OR  ? "|."
9345                         :  o->op_type == OP_SBIT_AND ? "&." : "^."
9346                            );
9347     }
9348     return o;
9349 }
9350
9351 PERL_STATIC_INLINE bool
9352 is_dollar_bracket(pTHX_ const OP * const o)
9353 {
9354     const OP *kid;
9355     PERL_UNUSED_CONTEXT;
9356     return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
9357         && (kid = cUNOPx(o)->op_first)
9358         && kid->op_type == OP_GV
9359         && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
9360 }
9361
9362 OP *
9363 Perl_ck_cmp(pTHX_ OP *o)
9364 {
9365     PERL_ARGS_ASSERT_CK_CMP;
9366     if (ckWARN(WARN_SYNTAX)) {
9367         const OP *kid = cUNOPo->op_first;
9368         if (kid &&
9369             (
9370                 (   is_dollar_bracket(aTHX_ kid)
9371                  && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
9372                 )
9373              || (   kid->op_type == OP_CONST
9374                  && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
9375                 )
9376            )
9377         )
9378             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9379                         "$[ used in %s (did you mean $] ?)", OP_DESC(o));
9380     }
9381     return o;
9382 }
9383
9384 OP *
9385 Perl_ck_concat(pTHX_ OP *o)
9386 {
9387     const OP * const kid = cUNOPo->op_first;
9388
9389     PERL_ARGS_ASSERT_CK_CONCAT;
9390     PERL_UNUSED_CONTEXT;
9391
9392     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
9393             !(kUNOP->op_first->op_flags & OPf_MOD))
9394         o->op_flags |= OPf_STACKED;
9395     return o;
9396 }
9397
9398 OP *
9399 Perl_ck_spair(pTHX_ OP *o)
9400 {
9401     dVAR;
9402
9403     PERL_ARGS_ASSERT_CK_SPAIR;
9404
9405     if (o->op_flags & OPf_KIDS) {
9406         OP* newop;
9407         OP* kid;
9408         OP* kidkid;
9409         const OPCODE type = o->op_type;
9410         o = modkids(ck_fun(o), type);
9411         kid    = cUNOPo->op_first;
9412         kidkid = kUNOP->op_first;
9413         newop = OpSIBLING(kidkid);
9414         if (newop) {
9415             const OPCODE type = newop->op_type;
9416             if (OpHAS_SIBLING(newop))
9417                 return o;
9418             if (o->op_type == OP_REFGEN
9419              && (  type == OP_RV2CV
9420                 || (  !(newop->op_flags & OPf_PARENS)
9421                    && (  type == OP_RV2AV || type == OP_PADAV
9422                       || type == OP_RV2HV || type == OP_PADHV))))
9423                 NOOP; /* OK (allow srefgen for \@a and \%h) */
9424             else if (OP_GIMME(newop,0) != G_SCALAR)
9425                 return o;
9426         }
9427         /* excise first sibling */
9428         op_sibling_splice(kid, NULL, 1, NULL);
9429         op_free(kidkid);
9430     }
9431     /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
9432      * and OP_CHOMP into OP_SCHOMP */
9433     o->op_ppaddr = PL_ppaddr[++o->op_type];
9434     return ck_fun(o);
9435 }
9436
9437 OP *
9438 Perl_ck_delete(pTHX_ OP *o)
9439 {
9440     PERL_ARGS_ASSERT_CK_DELETE;
9441
9442     o = ck_fun(o);
9443     o->op_private = 0;
9444     if (o->op_flags & OPf_KIDS) {
9445         OP * const kid = cUNOPo->op_first;
9446         switch (kid->op_type) {
9447         case OP_ASLICE:
9448             o->op_flags |= OPf_SPECIAL;
9449             /* FALLTHROUGH */
9450         case OP_HSLICE:
9451             o->op_private |= OPpSLICE;
9452             break;
9453         case OP_AELEM:
9454             o->op_flags |= OPf_SPECIAL;
9455             /* FALLTHROUGH */
9456         case OP_HELEM:
9457             break;
9458         case OP_KVASLICE:
9459             Perl_croak(aTHX_ "delete argument is index/value array slice,"
9460                              " use array slice");
9461         case OP_KVHSLICE:
9462             Perl_croak(aTHX_ "delete argument is key/value hash slice, use"
9463                              " hash slice");
9464         default:
9465             Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
9466                              "element or slice");
9467         }
9468         if (kid->op_private & OPpLVAL_INTRO)
9469             o->op_private |= OPpLVAL_INTRO;
9470         op_null(kid);
9471     }
9472     return o;
9473 }
9474
9475 OP *
9476 Perl_ck_eof(pTHX_ OP *o)
9477 {
9478     PERL_ARGS_ASSERT_CK_EOF;
9479
9480     if (o->op_flags & OPf_KIDS) {
9481         OP *kid;
9482         if (cLISTOPo->op_first->op_type == OP_STUB) {
9483             OP * const newop
9484                 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
9485             op_free(o);
9486             o = newop;
9487         }
9488         o = ck_fun(o);
9489         kid = cLISTOPo->op_first;
9490         if (kid->op_type == OP_RV2GV)
9491             kid->op_private |= OPpALLOW_FAKE;
9492     }
9493     return o;
9494 }
9495
9496 OP *
9497 Perl_ck_eval(pTHX_ OP *o)
9498 {
9499     dVAR;
9500
9501     PERL_ARGS_ASSERT_CK_EVAL;
9502
9503     PL_hints |= HINT_BLOCK_SCOPE;
9504     if (o->op_flags & OPf_KIDS) {
9505         SVOP * const kid = (SVOP*)cUNOPo->op_first;
9506         assert(kid);
9507
9508         if (o->op_type == OP_ENTERTRY) {
9509             LOGOP *enter;
9510
9511             /* cut whole sibling chain free from o */
9512             op_sibling_splice(o, NULL, -1, NULL);
9513             op_free(o);
9514
9515             enter = S_alloc_LOGOP(aTHX_ OP_ENTERTRY, NULL, NULL);
9516
9517             /* establish postfix order */
9518             enter->op_next = (OP*)enter;
9519
9520             o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
9521             OpTYPE_set(o, OP_LEAVETRY);
9522             enter->op_other = o;
9523             return o;
9524         }
9525         else {
9526             scalar((OP*)kid);
9527             S_set_haseval(aTHX);
9528         }
9529     }
9530     else {
9531         const U8 priv = o->op_private;
9532         op_free(o);
9533         /* the newUNOP will recursively call ck_eval(), which will handle
9534          * all the stuff at the end of this function, like adding
9535          * OP_HINTSEVAL
9536          */
9537         return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
9538     }
9539     o->op_targ = (PADOFFSET)PL_hints;
9540     if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
9541     if ((PL_hints & HINT_LOCALIZE_HH) != 0
9542      && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
9543         /* Store a copy of %^H that pp_entereval can pick up. */
9544         OP *hhop = newSVOP(OP_HINTSEVAL, 0,
9545                            MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
9546         /* append hhop to only child  */
9547         op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
9548
9549         o->op_private |= OPpEVAL_HAS_HH;
9550     }
9551     if (!(o->op_private & OPpEVAL_BYTES)
9552          && FEATURE_UNIEVAL_IS_ENABLED)
9553             o->op_private |= OPpEVAL_UNICODE;
9554     return o;
9555 }
9556
9557 OP *
9558 Perl_ck_exec(pTHX_ OP *o)
9559 {
9560     PERL_ARGS_ASSERT_CK_EXEC;
9561
9562     if (o->op_flags & OPf_STACKED) {
9563         OP *kid;
9564         o = ck_fun(o);
9565         kid = OpSIBLING(cUNOPo->op_first);
9566         if (kid->op_type == OP_RV2GV)
9567             op_null(kid);
9568     }
9569     else
9570         o = listkids(o);
9571     return o;
9572 }
9573
9574 OP *
9575 Perl_ck_exists(pTHX_ OP *o)
9576 {
9577     PERL_ARGS_ASSERT_CK_EXISTS;
9578
9579     o = ck_fun(o);
9580     if (o->op_flags & OPf_KIDS) {
9581         OP * const kid = cUNOPo->op_first;
9582         if (kid->op_type == OP_ENTERSUB) {
9583             (void) ref(kid, o->op_type);
9584             if (kid->op_type != OP_RV2CV
9585                         && !(PL_parser && PL_parser->error_count))
9586                 Perl_croak(aTHX_
9587                           "exists argument is not a subroutine name");
9588             o->op_private |= OPpEXISTS_SUB;
9589         }
9590         else if (kid->op_type == OP_AELEM)
9591             o->op_flags |= OPf_SPECIAL;
9592         else if (kid->op_type != OP_HELEM)
9593             Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
9594                              "element or a subroutine");
9595         op_null(kid);
9596     }
9597     return o;
9598 }
9599
9600 OP *
9601 Perl_ck_rvconst(pTHX_ OP *o)
9602 {
9603     dVAR;
9604     SVOP * const kid = (SVOP*)cUNOPo->op_first;
9605
9606     PERL_ARGS_ASSERT_CK_RVCONST;
9607
9608     o->op_private |= (PL_hints & HINT_STRICT_REFS);
9609
9610     if (kid->op_type == OP_CONST) {
9611         int iscv;
9612         GV *gv;
9613         SV * const kidsv = kid->op_sv;
9614
9615         /* Is it a constant from cv_const_sv()? */
9616         if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
9617             return o;
9618         }
9619         if (SvTYPE(kidsv) == SVt_PVAV) return o;
9620         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
9621             const char *badthing;
9622             switch (o->op_type) {
9623             case OP_RV2SV:
9624                 badthing = "a SCALAR";
9625                 break;
9626             case OP_RV2AV:
9627                 badthing = "an ARRAY";
9628                 break;
9629             case OP_RV2HV:
9630                 badthing = "a HASH";
9631                 break;
9632             default:
9633                 badthing = NULL;
9634                 break;
9635             }
9636             if (badthing)
9637                 Perl_croak(aTHX_
9638                            "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
9639                            SVfARG(kidsv), badthing);
9640         }
9641         /*
9642          * This is a little tricky.  We only want to add the symbol if we
9643          * didn't add it in the lexer.  Otherwise we get duplicate strict
9644          * warnings.  But if we didn't add it in the lexer, we must at
9645          * least pretend like we wanted to add it even if it existed before,
9646          * or we get possible typo warnings.  OPpCONST_ENTERED says
9647          * whether the lexer already added THIS instance of this symbol.
9648          */
9649         iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
9650         gv = gv_fetchsv(kidsv,
9651                 o->op_type == OP_RV2CV
9652                         && o->op_private & OPpMAY_RETURN_CONSTANT
9653                     ? GV_NOEXPAND
9654                     : iscv | !(kid->op_private & OPpCONST_ENTERED),
9655                 iscv
9656                     ? SVt_PVCV
9657                     : o->op_type == OP_RV2SV
9658                         ? SVt_PV
9659                         : o->op_type == OP_RV2AV
9660                             ? SVt_PVAV
9661                             : o->op_type == OP_RV2HV
9662                                 ? SVt_PVHV
9663                                 : SVt_PVGV);
9664         if (gv) {
9665             if (!isGV(gv)) {
9666                 assert(iscv);
9667                 assert(SvROK(gv));
9668                 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
9669                   && SvTYPE(SvRV(gv)) != SVt_PVCV)
9670                     gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
9671             }
9672             OpTYPE_set(kid, OP_GV);
9673             SvREFCNT_dec(kid->op_sv);
9674 #ifdef USE_ITHREADS
9675             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
9676             STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
9677             kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
9678             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
9679             PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
9680 #else
9681             kid->op_sv = SvREFCNT_inc_simple_NN(gv);
9682 #endif
9683             kid->op_private = 0;
9684             /* FAKE globs in the symbol table cause weird bugs (#77810) */
9685             SvFAKE_off(gv);
9686         }
9687     }
9688     return o;
9689 }
9690
9691 OP *
9692 Perl_ck_ftst(pTHX_ OP *o)
9693 {
9694     dVAR;
9695     const I32 type = o->op_type;
9696
9697     PERL_ARGS_ASSERT_CK_FTST;
9698
9699     if (o->op_flags & OPf_REF) {
9700         NOOP;
9701     }
9702     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
9703         SVOP * const kid = (SVOP*)cUNOPo->op_first;
9704         const OPCODE kidtype = kid->op_type;
9705
9706         if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
9707          && !kid->op_folded) {
9708             OP * const newop = newGVOP(type, OPf_REF,
9709                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
9710             op_free(o);
9711             return newop;
9712         }
9713         if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
9714             o->op_private |= OPpFT_ACCESS;
9715         if (type != OP_STAT && type != OP_LSTAT
9716             && PL_check[kidtype] == Perl_ck_ftst
9717             && kidtype != OP_STAT && kidtype != OP_LSTAT
9718         ) {
9719             o->op_private |= OPpFT_STACKED;
9720             kid->op_private |= OPpFT_STACKING;
9721             if (kidtype == OP_FTTTY && (
9722                    !(kid->op_private & OPpFT_STACKED)
9723                 || kid->op_private & OPpFT_AFTER_t
9724                ))
9725                 o->op_private |= OPpFT_AFTER_t;
9726         }
9727     }
9728     else {
9729         op_free(o);
9730         if (type == OP_FTTTY)
9731             o = newGVOP(type, OPf_REF, PL_stdingv);
9732         else
9733             o = newUNOP(type, 0, newDEFSVOP());
9734     }
9735     return o;
9736 }
9737
9738 OP *
9739 Perl_ck_fun(pTHX_ OP *o)
9740 {
9741     const int type = o->op_type;
9742     I32 oa = PL_opargs[type] >> OASHIFT;
9743
9744     PERL_ARGS_ASSERT_CK_FUN;
9745
9746     if (o->op_flags & OPf_STACKED) {
9747         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
9748             oa &= ~OA_OPTIONAL;
9749         else
9750             return no_fh_allowed(o);
9751     }
9752
9753     if (o->op_flags & OPf_KIDS) {
9754         OP *prev_kid = NULL;
9755         OP *kid = cLISTOPo->op_first;
9756         I32 numargs = 0;
9757         bool seen_optional = FALSE;
9758
9759         if (kid->op_type == OP_PUSHMARK ||
9760             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
9761         {
9762             prev_kid = kid;
9763             kid = OpSIBLING(kid);
9764         }
9765         if (kid && kid->op_type == OP_COREARGS) {
9766             bool optional = FALSE;
9767             while (oa) {
9768                 numargs++;
9769                 if (oa & OA_OPTIONAL) optional = TRUE;
9770                 oa = oa >> 4;
9771             }
9772             if (optional) o->op_private |= numargs;
9773             return o;
9774         }
9775
9776         while (oa) {
9777             if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
9778                 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
9779                     kid = newDEFSVOP();
9780                     /* append kid to chain */
9781                     op_sibling_splice(o, prev_kid, 0, kid);
9782                 }
9783                 seen_optional = TRUE;
9784             }
9785             if (!kid) break;
9786
9787             numargs++;
9788             switch (oa & 7) {
9789             case OA_SCALAR:
9790                 /* list seen where single (scalar) arg expected? */
9791                 if (numargs == 1 && !(oa >> 4)
9792                     && kid->op_type == OP_LIST && type != OP_SCALAR)
9793                 {
9794                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
9795                 }
9796                 if (type != OP_DELETE) scalar(kid);
9797                 break;
9798             case OA_LIST:
9799                 if (oa < 16) {
9800                     kid = 0;
9801                     continue;
9802                 }
9803                 else
9804                     list(kid);
9805                 break;
9806             case OA_AVREF:
9807                 if ((type == OP_PUSH || type == OP_UNSHIFT)
9808                     && !OpHAS_SIBLING(kid))
9809                     Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
9810                                    "Useless use of %s with no values",
9811                                    PL_op_desc[type]);
9812
9813                 if (kid->op_type == OP_CONST
9814                       && (  !SvROK(cSVOPx_sv(kid))
9815                          || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV  )
9816                         )
9817                     bad_type_pv(numargs, "array", o, kid);
9818                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
9819                     yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
9820                                          PL_op_desc[type]), 0);
9821                 }
9822                 else {
9823                     op_lvalue(kid, type);
9824                 }
9825                 break;
9826             case OA_HVREF:
9827                 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
9828                     bad_type_pv(numargs, "hash", o, kid);
9829                 op_lvalue(kid, type);
9830                 break;
9831             case OA_CVREF:
9832                 {
9833                     /* replace kid with newop in chain */
9834                     OP * const newop =
9835                         S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
9836                     newop->op_next = newop;
9837                     kid = newop;
9838                 }
9839                 break;
9840             case OA_FILEREF:
9841                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
9842                     if (kid->op_type == OP_CONST &&
9843                         (kid->op_private & OPpCONST_BARE))
9844                     {
9845                         OP * const newop = newGVOP(OP_GV, 0,
9846                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
9847                         /* replace kid with newop in chain */
9848                         op_sibling_splice(o, prev_kid, 1, newop);
9849                         op_free(kid);
9850                         kid = newop;
9851                     }
9852                     else if (kid->op_type == OP_READLINE) {
9853                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
9854                         bad_type_pv(numargs, "HANDLE", o, kid);
9855                     }
9856                     else {
9857                         I32 flags = OPf_SPECIAL;
9858                         I32 priv = 0;
9859                         PADOFFSET targ = 0;
9860
9861                         /* is this op a FH constructor? */
9862                         if (is_handle_constructor(o,numargs)) {
9863                             const char *name = NULL;
9864                             STRLEN len = 0;
9865                             U32 name_utf8 = 0;
9866                             bool want_dollar = TRUE;
9867
9868                             flags = 0;
9869                             /* Set a flag to tell rv2gv to vivify
9870                              * need to "prove" flag does not mean something
9871                              * else already - NI-S 1999/05/07
9872                              */
9873                             priv = OPpDEREF;
9874                             if (kid->op_type == OP_PADSV) {
9875                                 PADNAME * const pn
9876                                     = PAD_COMPNAME_SV(kid->op_targ);
9877                                 name = PadnamePV (pn);
9878                                 len  = PadnameLEN(pn);
9879                                 name_utf8 = PadnameUTF8(pn);
9880                             }
9881                             else if (kid->op_type == OP_RV2SV
9882                                      && kUNOP->op_first->op_type == OP_GV)
9883                             {
9884                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
9885                                 name = GvNAME(gv);
9886                                 len = GvNAMELEN(gv);
9887                                 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
9888                             }
9889                             else if (kid->op_type == OP_AELEM
9890                                      || kid->op_type == OP_HELEM)
9891                             {
9892                                  OP *firstop;
9893                                  OP *op = ((BINOP*)kid)->op_first;
9894                                  name = NULL;
9895                                  if (op) {
9896                                       SV *tmpstr = NULL;
9897                                       const char * const a =
9898                                            kid->op_type == OP_AELEM ?
9899                                            "[]" : "{}";
9900                                       if (((op->op_type == OP_RV2AV) ||
9901                                            (op->op_type == OP_RV2HV)) &&
9902                                           (firstop = ((UNOP*)op)->op_first) &&
9903                                           (firstop->op_type == OP_GV)) {
9904                                            /* packagevar $a[] or $h{} */
9905                                            GV * const gv = cGVOPx_gv(firstop);
9906                                            if (gv)
9907                                                 tmpstr =
9908                                                      Perl_newSVpvf(aTHX_
9909                                                                    "%s%c...%c",
9910                                                                    GvNAME(gv),
9911                                                                    a[0], a[1]);
9912                                       }
9913                                       else if (op->op_type == OP_PADAV
9914                                                || op->op_type == OP_PADHV) {
9915                                            /* lexicalvar $a[] or $h{} */
9916                                            const char * const padname =
9917                                                 PAD_COMPNAME_PV(op->op_targ);
9918                                            if (padname)
9919                                                 tmpstr =
9920                                                      Perl_newSVpvf(aTHX_
9921                                                                    "%s%c...%c",
9922                                                                    padname + 1,
9923                                                                    a[0], a[1]);
9924                                       }
9925                                       if (tmpstr) {
9926                                            name = SvPV_const(tmpstr, len);
9927                                            name_utf8 = SvUTF8(tmpstr);
9928                                            sv_2mortal(tmpstr);
9929                                       }
9930                                  }
9931                                  if (!name) {
9932                                       name = "__ANONIO__";
9933                                       len = 10;
9934                                       want_dollar = FALSE;
9935                                  }
9936                                  op_lvalue(kid, type);
9937                             }
9938                             if (name) {
9939                                 SV *namesv;
9940                                 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
9941                                 namesv = PAD_SVl(targ);
9942                                 if (want_dollar && *name != '$')
9943                                     sv_setpvs(namesv, "$");
9944                                 else
9945                                     sv_setpvs(namesv, "");
9946                                 sv_catpvn(namesv, name, len);
9947                                 if ( name_utf8 ) SvUTF8_on(namesv);
9948                             }
9949                         }
9950                         scalar(kid);
9951                         kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
9952                                     OP_RV2GV, flags);
9953                         kid->op_targ = targ;
9954                         kid->op_private |= priv;
9955                     }
9956                 }
9957                 scalar(kid);
9958                 break;
9959             case OA_SCALARREF:
9960                 if ((type == OP_UNDEF || type == OP_POS)
9961                     && numargs == 1 && !(oa >> 4)
9962                     && kid->op_type == OP_LIST)
9963                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
9964                 op_lvalue(scalar(kid), type);
9965                 break;
9966             }
9967             oa >>= 4;
9968             prev_kid = kid;
9969             kid = OpSIBLING(kid);
9970         }
9971         /* FIXME - should the numargs or-ing move after the too many
9972          * arguments check? */
9973         o->op_private |= numargs;
9974         if (kid)
9975             return too_many_arguments_pv(o,OP_DESC(o), 0);
9976         listkids(o);
9977     }
9978     else if (PL_opargs[type] & OA_DEFGV) {
9979         /* Ordering of these two is important to keep f_map.t passing.  */
9980         op_free(o);
9981         return newUNOP(type, 0, newDEFSVOP());
9982     }
9983
9984     if (oa) {
9985         while (oa & OA_OPTIONAL)
9986             oa >>= 4;
9987         if (oa && oa != OA_LIST)
9988             return too_few_arguments_pv(o,OP_DESC(o), 0);
9989     }
9990     return o;
9991 }
9992
9993 OP *
9994 Perl_ck_glob(pTHX_ OP *o)
9995 {
9996     GV *gv;
9997
9998     PERL_ARGS_ASSERT_CK_GLOB;
9999
10000     o = ck_fun(o);
10001     if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
10002         op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
10003
10004     if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
10005     {
10006         /* convert
10007          *     glob
10008          *       \ null - const(wildcard)
10009          * into
10010          *     null
10011          *       \ enter
10012          *            \ list
10013          *                 \ mark - glob - rv2cv
10014          *                             |        \ gv(CORE::GLOBAL::glob)
10015          *                             |
10016          *                              \ null - const(wildcard)
10017          */
10018         o->op_flags |= OPf_SPECIAL;
10019         o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
10020         o = S_new_entersubop(aTHX_ gv, o);
10021         o = newUNOP(OP_NULL, 0, o);
10022         o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
10023         return o;
10024     }
10025     else o->op_flags &= ~OPf_SPECIAL;
10026 #if !defined(PERL_EXTERNAL_GLOB)
10027     if (!PL_globhook) {
10028         ENTER;
10029         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
10030                                newSVpvs("File::Glob"), NULL, NULL, NULL);
10031         LEAVE;
10032     }
10033 #endif /* !PERL_EXTERNAL_GLOB */
10034     gv = (GV *)newSV(0);
10035     gv_init(gv, 0, "", 0, 0);
10036     gv_IOadd(gv);
10037     op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
10038     SvREFCNT_dec_NN(gv); /* newGVOP increased it */
10039     scalarkids(o);
10040     return o;
10041 }
10042
10043 OP *
10044 Perl_ck_grep(pTHX_ OP *o)
10045 {
10046     LOGOP *gwop;
10047     OP *kid;
10048     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
10049     PADOFFSET offset;
10050
10051     PERL_ARGS_ASSERT_CK_GREP;
10052
10053     /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
10054
10055     if (o->op_flags & OPf_STACKED) {
10056         kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
10057         if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
10058             return no_fh_allowed(o);
10059         o->op_flags &= ~OPf_STACKED;
10060     }
10061     kid = OpSIBLING(cLISTOPo->op_first);
10062     if (type == OP_MAPWHILE)
10063         list(kid);
10064     else
10065         scalar(kid);
10066     o = ck_fun(o);
10067     if (PL_parser && PL_parser->error_count)
10068         return o;
10069     kid = OpSIBLING(cLISTOPo->op_first);
10070     if (kid->op_type != OP_NULL)
10071         Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
10072     kid = kUNOP->op_first;
10073
10074     gwop = S_alloc_LOGOP(aTHX_ type, o, LINKLIST(kid));
10075     kid->op_next = (OP*)gwop;
10076     offset = pad_findmy_pvs("$_", 0);
10077     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
10078         o->op_private = gwop->op_private = 0;
10079         gwop->op_targ = pad_alloc(type, SVs_PADTMP);
10080     }
10081     else {
10082         o->op_private = gwop->op_private = OPpGREP_LEX;
10083         gwop->op_targ = o->op_targ = offset;
10084     }
10085
10086     kid = OpSIBLING(cLISTOPo->op_first);
10087     for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
10088         op_lvalue(kid, OP_GREPSTART);
10089
10090     return (OP*)gwop;
10091 }
10092
10093 OP *
10094 Perl_ck_index(pTHX_ OP *o)
10095 {
10096     PERL_ARGS_ASSERT_CK_INDEX;
10097
10098     if (o->op_flags & OPf_KIDS) {
10099         OP *kid = OpSIBLING(cLISTOPo->op_first);        /* get past pushmark */
10100         if (kid)
10101             kid = OpSIBLING(kid);                       /* get past "big" */
10102         if (kid && kid->op_type == OP_CONST) {
10103             const bool save_taint = TAINT_get;
10104             SV *sv = kSVOP->op_sv;
10105             if ((!SvPOK(sv) || SvNIOKp(sv)) && SvOK(sv) && !SvROK(sv)) {
10106                 sv = newSV(0);
10107                 sv_copypv(sv, kSVOP->op_sv);
10108                 SvREFCNT_dec_NN(kSVOP->op_sv);
10109                 kSVOP->op_sv = sv;
10110             }
10111             if (SvOK(sv)) fbm_compile(sv, 0);
10112             TAINT_set(save_taint);
10113 #ifdef NO_TAINT_SUPPORT
10114             PERL_UNUSED_VAR(save_taint);
10115 #endif
10116         }
10117     }
10118     return ck_fun(o);
10119 }
10120
10121 OP *
10122 Perl_ck_lfun(pTHX_ OP *o)
10123 {
10124     const OPCODE type = o->op_type;
10125
10126     PERL_ARGS_ASSERT_CK_LFUN;
10127
10128     return modkids(ck_fun(o), type);
10129 }
10130
10131 OP *
10132 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
10133 {
10134     PERL_ARGS_ASSERT_CK_DEFINED;
10135
10136     if ((o->op_flags & OPf_KIDS)) {
10137         switch (cUNOPo->op_first->op_type) {
10138         case OP_RV2AV:
10139         case OP_PADAV:
10140             Perl_croak(aTHX_ "Can't use 'defined(@array)'"
10141                              " (Maybe you should just omit the defined()?)");
10142         break;
10143         case OP_RV2HV:
10144         case OP_PADHV:
10145             Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
10146                              " (Maybe you should just omit the defined()?)");
10147             break;
10148         default:
10149             /* no warning */
10150             break;
10151         }
10152     }
10153     return ck_rfun(o);
10154 }
10155
10156 OP *
10157 Perl_ck_readline(pTHX_ OP *o)
10158 {
10159     PERL_ARGS_ASSERT_CK_READLINE;
10160
10161     if (o->op_flags & OPf_KIDS) {
10162          OP *kid = cLISTOPo->op_first;
10163          if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
10164     }
10165     else {
10166         OP * const newop
10167             = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
10168         op_free(o);
10169         return newop;
10170     }
10171     return o;
10172 }
10173
10174 OP *
10175 Perl_ck_rfun(pTHX_ OP *o)
10176 {
10177     const OPCODE type = o->op_type;
10178
10179     PERL_ARGS_ASSERT_CK_RFUN;
10180
10181     return refkids(ck_fun(o), type);
10182 }
10183
10184 OP *
10185 Perl_ck_listiob(pTHX_ OP *o)
10186 {
10187     OP *kid;
10188
10189     PERL_ARGS_ASSERT_CK_LISTIOB;
10190
10191     kid = cLISTOPo->op_first;
10192     if (!kid) {
10193         o = force_list(o, 1);
10194         kid = cLISTOPo->op_first;
10195     }
10196     if (kid->op_type == OP_PUSHMARK)
10197         kid = OpSIBLING(kid);
10198     if (kid && o->op_flags & OPf_STACKED)
10199         kid = OpSIBLING(kid);
10200     else if (kid && !OpHAS_SIBLING(kid)) {              /* print HANDLE; */
10201         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
10202          && !kid->op_folded) {
10203             o->op_flags |= OPf_STACKED; /* make it a filehandle */
10204             scalar(kid);
10205             /* replace old const op with new OP_RV2GV parent */
10206             kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
10207                                         OP_RV2GV, OPf_REF);
10208             kid = OpSIBLING(kid);
10209         }
10210     }
10211
10212     if (!kid)
10213         op_append_elem(o->op_type, o, newDEFSVOP());
10214
10215     if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
10216     return listkids(o);
10217 }
10218
10219 OP *
10220 Perl_ck_smartmatch(pTHX_ OP *o)
10221 {
10222     dVAR;
10223     PERL_ARGS_ASSERT_CK_SMARTMATCH;
10224     if (0 == (o->op_flags & OPf_SPECIAL)) {
10225         OP *first  = cBINOPo->op_first;
10226         OP *second = OpSIBLING(first);
10227
10228         /* Implicitly take a reference to an array or hash */
10229
10230         /* remove the original two siblings, then add back the
10231          * (possibly different) first and second sibs.
10232          */
10233         op_sibling_splice(o, NULL, 1, NULL);
10234         op_sibling_splice(o, NULL, 1, NULL);
10235         first  = ref_array_or_hash(first);
10236         second = ref_array_or_hash(second);
10237         op_sibling_splice(o, NULL, 0, second);
10238         op_sibling_splice(o, NULL, 0, first);
10239
10240         /* Implicitly take a reference to a regular expression */
10241         if (first->op_type == OP_MATCH) {
10242             OpTYPE_set(first, OP_QR);
10243         }
10244         if (second->op_type == OP_MATCH) {
10245             OpTYPE_set(second, OP_QR);
10246         }
10247     }
10248
10249     return o;
10250 }
10251
10252
10253 static OP *
10254 S_maybe_targlex(pTHX_ OP *o)
10255 {
10256     OP * const kid = cLISTOPo->op_first;
10257     /* has a disposable target? */
10258     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
10259         && !(kid->op_flags & OPf_STACKED)
10260         /* Cannot steal the second time! */
10261         && !(kid->op_private & OPpTARGET_MY)
10262         )
10263     {
10264         OP * const kkid = OpSIBLING(kid);
10265
10266         /* Can just relocate the target. */
10267         if (kkid && kkid->op_type == OP_PADSV
10268             && (!(kkid->op_private & OPpLVAL_INTRO)
10269                || kkid->op_private & OPpPAD_STATE))
10270         {
10271             kid->op_targ = kkid->op_targ;
10272             kkid->op_targ = 0;
10273             /* Now we do not need PADSV and SASSIGN.
10274              * Detach kid and free the rest. */
10275             op_sibling_splice(o, NULL, 1, NULL);
10276             op_free(o);
10277             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
10278             return kid;
10279         }
10280     }
10281     return o;
10282 }
10283
10284 OP *
10285 Perl_ck_sassign(pTHX_ OP *o)
10286 {
10287     dVAR;
10288     OP * const kid = cLISTOPo->op_first;
10289
10290     PERL_ARGS_ASSERT_CK_SASSIGN;
10291
10292     if (OpHAS_SIBLING(kid)) {
10293         OP *kkid = OpSIBLING(kid);
10294         /* For state variable assignment with attributes, kkid is a list op
10295            whose op_last is a padsv. */
10296         if ((kkid->op_type == OP_PADSV ||
10297              (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
10298               (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
10299              )
10300             )
10301                 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
10302                     == (OPpLVAL_INTRO|OPpPAD_STATE)) {
10303             const PADOFFSET target = kkid->op_targ;
10304             OP *const other = newOP(OP_PADSV,
10305                                     kkid->op_flags
10306                                     | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
10307             OP *const first = newOP(OP_NULL, 0);
10308             OP *const nullop =
10309                 newCONDOP(0, first, o, other);
10310             /* XXX targlex disabled for now; see ticket #124160
10311                 newCONDOP(0, first, S_maybe_targlex(aTHX_ o), other);
10312              */
10313             OP *const condop = first->op_next;
10314
10315             OpTYPE_set(condop, OP_ONCE);
10316             other->op_targ = target;
10317             nullop->op_flags |= OPf_WANT_SCALAR;
10318
10319             /* Store the initializedness of state vars in a separate
10320                pad entry.  */
10321             condop->op_targ =
10322               pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
10323             /* hijacking PADSTALE for uninitialized state variables */
10324             SvPADSTALE_on(PAD_SVl(condop->op_targ));
10325
10326             return nullop;
10327         }
10328     }
10329     return S_maybe_targlex(aTHX_ o);
10330 }
10331
10332 OP *
10333 Perl_ck_match(pTHX_ OP *o)
10334 {
10335     PERL_ARGS_ASSERT_CK_MATCH;
10336
10337     if (o->op_type != OP_QR && PL_compcv) {
10338         const PADOFFSET offset = pad_findmy_pvs("$_", 0);
10339         if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
10340             o->op_targ = offset;
10341             o->op_private |= OPpTARGET_MY;
10342         }
10343     }
10344     if (o->op_type == OP_MATCH || o->op_type == OP_QR)
10345         o->op_private |= OPpRUNTIME;
10346     return o;
10347 }
10348
10349 OP *
10350 Perl_ck_method(pTHX_ OP *o)
10351 {
10352     SV *sv, *methsv, *rclass;
10353     const char* method;
10354     char* compatptr;
10355     int utf8;
10356     STRLEN len, nsplit = 0, i;
10357     OP* new_op;
10358     OP * const kid = cUNOPo->op_first;
10359
10360     PERL_ARGS_ASSERT_CK_METHOD;
10361     if (kid->op_type != OP_CONST) return o;
10362
10363     sv = kSVOP->op_sv;
10364
10365     /* replace ' with :: */
10366     while ((compatptr = strchr(SvPVX(sv), '\''))) {
10367         *compatptr = ':';
10368         sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
10369     }
10370
10371     method = SvPVX_const(sv);
10372     len = SvCUR(sv);
10373     utf8 = SvUTF8(sv) ? -1 : 1;
10374
10375     for (i = len - 1; i > 0; --i) if (method[i] == ':') {
10376         nsplit = i+1;
10377         break;
10378     }
10379
10380     methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
10381
10382     if (!nsplit) { /* $proto->method() */
10383         op_free(o);
10384         return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
10385     }
10386
10387     if (nsplit == 7 && memEQ(method, "SUPER::", nsplit)) { /* $proto->SUPER::method() */
10388         op_free(o);
10389         return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
10390     }
10391
10392     /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
10393     if (nsplit >= 9 && strnEQ(method+nsplit-9, "::SUPER::", 9)) {
10394         rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
10395         new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
10396     } else {
10397         rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
10398         new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
10399     }
10400 #ifdef USE_ITHREADS
10401     op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
10402 #else
10403     cMETHOPx(new_op)->op_rclass_sv = rclass;
10404 #endif
10405     op_free(o);
10406     return new_op;
10407 }
10408
10409 OP *
10410 Perl_ck_null(pTHX_ OP *o)
10411 {
10412     PERL_ARGS_ASSERT_CK_NULL;
10413     PERL_UNUSED_CONTEXT;
10414     return o;
10415 }
10416
10417 OP *
10418 Perl_ck_open(pTHX_ OP *o)
10419 {
10420     PERL_ARGS_ASSERT_CK_OPEN;
10421
10422     S_io_hints(aTHX_ o);
10423     {
10424          /* In case of three-arg dup open remove strictness
10425           * from the last arg if it is a bareword. */
10426          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
10427          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
10428          OP *oa;
10429          const char *mode;
10430
10431          if ((last->op_type == OP_CONST) &&             /* The bareword. */
10432              (last->op_private & OPpCONST_BARE) &&
10433              (last->op_private & OPpCONST_STRICT) &&
10434              (oa = OpSIBLING(first)) &&         /* The fh. */
10435              (oa = OpSIBLING(oa)) &&                    /* The mode. */
10436              (oa->op_type == OP_CONST) &&
10437              SvPOK(((SVOP*)oa)->op_sv) &&
10438              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
10439              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
10440              (last == OpSIBLING(oa)))                   /* The bareword. */
10441               last->op_private &= ~OPpCONST_STRICT;
10442     }
10443     return ck_fun(o);
10444 }
10445
10446 OP *
10447 Perl_ck_prototype(pTHX_ OP *o)
10448 {
10449     PERL_ARGS_ASSERT_CK_PROTOTYPE;
10450     if (!(o->op_flags & OPf_KIDS)) {
10451         op_free(o);
10452         return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
10453     }
10454     return o;
10455 }
10456
10457 OP *
10458 Perl_ck_refassign(pTHX_ OP *o)
10459 {
10460     OP * const right = cLISTOPo->op_first;
10461     OP * const left = OpSIBLING(right);
10462     OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
10463     bool stacked = 0;
10464
10465     PERL_ARGS_ASSERT_CK_REFASSIGN;
10466     assert (left);
10467     assert (left->op_type == OP_SREFGEN);
10468
10469     o->op_private = 0;
10470     /* we use OPpPAD_STATE in refassign to mean either of those things,
10471      * and the code assumes the two flags occupy the same bit position
10472      * in the various ops below */
10473     assert(OPpPAD_STATE == OPpOUR_INTRO);
10474
10475     switch (varop->op_type) {
10476     case OP_PADAV:
10477         o->op_private |= OPpLVREF_AV;
10478         goto settarg;
10479     case OP_PADHV:
10480         o->op_private |= OPpLVREF_HV;
10481         /* FALLTHROUGH */
10482     case OP_PADSV:
10483       settarg:
10484         o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
10485         o->op_targ = varop->op_targ;
10486         varop->op_targ = 0;
10487         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
10488         break;
10489
10490     case OP_RV2AV:
10491         o->op_private |= OPpLVREF_AV;
10492         goto checkgv;
10493         NOT_REACHED; /* NOTREACHED */
10494     case OP_RV2HV:
10495         o->op_private |= OPpLVREF_HV;
10496         /* FALLTHROUGH */
10497     case OP_RV2SV:
10498       checkgv:
10499         o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
10500         if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
10501       detach_and_stack:
10502         /* Point varop to its GV kid, detached.  */
10503         varop = op_sibling_splice(varop, NULL, -1, NULL);
10504         stacked = TRUE;
10505         break;
10506     case OP_RV2CV: {
10507         OP * const kidparent =
10508             OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
10509         OP * const kid = cUNOPx(kidparent)->op_first;
10510         o->op_private |= OPpLVREF_CV;
10511         if (kid->op_type == OP_GV) {
10512             varop = kidparent;
10513             goto detach_and_stack;
10514         }
10515         if (kid->op_type != OP_PADCV)   goto bad;
10516         o->op_targ = kid->op_targ;
10517         kid->op_targ = 0;
10518         break;
10519     }
10520     case OP_AELEM:
10521     case OP_HELEM:
10522         o->op_private |= (varop->op_private & OPpLVAL_INTRO);
10523         o->op_private |= OPpLVREF_ELEM;
10524         op_null(varop);
10525         stacked = TRUE;
10526         /* Detach varop.  */
10527         op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
10528         break;
10529     default:
10530       bad:
10531         /* diag_listed_as: Can't modify reference to %s in %s assignment */
10532         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
10533                                 "assignment",
10534                                  OP_DESC(varop)));
10535         return o;
10536     }
10537     if (!FEATURE_REFALIASING_IS_ENABLED)
10538         Perl_croak(aTHX_
10539                   "Experimental aliasing via reference not enabled");
10540     Perl_ck_warner_d(aTHX_
10541                      packWARN(WARN_EXPERIMENTAL__REFALIASING),
10542                     "Aliasing via reference is experimental");
10543     if (stacked) {
10544         o->op_flags |= OPf_STACKED;
10545         op_sibling_splice(o, right, 1, varop);
10546     }
10547     else {
10548         o->op_flags &=~ OPf_STACKED;
10549         op_sibling_splice(o, right, 1, NULL);
10550     }
10551     op_free(left);
10552     return o;
10553 }
10554
10555 OP *
10556 Perl_ck_repeat(pTHX_ OP *o)
10557 {
10558     PERL_ARGS_ASSERT_CK_REPEAT;
10559
10560     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
10561         OP* kids;
10562         o->op_private |= OPpREPEAT_DOLIST;
10563         kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
10564         kids = force_list(kids, 1); /* promote it to a list */
10565         op_sibling_splice(o, NULL, 0, kids); /* and add back */
10566     }
10567     else
10568         scalar(o);
10569     return o;
10570 }
10571
10572 OP *
10573 Perl_ck_require(pTHX_ OP *o)
10574 {
10575     GV* gv;
10576
10577     PERL_ARGS_ASSERT_CK_REQUIRE;
10578
10579     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
10580         SVOP * const kid = (SVOP*)cUNOPo->op_first;
10581         HEK *hek;
10582         U32 hash;
10583         char *s;
10584         STRLEN len;
10585         if (kid->op_type == OP_CONST) {
10586           SV * const sv = kid->op_sv;
10587           U32 const was_readonly = SvREADONLY(sv);
10588           if (kid->op_private & OPpCONST_BARE) {
10589             dVAR;
10590             const char *end;
10591
10592             if (was_readonly) {
10593                     SvREADONLY_off(sv);
10594             }
10595             if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
10596
10597             s = SvPVX(sv);
10598             len = SvCUR(sv);
10599             end = s + len;
10600             for (; s < end; s++) {
10601                 if (*s == ':' && s[1] == ':') {
10602                     *s = '/';
10603                     Move(s+2, s+1, end - s - 1, char);
10604                     --end;
10605                 }
10606             }
10607             SvEND_set(sv, end);
10608             sv_catpvs(sv, ".pm");
10609             PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
10610             hek = share_hek(SvPVX(sv),
10611                             (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
10612                             hash);
10613             sv_sethek(sv, hek);
10614             unshare_hek(hek);
10615             SvFLAGS(sv) |= was_readonly;
10616           }
10617           else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
10618                 && !SvVOK(sv)) {
10619             s = SvPV(sv, len);
10620             if (SvREFCNT(sv) > 1) {
10621                 kid->op_sv = newSVpvn_share(
10622                     s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
10623                 SvREFCNT_dec_NN(sv);
10624             }
10625             else {
10626                 dVAR;
10627                 if (was_readonly) SvREADONLY_off(sv);
10628                 PERL_HASH(hash, s, len);
10629                 hek = share_hek(s,
10630                                 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
10631                                 hash);
10632                 sv_sethek(sv, hek);
10633                 unshare_hek(hek);
10634                 SvFLAGS(sv) |= was_readonly;
10635             }
10636           }
10637         }
10638     }
10639
10640     if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
10641         /* handle override, if any */
10642      && (gv = gv_override("require", 7))) {
10643         OP *kid, *newop;
10644         if (o->op_flags & OPf_KIDS) {
10645             kid = cUNOPo->op_first;
10646             op_sibling_splice(o, NULL, -1, NULL);
10647         }
10648         else {
10649             kid = newDEFSVOP();
10650         }
10651         op_free(o);
10652         newop = S_new_entersubop(aTHX_ gv, kid);
10653         return newop;
10654     }
10655
10656     return ck_fun(o);
10657 }
10658
10659 OP *
10660 Perl_ck_return(pTHX_ OP *o)
10661 {
10662     OP *kid;
10663
10664     PERL_ARGS_ASSERT_CK_RETURN;
10665
10666     kid = OpSIBLING(cLISTOPo->op_first);
10667     if (CvLVALUE(PL_compcv)) {
10668         for (; kid; kid = OpSIBLING(kid))
10669             op_lvalue(kid, OP_LEAVESUBLV);
10670     }
10671
10672     return o;
10673 }
10674
10675 OP *
10676 Perl_ck_select(pTHX_ OP *o)
10677 {
10678     dVAR;
10679     OP* kid;
10680
10681     PERL_ARGS_ASSERT_CK_SELECT;
10682
10683     if (o->op_flags & OPf_KIDS) {
10684         kid = OpSIBLING(cLISTOPo->op_first);     /* get past pushmark */
10685         if (kid && OpHAS_SIBLING(kid)) {
10686             OpTYPE_set(o, OP_SSELECT);
10687             o = ck_fun(o);
10688             return fold_constants(op_integerize(op_std_init(o)));
10689         }
10690     }
10691     o = ck_fun(o);
10692     kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
10693     if (kid && kid->op_type == OP_RV2GV)
10694         kid->op_private &= ~HINT_STRICT_REFS;
10695     return o;
10696 }
10697
10698 OP *
10699 Perl_ck_shift(pTHX_ OP *o)
10700 {
10701     const I32 type = o->op_type;
10702
10703     PERL_ARGS_ASSERT_CK_SHIFT;
10704
10705     if (!(o->op_flags & OPf_KIDS)) {
10706         OP *argop;
10707
10708         if (!CvUNIQUE(PL_compcv)) {
10709             o->op_flags |= OPf_SPECIAL;
10710             return o;
10711         }
10712
10713         argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
10714         op_free(o);
10715         return newUNOP(type, 0, scalar(argop));
10716     }
10717     return scalar(ck_fun(o));
10718 }
10719
10720 OP *
10721 Perl_ck_sort(pTHX_ OP *o)
10722 {
10723     OP *firstkid;
10724     OP *kid;
10725     HV * const hinthv =
10726         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
10727     U8 stacked;
10728
10729     PERL_ARGS_ASSERT_CK_SORT;
10730
10731     if (hinthv) {
10732             SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
10733             if (svp) {
10734                 const I32 sorthints = (I32)SvIV(*svp);
10735                 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
10736                     o->op_private |= OPpSORT_QSORT;
10737                 if ((sorthints & HINT_SORT_STABLE) != 0)
10738                     o->op_private |= OPpSORT_STABLE;
10739             }
10740     }
10741
10742     if (o->op_flags & OPf_STACKED)
10743         simplify_sort(o);
10744     firstkid = OpSIBLING(cLISTOPo->op_first);           /* get past pushmark */
10745
10746     if ((stacked = o->op_flags & OPf_STACKED)) {        /* may have been cleared */
10747         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
10748
10749         /* if the first arg is a code block, process it and mark sort as
10750          * OPf_SPECIAL */
10751         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
10752             LINKLIST(kid);
10753             if (kid->op_type == OP_LEAVE)
10754                     op_null(kid);                       /* wipe out leave */
10755             /* Prevent execution from escaping out of the sort block. */
10756             kid->op_next = 0;
10757
10758             /* provide scalar context for comparison function/block */
10759             kid = scalar(firstkid);
10760             kid->op_next = kid;
10761             o->op_flags |= OPf_SPECIAL;
10762         }
10763         else if (kid->op_type == OP_CONST
10764               && kid->op_private & OPpCONST_BARE) {
10765             char tmpbuf[256];
10766             STRLEN len;
10767             PADOFFSET off;
10768             const char * const name = SvPV(kSVOP_sv, len);
10769             *tmpbuf = '&';
10770             assert (len < 256);
10771             Copy(name, tmpbuf+1, len, char);
10772             off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv));
10773             if (off != NOT_IN_PAD) {
10774                 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
10775                     SV * const fq =
10776                         newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
10777                     sv_catpvs(fq, "::");
10778                     sv_catsv(fq, kSVOP_sv);
10779                     SvREFCNT_dec_NN(kSVOP_sv);
10780                     kSVOP->op_sv = fq;
10781                 }
10782                 else {
10783                     OP * const padop = newOP(OP_PADCV, 0);
10784                     padop->op_targ = off;
10785                     /* replace the const op with the pad op */
10786                     op_sibling_splice(firstkid, NULL, 1, padop);
10787                     op_free(kid);
10788                 }
10789             }
10790         }
10791
10792         firstkid = OpSIBLING(firstkid);
10793     }
10794
10795     for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
10796         /* provide list context for arguments */
10797         list(kid);
10798         if (stacked)
10799             op_lvalue(kid, OP_GREPSTART);
10800     }
10801
10802     return o;
10803 }
10804
10805 /* for sort { X } ..., where X is one of
10806  *   $a <=> $b, $b <= $a, $a cmp $b, $b cmp $a
10807  * elide the second child of the sort (the one containing X),
10808  * and set these flags as appropriate
10809         OPpSORT_NUMERIC;
10810         OPpSORT_INTEGER;
10811         OPpSORT_DESCEND;
10812  * Also, check and warn on lexical $a, $b.
10813  */
10814
10815 STATIC void
10816 S_simplify_sort(pTHX_ OP *o)
10817 {
10818     OP *kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
10819     OP *k;
10820     int descending;
10821     GV *gv;
10822     const char *gvname;
10823     bool have_scopeop;
10824
10825     PERL_ARGS_ASSERT_SIMPLIFY_SORT;
10826
10827     kid = kUNOP->op_first;                              /* get past null */
10828     if (!(have_scopeop = kid->op_type == OP_SCOPE)
10829      && kid->op_type != OP_LEAVE)
10830         return;
10831     kid = kLISTOP->op_last;                             /* get past scope */
10832     switch(kid->op_type) {
10833         case OP_NCMP:
10834         case OP_I_NCMP:
10835         case OP_SCMP:
10836             if (!have_scopeop) goto padkids;
10837             break;
10838         default:
10839             return;
10840     }
10841     k = kid;                                            /* remember this node*/
10842     if (kBINOP->op_first->op_type != OP_RV2SV
10843      || kBINOP->op_last ->op_type != OP_RV2SV)
10844     {
10845         /*
10846            Warn about my($a) or my($b) in a sort block, *if* $a or $b is
10847            then used in a comparison.  This catches most, but not
10848            all cases.  For instance, it catches
10849                sort { my($a); $a <=> $b }
10850            but not
10851                sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
10852            (although why you'd do that is anyone's guess).
10853         */
10854
10855        padkids:
10856         if (!ckWARN(WARN_SYNTAX)) return;
10857         kid = kBINOP->op_first;
10858         do {
10859             if (kid->op_type == OP_PADSV) {
10860                 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
10861                 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
10862                  && (  PadnamePV(name)[1] == 'a'
10863                     || PadnamePV(name)[1] == 'b'  ))
10864                     /* diag_listed_as: "my %s" used in sort comparison */
10865                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10866                                      "\"%s %s\" used in sort comparison",
10867                                       PadnameIsSTATE(name)
10868                                         ? "state"
10869                                         : "my",
10870                                       PadnamePV(name));
10871             }
10872         } while ((kid = OpSIBLING(kid)));
10873         return;
10874     }
10875     kid = kBINOP->op_first;                             /* get past cmp */
10876     if (kUNOP->op_first->op_type != OP_GV)
10877         return;
10878     kid = kUNOP->op_first;                              /* get past rv2sv */
10879     gv = kGVOP_gv;
10880     if (GvSTASH(gv) != PL_curstash)
10881         return;
10882     gvname = GvNAME(gv);
10883     if (*gvname == 'a' && gvname[1] == '\0')
10884         descending = 0;
10885     else if (*gvname == 'b' && gvname[1] == '\0')
10886         descending = 1;
10887     else
10888         return;
10889
10890     kid = k;                                            /* back to cmp */
10891     /* already checked above that it is rv2sv */
10892     kid = kBINOP->op_last;                              /* down to 2nd arg */
10893     if (kUNOP->op_first->op_type != OP_GV)
10894         return;
10895     kid = kUNOP->op_first;                              /* get past rv2sv */
10896     gv = kGVOP_gv;
10897     if (GvSTASH(gv) != PL_curstash)
10898         return;
10899     gvname = GvNAME(gv);
10900     if ( descending
10901          ? !(*gvname == 'a' && gvname[1] == '\0')
10902          : !(*gvname == 'b' && gvname[1] == '\0'))
10903         return;
10904     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
10905     if (descending)
10906         o->op_private |= OPpSORT_DESCEND;
10907     if (k->op_type == OP_NCMP)
10908         o->op_private |= OPpSORT_NUMERIC;
10909     if (k->op_type == OP_I_NCMP)
10910         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
10911     kid = OpSIBLING(cLISTOPo->op_first);
10912     /* cut out and delete old block (second sibling) */
10913     op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
10914     op_free(kid);
10915 }
10916
10917 OP *
10918 Perl_ck_split(pTHX_ OP *o)
10919 {
10920     dVAR;
10921     OP *kid;
10922
10923     PERL_ARGS_ASSERT_CK_SPLIT;
10924
10925     if (o->op_flags & OPf_STACKED)
10926         return no_fh_allowed(o);
10927
10928     kid = cLISTOPo->op_first;
10929     if (kid->op_type != OP_NULL)
10930         Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
10931     /* delete leading NULL node, then add a CONST if no other nodes */
10932     op_sibling_splice(o, NULL, 1,
10933         OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
10934     op_free(kid);
10935     kid = cLISTOPo->op_first;
10936
10937     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
10938         /* remove kid, and replace with new optree */
10939         op_sibling_splice(o, NULL, 1, NULL);
10940         /* OPf_SPECIAL is used to trigger split " " behavior */
10941         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, NULL, 0, 0);
10942         op_sibling_splice(o, NULL, 0, kid);
10943     }
10944     OpTYPE_set(kid, OP_PUSHRE);
10945     /* target implies @ary=..., so wipe it */
10946     kid->op_targ = 0;
10947     scalar(kid);
10948     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
10949       Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
10950                      "Use of /g modifier is meaningless in split");
10951     }
10952
10953     if (!OpHAS_SIBLING(kid))
10954         op_append_elem(OP_SPLIT, o, newDEFSVOP());
10955
10956     kid = OpSIBLING(kid);
10957     assert(kid);
10958     scalar(kid);
10959
10960     if (!OpHAS_SIBLING(kid))
10961     {
10962         op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
10963         o->op_private |= OPpSPLIT_IMPLIM;
10964     }
10965     assert(OpHAS_SIBLING(kid));
10966
10967     kid = OpSIBLING(kid);
10968     scalar(kid);
10969
10970     if (OpHAS_SIBLING(kid))
10971         return too_many_arguments_pv(o,OP_DESC(o), 0);
10972
10973     return o;
10974 }
10975
10976 OP *
10977 Perl_ck_stringify(pTHX_ OP *o)
10978 {
10979     OP * const kid = OpSIBLING(cUNOPo->op_first);
10980     PERL_ARGS_ASSERT_CK_STRINGIFY;
10981     if ((   kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
10982          || kid->op_type == OP_LC   || kid->op_type == OP_LCFIRST
10983          || kid->op_type == OP_UC   || kid->op_type == OP_UCFIRST)
10984         && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
10985     {
10986         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
10987         op_free(o);
10988         return kid;
10989     }
10990     return ck_fun(o);
10991 }
10992
10993 OP *
10994 Perl_ck_join(pTHX_ OP *o)
10995 {
10996     OP * const kid = OpSIBLING(cLISTOPo->op_first);
10997
10998     PERL_ARGS_ASSERT_CK_JOIN;
10999
11000     if (kid && kid->op_type == OP_MATCH) {
11001         if (ckWARN(WARN_SYNTAX)) {
11002             const REGEXP *re = PM_GETRE(kPMOP);
11003             const SV *msg = re
11004                     ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
11005                                             SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
11006                     : newSVpvs_flags( "STRING", SVs_TEMP );
11007             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11008                         "/%"SVf"/ should probably be written as \"%"SVf"\"",
11009                         SVfARG(msg), SVfARG(msg));
11010         }
11011     }
11012     if (kid
11013      && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
11014         || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
11015         || (  kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
11016            && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
11017     {
11018         const OP * const bairn = OpSIBLING(kid); /* the list */
11019         if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
11020          && OP_GIMME(bairn,0) == G_SCALAR)
11021         {
11022             OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
11023                                      op_sibling_splice(o, kid, 1, NULL));
11024             op_free(o);
11025             return ret;
11026         }
11027     }
11028
11029     return ck_fun(o);
11030 }
11031
11032 /*
11033 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
11034
11035 Examines an op, which is expected to identify a subroutine at runtime,
11036 and attempts to determine at compile time which subroutine it identifies.
11037 This is normally used during Perl compilation to determine whether
11038 a prototype can be applied to a function call.  C<cvop> is the op
11039 being considered, normally an C<rv2cv> op.  A pointer to the identified
11040 subroutine is returned, if it could be determined statically, and a null
11041 pointer is returned if it was not possible to determine statically.
11042
11043 Currently, the subroutine can be identified statically if the RV that the
11044 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
11045 A C<gv> op is suitable if the GV's CV slot is populated.  A C<const> op is
11046 suitable if the constant value must be an RV pointing to a CV.  Details of
11047 this process may change in future versions of Perl.  If the C<rv2cv> op
11048 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
11049 the subroutine statically: this flag is used to suppress compile-time
11050 magic on a subroutine call, forcing it to use default runtime behaviour.
11051
11052 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
11053 of a GV reference is modified.  If a GV was examined and its CV slot was
11054 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
11055 If the op is not optimised away, and the CV slot is later populated with
11056 a subroutine having a prototype, that flag eventually triggers the warning
11057 "called too early to check prototype".
11058
11059 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
11060 of returning a pointer to the subroutine it returns a pointer to the
11061 GV giving the most appropriate name for the subroutine in this context.
11062 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
11063 (C<CvANON>) subroutine that is referenced through a GV it will be the
11064 referencing GV.  The resulting C<GV*> is cast to C<CV*> to be returned.
11065 A null pointer is returned as usual if there is no statically-determinable
11066 subroutine.
11067
11068 =cut
11069 */
11070
11071 /* shared by toke.c:yylex */
11072 CV *
11073 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
11074 {
11075     PADNAME *name = PAD_COMPNAME(off);
11076     CV *compcv = PL_compcv;
11077     while (PadnameOUTER(name)) {
11078         assert(PARENT_PAD_INDEX(name));
11079         compcv = CvOUTSIDE(compcv);
11080         name = PadlistNAMESARRAY(CvPADLIST(compcv))
11081                 [off = PARENT_PAD_INDEX(name)];
11082     }
11083     assert(!PadnameIsOUR(name));
11084     if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
11085         return PadnamePROTOCV(name);
11086     }
11087     return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
11088 }
11089
11090 CV *
11091 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
11092 {
11093     OP *rvop;
11094     CV *cv;
11095     GV *gv;
11096     PERL_ARGS_ASSERT_RV2CV_OP_CV;
11097     if (flags & ~RV2CVOPCV_FLAG_MASK)
11098         Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
11099     if (cvop->op_type != OP_RV2CV)
11100         return NULL;
11101     if (cvop->op_private & OPpENTERSUB_AMPER)
11102         return NULL;
11103     if (!(cvop->op_flags & OPf_KIDS))
11104         return NULL;
11105     rvop = cUNOPx(cvop)->op_first;
11106     switch (rvop->op_type) {
11107         case OP_GV: {
11108             gv = cGVOPx_gv(rvop);
11109             if (!isGV(gv)) {
11110                 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
11111                     cv = MUTABLE_CV(SvRV(gv));
11112                     gv = NULL;
11113                     break;
11114                 }
11115                 if (flags & RV2CVOPCV_RETURN_STUB)
11116                     return (CV *)gv;
11117                 else return NULL;
11118             }
11119             cv = GvCVu(gv);
11120             if (!cv) {
11121                 if (flags & RV2CVOPCV_MARK_EARLY)
11122                     rvop->op_private |= OPpEARLY_CV;
11123                 return NULL;
11124             }
11125         } break;
11126         case OP_CONST: {
11127             SV *rv = cSVOPx_sv(rvop);
11128             if (!SvROK(rv))
11129                 return NULL;
11130             cv = (CV*)SvRV(rv);
11131             gv = NULL;
11132         } break;
11133         case OP_PADCV: {
11134             cv = find_lexical_cv(rvop->op_targ);
11135             gv = NULL;
11136         } break;
11137         default: {
11138             return NULL;
11139         } NOT_REACHED; /* NOTREACHED */
11140     }
11141     if (SvTYPE((SV*)cv) != SVt_PVCV)
11142         return NULL;
11143     if (flags & (RV2CVOPCV_RETURN_NAME_GV|RV2CVOPCV_MAYBE_NAME_GV)) {
11144         if ((!CvANON(cv) || !gv) && !CvLEXICAL(cv)
11145          && ((flags & RV2CVOPCV_RETURN_NAME_GV) || !CvNAMED(cv)))
11146             gv = CvGV(cv);
11147         return (CV*)gv;
11148     } else {
11149         return cv;
11150     }
11151 }
11152
11153 /*
11154 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
11155
11156 Performs the default fixup of the arguments part of an C<entersub>
11157 op tree.  This consists of applying list context to each of the
11158 argument ops.  This is the standard treatment used on a call marked
11159 with C<&>, or a method call, or a call through a subroutine reference,
11160 or any other call where the callee can't be identified at compile time,
11161 or a call where the callee has no prototype.
11162
11163 =cut
11164 */
11165
11166 OP *
11167 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
11168 {
11169     OP *aop;
11170     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
11171     aop = cUNOPx(entersubop)->op_first;
11172     if (!OpHAS_SIBLING(aop))
11173         aop = cUNOPx(aop)->op_first;
11174     for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
11175         list(aop);
11176         op_lvalue(aop, OP_ENTERSUB);
11177     }
11178     return entersubop;
11179 }
11180
11181 /*
11182 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
11183
11184 Performs the fixup of the arguments part of an C<entersub> op tree
11185 based on a subroutine prototype.  This makes various modifications to
11186 the argument ops, from applying context up to inserting C<refgen> ops,
11187 and checking the number and syntactic types of arguments, as directed by
11188 the prototype.  This is the standard treatment used on a subroutine call,
11189 not marked with C<&>, where the callee can be identified at compile time
11190 and has a prototype.
11191
11192 C<protosv> supplies the subroutine prototype to be applied to the call.
11193 It may be a normal defined scalar, of which the string value will be used.
11194 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11195 that has been cast to C<SV*>) which has a prototype.  The prototype
11196 supplied, in whichever form, does not need to match the actual callee
11197 referenced by the op tree.
11198
11199 If the argument ops disagree with the prototype, for example by having
11200 an unacceptable number of arguments, a valid op tree is returned anyway.
11201 The error is reflected in the parser state, normally resulting in a single
11202 exception at the top level of parsing which covers all the compilation
11203 errors that occurred.  In the error message, the callee is referred to
11204 by the name defined by the C<namegv> parameter.
11205
11206 =cut
11207 */
11208
11209 OP *
11210 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11211 {
11212     STRLEN proto_len;
11213     const char *proto, *proto_end;
11214     OP *aop, *prev, *cvop, *parent;
11215     int optional = 0;
11216     I32 arg = 0;
11217     I32 contextclass = 0;
11218     const char *e = NULL;
11219     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
11220     if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
11221         Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
11222                    "flags=%lx", (unsigned long) SvFLAGS(protosv));
11223     if (SvTYPE(protosv) == SVt_PVCV)
11224          proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
11225     else proto = SvPV(protosv, proto_len);
11226     proto = S_strip_spaces(aTHX_ proto, &proto_len);
11227     proto_end = proto + proto_len;
11228     parent = entersubop;
11229     aop = cUNOPx(entersubop)->op_first;
11230     if (!OpHAS_SIBLING(aop)) {
11231         parent = aop;
11232         aop = cUNOPx(aop)->op_first;
11233     }
11234     prev = aop;
11235     aop = OpSIBLING(aop);
11236     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11237     while (aop != cvop) {
11238         OP* o3 = aop;
11239
11240         if (proto >= proto_end)
11241         {
11242             SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11243             yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf,
11244                                         SVfARG(namesv)), SvUTF8(namesv));
11245             return entersubop;
11246         }
11247
11248         switch (*proto) {
11249             case ';':
11250                 optional = 1;
11251                 proto++;
11252                 continue;
11253             case '_':
11254                 /* _ must be at the end */
11255                 if (proto[1] && !strchr(";@%", proto[1]))
11256                     goto oops;
11257                 /* FALLTHROUGH */
11258             case '$':
11259                 proto++;
11260                 arg++;
11261                 scalar(aop);
11262                 break;
11263             case '%':
11264             case '@':
11265                 list(aop);
11266                 arg++;
11267                 break;
11268             case '&':
11269                 proto++;
11270                 arg++;
11271                 if (    o3->op_type != OP_UNDEF
11272                     && (o3->op_type != OP_SREFGEN
11273                         || (  cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
11274                                 != OP_ANONCODE
11275                             && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
11276                                 != OP_RV2CV)))
11277                     bad_type_gv(arg, namegv, o3,
11278                             arg == 1 ? "block or sub {}" : "sub {}");
11279                 break;
11280             case '*':
11281                 /* '*' allows any scalar type, including bareword */
11282                 proto++;
11283                 arg++;
11284                 if (o3->op_type == OP_RV2GV)
11285                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
11286                 else if (o3->op_type == OP_CONST)
11287                     o3->op_private &= ~OPpCONST_STRICT;
11288                 scalar(aop);
11289                 break;
11290             case '+':
11291                 proto++;
11292                 arg++;
11293                 if (o3->op_type == OP_RV2AV ||
11294                     o3->op_type == OP_PADAV ||
11295                     o3->op_type == OP_RV2HV ||
11296                     o3->op_type == OP_PADHV
11297                 ) {
11298                     goto wrapref;
11299                 }
11300                 scalar(aop);
11301                 break;
11302             case '[': case ']':
11303                 goto oops;
11304
11305             case '\\':
11306                 proto++;
11307                 arg++;
11308             again:
11309                 switch (*proto++) {
11310                     case '[':
11311                         if (contextclass++ == 0) {
11312                             e = strchr(proto, ']');
11313                             if (!e || e == proto)
11314                                 goto oops;
11315                         }
11316                         else
11317                             goto oops;
11318                         goto again;
11319
11320                     case ']':
11321                         if (contextclass) {
11322                             const char *p = proto;
11323                             const char *const end = proto;
11324                             contextclass = 0;
11325                             while (*--p != '[')
11326                                 /* \[$] accepts any scalar lvalue */
11327                                 if (*p == '$'
11328                                  && Perl_op_lvalue_flags(aTHX_
11329                                      scalar(o3),
11330                                      OP_READ, /* not entersub */
11331                                      OP_LVALUE_NO_CROAK
11332                                     )) goto wrapref;
11333                             bad_type_gv(arg, namegv, o3,
11334                                     Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
11335                         } else
11336                             goto oops;
11337                         break;
11338                     case '*':
11339                         if (o3->op_type == OP_RV2GV)
11340                             goto wrapref;
11341                         if (!contextclass)
11342                             bad_type_gv(arg, namegv, o3, "symbol");
11343                         break;
11344                     case '&':
11345                         if (o3->op_type == OP_ENTERSUB
11346                          && !(o3->op_flags & OPf_STACKED))
11347                             goto wrapref;
11348                         if (!contextclass)
11349                             bad_type_gv(arg, namegv, o3, "subroutine");
11350                         break;
11351                     case '$':
11352                         if (o3->op_type == OP_RV2SV ||
11353                                 o3->op_type == OP_PADSV ||
11354                                 o3->op_type == OP_HELEM ||
11355                                 o3->op_type == OP_AELEM)
11356                             goto wrapref;
11357                         if (!contextclass) {
11358                             /* \$ accepts any scalar lvalue */
11359                             if (Perl_op_lvalue_flags(aTHX_
11360                                     scalar(o3),
11361                                     OP_READ,  /* not entersub */
11362                                     OP_LVALUE_NO_CROAK
11363                                )) goto wrapref;
11364                             bad_type_gv(arg, namegv, o3, "scalar");
11365                         }
11366                         break;
11367                     case '@':
11368                         if (o3->op_type == OP_RV2AV ||
11369                                 o3->op_type == OP_PADAV)
11370                         {
11371                             o3->op_flags &=~ OPf_PARENS;
11372                             goto wrapref;
11373                         }
11374                         if (!contextclass)
11375                             bad_type_gv(arg, namegv, o3, "array");
11376                         break;
11377                     case '%':
11378                         if (o3->op_type == OP_RV2HV ||
11379                                 o3->op_type == OP_PADHV)
11380                         {
11381                             o3->op_flags &=~ OPf_PARENS;
11382                             goto wrapref;
11383                         }
11384                         if (!contextclass)
11385                             bad_type_gv(arg, namegv, o3, "hash");
11386                         break;
11387                     wrapref:
11388                             aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
11389                                                 OP_REFGEN, 0);
11390                         if (contextclass && e) {
11391                             proto = e + 1;
11392                             contextclass = 0;
11393                         }
11394                         break;
11395                     default: goto oops;
11396                 }
11397                 if (contextclass)
11398                     goto again;
11399                 break;
11400             case ' ':
11401                 proto++;
11402                 continue;
11403             default:
11404             oops: {
11405                 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
11406                                   SVfARG(cv_name((CV *)namegv, NULL, 0)),
11407                                   SVfARG(protosv));
11408             }
11409         }
11410
11411         op_lvalue(aop, OP_ENTERSUB);
11412         prev = aop;
11413         aop = OpSIBLING(aop);
11414     }
11415     if (aop == cvop && *proto == '_') {
11416         /* generate an access to $_ */
11417         op_sibling_splice(parent, prev, 0, newDEFSVOP());
11418     }
11419     if (!optional && proto_end > proto &&
11420         (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
11421     {
11422         SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11423         yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf,
11424                                     SVfARG(namesv)), SvUTF8(namesv));
11425     }
11426     return entersubop;
11427 }
11428
11429 /*
11430 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
11431
11432 Performs the fixup of the arguments part of an C<entersub> op tree either
11433 based on a subroutine prototype or using default list-context processing.
11434 This is the standard treatment used on a subroutine call, not marked
11435 with C<&>, where the callee can be identified at compile time.
11436
11437 C<protosv> supplies the subroutine prototype to be applied to the call,
11438 or indicates that there is no prototype.  It may be a normal scalar,
11439 in which case if it is defined then the string value will be used
11440 as a prototype, and if it is undefined then there is no prototype.
11441 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11442 that has been cast to C<SV*>), of which the prototype will be used if it
11443 has one.  The prototype (or lack thereof) supplied, in whichever form,
11444 does not need to match the actual callee referenced by the op tree.
11445
11446 If the argument ops disagree with the prototype, for example by having
11447 an unacceptable number of arguments, a valid op tree is returned anyway.
11448 The error is reflected in the parser state, normally resulting in a single
11449 exception at the top level of parsing which covers all the compilation
11450 errors that occurred.  In the error message, the callee is referred to
11451 by the name defined by the C<namegv> parameter.
11452
11453 =cut
11454 */
11455
11456 OP *
11457 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
11458         GV *namegv, SV *protosv)
11459 {
11460     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
11461     if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
11462         return ck_entersub_args_proto(entersubop, namegv, protosv);
11463     else
11464         return ck_entersub_args_list(entersubop);
11465 }
11466
11467 OP *
11468 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11469 {
11470     int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
11471     OP *aop = cUNOPx(entersubop)->op_first;
11472
11473     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
11474
11475     if (!opnum) {
11476         OP *cvop;
11477         if (!OpHAS_SIBLING(aop))
11478             aop = cUNOPx(aop)->op_first;
11479         aop = OpSIBLING(aop);
11480         for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11481         if (aop != cvop)
11482             (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
11483
11484         op_free(entersubop);
11485         switch(GvNAME(namegv)[2]) {
11486         case 'F': return newSVOP(OP_CONST, 0,
11487                                         newSVpv(CopFILE(PL_curcop),0));
11488         case 'L': return newSVOP(
11489                            OP_CONST, 0,
11490                            Perl_newSVpvf(aTHX_
11491                              "%"IVdf, (IV)CopLINE(PL_curcop)
11492                            )
11493                          );
11494         case 'P': return newSVOP(OP_CONST, 0,
11495                                    (PL_curstash
11496                                      ? newSVhek(HvNAME_HEK(PL_curstash))
11497                                      : &PL_sv_undef
11498                                    )
11499                                 );
11500         }
11501         NOT_REACHED; /* NOTREACHED */
11502     }
11503     else {
11504         OP *prev, *cvop, *first, *parent;
11505         U32 flags = 0;
11506
11507         parent = entersubop;
11508         if (!OpHAS_SIBLING(aop)) {
11509             parent = aop;
11510             aop = cUNOPx(aop)->op_first;
11511         }
11512
11513         first = prev = aop;
11514         aop = OpSIBLING(aop);
11515         /* find last sibling */
11516         for (cvop = aop;
11517              OpHAS_SIBLING(cvop);
11518              prev = cvop, cvop = OpSIBLING(cvop))
11519             ;
11520         if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
11521             /* Usually, OPf_SPECIAL on an op with no args means that it had
11522              * parens, but these have their own meaning for that flag: */
11523             && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
11524             && opnum != OP_DELETE && opnum != OP_EXISTS)
11525                 flags |= OPf_SPECIAL;
11526         /* excise cvop from end of sibling chain */
11527         op_sibling_splice(parent, prev, 1, NULL);
11528         op_free(cvop);
11529         if (aop == cvop) aop = NULL;
11530
11531         /* detach remaining siblings from the first sibling, then
11532          * dispose of original optree */
11533
11534         if (aop)
11535             op_sibling_splice(parent, first, -1, NULL);
11536         op_free(entersubop);
11537
11538         if (opnum == OP_ENTEREVAL
11539          && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
11540             flags |= OPpEVAL_BYTES <<8;
11541
11542         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
11543         case OA_UNOP:
11544         case OA_BASEOP_OR_UNOP:
11545         case OA_FILESTATOP:
11546             return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
11547         case OA_BASEOP:
11548             if (aop) {
11549                     (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
11550                 op_free(aop);
11551             }
11552             return opnum == OP_RUNCV
11553                 ? newPVOP(OP_RUNCV,0,NULL)
11554                 : newOP(opnum,0);
11555         default:
11556             return op_convert_list(opnum,0,aop);
11557         }
11558     }
11559     NOT_REACHED; /* NOTREACHED */
11560     return entersubop;
11561 }
11562
11563 /*
11564 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
11565
11566 Retrieves the function that will be used to fix up a call to C<cv>.
11567 Specifically, the function is applied to an C<entersub> op tree for a
11568 subroutine call, not marked with C<&>, where the callee can be identified
11569 at compile time as C<cv>.
11570
11571 The C-level function pointer is returned in C<*ckfun_p>, and an SV
11572 argument for it is returned in C<*ckobj_p>.  The function is intended
11573 to be called in this manner:
11574
11575  entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
11576
11577 In this call, C<entersubop> is a pointer to the C<entersub> op,
11578 which may be replaced by the check function, and C<namegv> is a GV
11579 supplying the name that should be used by the check function to refer
11580 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11581 It is permitted to apply the check function in non-standard situations,
11582 such as to a call to a different subroutine or to a method call.
11583
11584 By default, the function is
11585 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
11586 and the SV parameter is C<cv> itself.  This implements standard
11587 prototype processing.  It can be changed, for a particular subroutine,
11588 by L</cv_set_call_checker>.
11589
11590 =cut
11591 */
11592
11593 static void
11594 S_cv_get_call_checker(CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p,
11595                       U8 *flagsp)
11596 {
11597     MAGIC *callmg;
11598     callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
11599     if (callmg) {
11600         *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
11601         *ckobj_p = callmg->mg_obj;
11602         if (flagsp) *flagsp = callmg->mg_flags;
11603     } else {
11604         *ckfun_p = Perl_ck_entersub_args_proto_or_list;
11605         *ckobj_p = (SV*)cv;
11606         if (flagsp) *flagsp = 0;
11607     }
11608 }
11609
11610 void
11611 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
11612 {
11613     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
11614     PERL_UNUSED_CONTEXT;
11615     S_cv_get_call_checker(cv, ckfun_p, ckobj_p, NULL);
11616 }
11617
11618 /*
11619 =for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 flags
11620
11621 Sets the function that will be used to fix up a call to C<cv>.
11622 Specifically, the function is applied to an C<entersub> op tree for a
11623 subroutine call, not marked with C<&>, where the callee can be identified
11624 at compile time as C<cv>.
11625
11626 The C-level function pointer is supplied in C<ckfun>, and an SV argument
11627 for it is supplied in C<ckobj>.  The function should be defined like this:
11628
11629     STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
11630
11631 It is intended to be called in this manner:
11632
11633     entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
11634
11635 In this call, C<entersubop> is a pointer to the C<entersub> op,
11636 which may be replaced by the check function, and C<namegv> supplies
11637 the name that should be used by the check function to refer
11638 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11639 It is permitted to apply the check function in non-standard situations,
11640 such as to a call to a different subroutine or to a method call.
11641
11642 C<namegv> may not actually be a GV.  For efficiency, perl may pass a
11643 CV or other SV instead.  Whatever is passed can be used as the first
11644 argument to L</cv_name>.  You can force perl to pass a GV by including
11645 C<CALL_CHECKER_REQUIRE_GV> in the C<flags>.
11646
11647 The current setting for a particular CV can be retrieved by
11648 L</cv_get_call_checker>.
11649
11650 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
11651
11652 The original form of L</cv_set_call_checker_flags>, which passes it the
11653 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.
11654
11655 =cut
11656 */
11657
11658 void
11659 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
11660 {
11661     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
11662     cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
11663 }
11664
11665 void
11666 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
11667                                      SV *ckobj, U32 flags)
11668 {
11669     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
11670     if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
11671         if (SvMAGICAL((SV*)cv))
11672             mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
11673     } else {
11674         MAGIC *callmg;
11675         sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
11676         callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
11677         assert(callmg);
11678         if (callmg->mg_flags & MGf_REFCOUNTED) {
11679             SvREFCNT_dec(callmg->mg_obj);
11680             callmg->mg_flags &= ~MGf_REFCOUNTED;
11681         }
11682         callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
11683         callmg->mg_obj = ckobj;
11684         if (ckobj != (SV*)cv) {
11685             SvREFCNT_inc_simple_void_NN(ckobj);
11686             callmg->mg_flags |= MGf_REFCOUNTED;
11687         }
11688         callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
11689                          | (U8)(flags & MGf_REQUIRE_GV) | MGf_COPY;
11690     }
11691 }
11692
11693 static void
11694 S_entersub_alloc_targ(pTHX_ OP * const o)
11695 {
11696     o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
11697     o->op_private |= OPpENTERSUB_HASTARG;
11698 }
11699
11700 OP *
11701 Perl_ck_subr(pTHX_ OP *o)
11702 {
11703     OP *aop, *cvop;
11704     CV *cv;
11705     GV *namegv;
11706     SV **const_class = NULL;
11707
11708     PERL_ARGS_ASSERT_CK_SUBR;
11709
11710     aop = cUNOPx(o)->op_first;
11711     if (!OpHAS_SIBLING(aop))
11712         aop = cUNOPx(aop)->op_first;
11713     aop = OpSIBLING(aop);
11714     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11715     cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
11716     namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
11717
11718     o->op_private &= ~1;
11719     o->op_private |= (PL_hints & HINT_STRICT_REFS);
11720     if (PERLDB_SUB && PL_curstash != PL_debstash)
11721         o->op_private |= OPpENTERSUB_DB;
11722     switch (cvop->op_type) {
11723         case OP_RV2CV:
11724             o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
11725             op_null(cvop);
11726             break;
11727         case OP_METHOD:
11728         case OP_METHOD_NAMED:
11729         case OP_METHOD_SUPER:
11730         case OP_METHOD_REDIR:
11731         case OP_METHOD_REDIR_SUPER:
11732             if (aop->op_type == OP_CONST) {
11733                 aop->op_private &= ~OPpCONST_STRICT;
11734                 const_class = &cSVOPx(aop)->op_sv;
11735             }
11736             else if (aop->op_type == OP_LIST) {
11737                 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
11738                 if (sib && sib->op_type == OP_CONST) {
11739                     sib->op_private &= ~OPpCONST_STRICT;
11740                     const_class = &cSVOPx(sib)->op_sv;
11741                 }
11742             }
11743             /* make class name a shared cow string to speedup method calls */
11744             /* constant string might be replaced with object, f.e. bigint */
11745             if (const_class && SvPOK(*const_class)) {
11746                 STRLEN len;
11747                 const char* str = SvPV(*const_class, len);
11748                 if (len) {
11749                     SV* const shared = newSVpvn_share(
11750                         str, SvUTF8(*const_class)
11751                                     ? -(SSize_t)len : (SSize_t)len,
11752                         0
11753                     );
11754                     if (SvREADONLY(*const_class))
11755                         SvREADONLY_on(shared);
11756                     SvREFCNT_dec(*const_class);
11757                     *const_class = shared;
11758                 }
11759             }
11760             break;
11761     }
11762
11763     if (!cv) {
11764         S_entersub_alloc_targ(aTHX_ o);
11765         return ck_entersub_args_list(o);
11766     } else {
11767         Perl_call_checker ckfun;
11768         SV *ckobj;
11769         U8 flags;
11770         S_cv_get_call_checker(cv, &ckfun, &ckobj, &flags);
11771         if (CvISXSUB(cv) || !CvROOT(cv))
11772             S_entersub_alloc_targ(aTHX_ o);
11773         if (!namegv) {
11774             /* The original call checker API guarantees that a GV will be
11775                be provided with the right name.  So, if the old API was
11776                used (or the REQUIRE_GV flag was passed), we have to reify
11777                the CV’s GV, unless this is an anonymous sub.  This is not
11778                ideal for lexical subs, as its stringification will include
11779                the package.  But it is the best we can do.  */
11780             if (flags & MGf_REQUIRE_GV) {
11781                 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
11782                     namegv = CvGV(cv);
11783             }
11784             else namegv = MUTABLE_GV(cv);
11785             /* After a syntax error in a lexical sub, the cv that
11786                rv2cv_op_cv returns may be a nameless stub. */
11787             if (!namegv) return ck_entersub_args_list(o);
11788
11789         }
11790         return ckfun(aTHX_ o, namegv, ckobj);
11791     }
11792 }
11793
11794 OP *
11795 Perl_ck_svconst(pTHX_ OP *o)
11796 {
11797     SV * const sv = cSVOPo->op_sv;
11798     PERL_ARGS_ASSERT_CK_SVCONST;
11799     PERL_UNUSED_CONTEXT;
11800 #ifdef PERL_COPY_ON_WRITE
11801     /* Since the read-only flag may be used to protect a string buffer, we
11802        cannot do copy-on-write with existing read-only scalars that are not
11803        already copy-on-write scalars.  To allow $_ = "hello" to do COW with
11804        that constant, mark the constant as COWable here, if it is not
11805        already read-only. */
11806     if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
11807         SvIsCOW_on(sv);
11808         CowREFCNT(sv) = 0;
11809 # ifdef PERL_DEBUG_READONLY_COW
11810         sv_buf_to_ro(sv);
11811 # endif
11812     }
11813 #endif
11814     SvREADONLY_on(sv);
11815     return o;
11816 }
11817
11818 OP *
11819 Perl_ck_trunc(pTHX_ OP *o)
11820 {
11821     PERL_ARGS_ASSERT_CK_TRUNC;
11822
11823     if (o->op_flags & OPf_KIDS) {
11824         SVOP *kid = (SVOP*)cUNOPo->op_first;
11825
11826         if (kid->op_type == OP_NULL)
11827             kid = (SVOP*)OpSIBLING(kid);
11828         if (kid && kid->op_type == OP_CONST &&
11829             (kid->op_private & OPpCONST_BARE) &&
11830             !kid->op_folded)
11831         {
11832             o->op_flags |= OPf_SPECIAL;
11833             kid->op_private &= ~OPpCONST_STRICT;
11834         }
11835     }
11836     return ck_fun(o);
11837 }
11838
11839 OP *
11840 Perl_ck_substr(pTHX_ OP *o)
11841 {
11842     PERL_ARGS_ASSERT_CK_SUBSTR;
11843
11844     o = ck_fun(o);
11845     if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
11846         OP *kid = cLISTOPo->op_first;
11847
11848         if (kid->op_type == OP_NULL)
11849             kid = OpSIBLING(kid);
11850         if (kid)
11851             kid->op_flags |= OPf_MOD;
11852
11853     }
11854     return o;
11855 }
11856
11857 OP *
11858 Perl_ck_tell(pTHX_ OP *o)
11859 {
11860     PERL_ARGS_ASSERT_CK_TELL;
11861     o = ck_fun(o);
11862     if (o->op_flags & OPf_KIDS) {
11863      OP *kid = cLISTOPo->op_first;
11864      if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
11865      if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
11866     }
11867     return o;
11868 }
11869
11870 OP *
11871 Perl_ck_each(pTHX_ OP *o)
11872 {
11873     dVAR;
11874     OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
11875     const unsigned orig_type  = o->op_type;
11876
11877     PERL_ARGS_ASSERT_CK_EACH;
11878
11879     if (kid) {
11880         switch (kid->op_type) {
11881             case OP_PADHV:
11882             case OP_RV2HV:
11883                 break;
11884             case OP_PADAV:
11885             case OP_RV2AV:
11886                 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
11887                             : orig_type == OP_KEYS ? OP_AKEYS
11888                             :                        OP_AVALUES);
11889                 break;
11890             case OP_CONST:
11891                 if (kid->op_private == OPpCONST_BARE
11892                  || !SvROK(cSVOPx_sv(kid))
11893                  || (  SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
11894                     && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV  )
11895                    )
11896                     /* we let ck_fun handle it */
11897                     break;
11898             default:
11899                 Perl_croak_nocontext(
11900                     "Experimental %s on scalar is now forbidden",
11901                     PL_op_desc[orig_type]);
11902                 break;
11903         }
11904     }
11905     return ck_fun(o);
11906 }
11907
11908 OP *
11909 Perl_ck_length(pTHX_ OP *o)
11910 {
11911     PERL_ARGS_ASSERT_CK_LENGTH;
11912
11913     o = ck_fun(o);
11914
11915     if (ckWARN(WARN_SYNTAX)) {
11916         const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
11917
11918         if (kid) {
11919             SV *name = NULL;
11920             const bool hash = kid->op_type == OP_PADHV
11921                            || kid->op_type == OP_RV2HV;
11922             switch (kid->op_type) {
11923                 case OP_PADHV:
11924                 case OP_PADAV:
11925                 case OP_RV2HV:
11926                 case OP_RV2AV:
11927                     name = S_op_varname(aTHX_ kid);
11928                     break;
11929                 default:
11930                     return o;
11931             }
11932             if (name)
11933                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11934                     "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
11935                     ")\"?)",
11936                     SVfARG(name), hash ? "keys " : "", SVfARG(name)
11937                 );
11938             else if (hash)
11939      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
11940                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11941                     "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
11942             else
11943      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
11944                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11945                     "length() used on @array (did you mean \"scalar(@array)\"?)");
11946         }
11947     }
11948
11949     return o;
11950 }
11951
11952
11953
11954 /*
11955    ---------------------------------------------------------
11956
11957    Common vars in list assignment
11958
11959    There now follows some enums and static functions for detecting
11960    common variables in list assignments. Here is a little essay I wrote
11961    for myself when trying to get my head around this. DAPM.
11962
11963    ----
11964
11965    First some random observations:
11966
11967    * If a lexical var is an alias of something else, e.g.
11968        for my $x ($lex, $pkg, $a[0]) {...}
11969      then the act of aliasing will increase the reference count of the SV
11970
11971    * If a package var is an alias of something else, it may still have a
11972      reference count of 1, depending on how the alias was created, e.g.
11973      in *a = *b, $a may have a refcount of 1 since the GP is shared
11974      with a single GvSV pointer to the SV. So If it's an alias of another
11975      package var, then RC may be 1; if it's an alias of another scalar, e.g.
11976      a lexical var or an array element, then it will have RC > 1.
11977
11978    * There are many ways to create a package alias; ultimately, XS code
11979      may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
11980      run-time tracing mechanisms are unlikely to be able to catch all cases.
11981
11982    * When the LHS is all my declarations, the same vars can't appear directly
11983      on the RHS, but they can indirectly via closures, aliasing and lvalue
11984      subs. But those techniques all involve an increase in the lexical
11985      scalar's ref count.
11986
11987    * When the LHS is all lexical vars (but not necessarily my declarations),
11988      it is possible for the same lexicals to appear directly on the RHS, and
11989      without an increased ref count, since the stack isn't refcounted.
11990      This case can be detected at compile time by scanning for common lex
11991      vars with PL_generation.
11992
11993    * lvalue subs defeat common var detection, but they do at least
11994      return vars with a temporary ref count increment. Also, you can't
11995      tell at compile time whether a sub call is lvalue.
11996
11997
11998    So...
11999
12000    A: There are a few circumstances where there definitely can't be any
12001      commonality:
12002
12003        LHS empty:  () = (...);
12004        RHS empty:  (....) = ();
12005        RHS contains only constants or other 'can't possibly be shared'
12006            elements (e.g. ops that return PADTMPs):  (...) = (1,2, length)
12007            i.e. they only contain ops not marked as dangerous, whose children
12008            are also not dangerous;
12009        LHS ditto;
12010        LHS contains a single scalar element: e.g. ($x) = (....); because
12011            after $x has been modified, it won't be used again on the RHS;
12012        RHS contains a single element with no aggregate on LHS: e.g.
12013            ($a,$b,$c)  = ($x); again, once $a has been modified, its value
12014            won't be used again.
12015
12016    B: If LHS are all 'my' lexical var declarations (or safe ops, which
12017      we can ignore):
12018
12019        my ($a, $b, @c) = ...;
12020
12021        Due to closure and goto tricks, these vars may already have content.
12022        For the same reason, an element on the RHS may be a lexical or package
12023        alias of one of the vars on the left, or share common elements, for
12024        example:
12025
12026            my ($x,$y) = f(); # $x and $y on both sides
12027            sub f : lvalue { ($x,$y) = (1,2); $y, $x }
12028
12029        and
12030
12031            my $ra = f();
12032            my @a = @$ra;  # elements of @a on both sides
12033            sub f { @a = 1..4; \@a }
12034
12035
12036        First, just consider scalar vars on LHS:
12037
12038            RHS is safe only if (A), or in addition,
12039                * contains only lexical *scalar* vars, where neither side's
12040                  lexicals have been flagged as aliases
12041
12042            If RHS is not safe, then it's always legal to check LHS vars for
12043            RC==1, since the only RHS aliases will always be associated
12044            with an RC bump.
12045
12046            Note that in particular, RHS is not safe if:
12047
12048                * it contains package scalar vars; e.g.:
12049
12050                    f();
12051                    my ($x, $y) = (2, $x_alias);
12052                    sub f { $x = 1; *x_alias = \$x; }
12053
12054                * It contains other general elements, such as flattened or
12055                * spliced or single array or hash elements, e.g.
12056
12057                    f();
12058                    my ($x,$y) = @a; # or $a[0] or @a{@b} etc
12059
12060                    sub f {
12061                        ($x, $y) = (1,2);
12062                        use feature 'refaliasing';
12063                        \($a[0], $a[1]) = \($y,$x);
12064                    }
12065
12066                  It doesn't matter if the array/hash is lexical or package.
12067
12068                * it contains a function call that happens to be an lvalue
12069                  sub which returns one or more of the above, e.g.
12070
12071                    f();
12072                    my ($x,$y) = f();
12073
12074                    sub f : lvalue {
12075                        ($x, $y) = (1,2);
12076                        *x1 = \$x;
12077                        $y, $x1;
12078                    }
12079
12080                    (so a sub call on the RHS should be treated the same
12081                    as having a package var on the RHS).
12082
12083                * any other "dangerous" thing, such an op or built-in that
12084                  returns one of the above, e.g. pp_preinc
12085
12086
12087            If RHS is not safe, what we can do however is at compile time flag
12088            that the LHS are all my declarations, and at run time check whether
12089            all the LHS have RC == 1, and if so skip the full scan.
12090
12091        Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
12092
12093            Here the issue is whether there can be elements of @a on the RHS
12094            which will get prematurely freed when @a is cleared prior to
12095            assignment. This is only a problem if the aliasing mechanism
12096            is one which doesn't increase the refcount - only if RC == 1
12097            will the RHS element be prematurely freed.
12098
12099            Because the array/hash is being INTROed, it or its elements
12100            can't directly appear on the RHS:
12101
12102                my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
12103
12104            but can indirectly, e.g.:
12105
12106                my $r = f();
12107                my (@a) = @$r;
12108                sub f { @a = 1..3; \@a }
12109
12110            So if the RHS isn't safe as defined by (A), we must always
12111            mortalise and bump the ref count of any remaining RHS elements
12112            when assigning to a non-empty LHS aggregate.
12113
12114            Lexical scalars on the RHS aren't safe if they've been involved in
12115            aliasing, e.g.
12116
12117                use feature 'refaliasing';
12118
12119                f();
12120                \(my $lex) = \$pkg;
12121                my @a = ($lex,3); # equivalent to ($a[0],3)
12122
12123                sub f {
12124                    @a = (1,2);
12125                    \$pkg = \$a[0];
12126                }
12127
12128            Similarly with lexical arrays and hashes on the RHS:
12129
12130                f();
12131                my @b;
12132                my @a = (@b);
12133
12134                sub f {
12135                    @a = (1,2);
12136                    \$b[0] = \$a[1];
12137                    \$b[1] = \$a[0];
12138                }
12139
12140
12141
12142    C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
12143        my $a; ($a, my $b) = (....);
12144
12145        The difference between (B) and (C) is that it is now physically
12146        possible for the LHS vars to appear on the RHS too, where they
12147        are not reference counted; but in this case, the compile-time
12148        PL_generation sweep will detect such common vars.
12149
12150        So the rules for (C) differ from (B) in that if common vars are
12151        detected, the runtime "test RC==1" optimisation can no longer be used,
12152        and a full mark and sweep is required
12153
12154    D: As (C), but in addition the LHS may contain package vars.
12155
12156        Since package vars can be aliased without a corresponding refcount
12157        increase, all bets are off. It's only safe if (A). E.g.
12158
12159            my ($x, $y) = (1,2);
12160
12161            for $x_alias ($x) {
12162                ($x_alias, $y) = (3, $x); # whoops
12163            }
12164
12165        Ditto for LHS aggregate package vars.
12166
12167    E: Any other dangerous ops on LHS, e.g.
12168            (f(), $a[0], @$r) = (...);
12169
12170        this is similar to (E) in that all bets are off. In addition, it's
12171        impossible to determine at compile time whether the LHS
12172        contains a scalar or an aggregate, e.g.
12173
12174            sub f : lvalue { @a }
12175            (f()) = 1..3;
12176
12177 * ---------------------------------------------------------
12178 */
12179
12180
12181 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates
12182  * that at least one of the things flagged was seen.
12183  */
12184
12185 enum {
12186     AAS_MY_SCALAR       = 0x001, /* my $scalar */
12187     AAS_MY_AGG          = 0x002, /* aggregate: my @array or my %hash */
12188     AAS_LEX_SCALAR      = 0x004, /* $lexical */
12189     AAS_LEX_AGG         = 0x008, /* @lexical or %lexical aggregate */
12190     AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
12191     AAS_PKG_SCALAR      = 0x020, /* $scalar (where $scalar is pkg var) */
12192     AAS_PKG_AGG         = 0x040, /* package @array or %hash aggregate */
12193     AAS_DANGEROUS       = 0x080, /* an op (other than the above)
12194                                          that's flagged OA_DANGEROUS */
12195     AAS_SAFE_SCALAR     = 0x100, /* produces at least one scalar SV that's
12196                                         not in any of the categories above */
12197     AAS_DEFAV           = 0x200, /* contains just a single '@_' on RHS */
12198 };
12199
12200
12201
12202 /* helper function for S_aassign_scan().
12203  * check a PAD-related op for commonality and/or set its generation number.
12204  * Returns a boolean indicating whether its shared */
12205
12206 static bool
12207 S_aassign_padcheck(pTHX_ OP* o, bool rhs)
12208 {
12209     if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
12210         /* lexical used in aliasing */
12211         return TRUE;
12212
12213     if (rhs)
12214         return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
12215     else
12216         PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
12217
12218     return FALSE;
12219 }
12220
12221
12222 /*
12223   Helper function for OPpASSIGN_COMMON* detection in rpeep().
12224   It scans the left or right hand subtree of the aassign op, and returns a
12225   set of flags indicating what sorts of things it found there.
12226   'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
12227   set PL_generation on lexical vars; if the latter, we see if
12228   PL_generation matches.
12229   'top' indicates whether we're recursing or at the top level.
12230   'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
12231   This fn will increment it by the number seen. It's not intended to
12232   be an accurate count (especially as many ops can push a variable
12233   number of SVs onto the stack); rather it's used as to test whether there
12234   can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
12235 */
12236
12237 static int
12238 S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *scalars_p)
12239 {
12240     int flags = 0;
12241     bool kid_top = FALSE;
12242
12243     /* first, look for a solitary @_ on the RHS */
12244     if (   rhs
12245         && top
12246         && (o->op_flags & OPf_KIDS)
12247         && OP_TYPE_IS_OR_WAS(o, OP_LIST)
12248     ) {
12249         OP *kid = cUNOPo->op_first;
12250         if (   (   kid->op_type == OP_PUSHMARK
12251                 || kid->op_type == OP_PADRANGE) /* ex-pushmark */
12252             && ((kid = OpSIBLING(kid)))
12253             && !OpHAS_SIBLING(kid)
12254             && kid->op_type == OP_RV2AV
12255             && !(kid->op_flags & OPf_REF)
12256             && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
12257             && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
12258             && ((kid = cUNOPx(kid)->op_first))
12259             && kid->op_type == OP_GV
12260             && cGVOPx_gv(kid) == PL_defgv
12261         )
12262             flags |= AAS_DEFAV;
12263     }
12264
12265     switch (o->op_type) {
12266     case OP_GVSV:
12267         (*scalars_p)++;
12268         return AAS_PKG_SCALAR;
12269
12270     case OP_PADAV:
12271     case OP_PADHV:
12272         (*scalars_p) += 2;
12273         if (top && (o->op_flags & OPf_REF))
12274             return (o->op_private & OPpLVAL_INTRO)
12275                 ? AAS_MY_AGG : AAS_LEX_AGG;
12276         return AAS_DANGEROUS;
12277
12278     case OP_PADSV:
12279         {
12280             int comm = S_aassign_padcheck(aTHX_ o, rhs)
12281                         ?  AAS_LEX_SCALAR_COMM : 0;
12282             (*scalars_p)++;
12283             return (o->op_private & OPpLVAL_INTRO)
12284                 ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
12285         }
12286
12287     case OP_RV2AV:
12288     case OP_RV2HV:
12289         (*scalars_p) += 2;
12290         if (cUNOPx(o)->op_first->op_type != OP_GV)
12291             return AAS_DANGEROUS; /* @{expr}, %{expr} */
12292         /* @pkg, %pkg */
12293         if (top && (o->op_flags & OPf_REF))
12294             return AAS_PKG_AGG;
12295         return AAS_DANGEROUS;
12296
12297     case OP_RV2SV:
12298         (*scalars_p)++;
12299         if (cUNOPx(o)->op_first->op_type != OP_GV) {
12300             (*scalars_p) += 2;
12301             return AAS_DANGEROUS; /* ${expr} */
12302         }
12303         return AAS_PKG_SCALAR; /* $pkg */
12304
12305     case OP_SPLIT:
12306         if (cLISTOPo->op_first->op_type == OP_PUSHRE) {
12307             /* "@foo = split... " optimises away the aassign and stores its
12308              * destination array in the OP_PUSHRE that precedes it.
12309              * A flattened array is always dangerous.
12310              */
12311             (*scalars_p) += 2;
12312             return AAS_DANGEROUS;
12313         }
12314         break;
12315
12316     case OP_UNDEF:
12317         /* undef counts as a scalar on the RHS:
12318          *   (undef, $x) = ...;         # only 1 scalar on LHS: always safe
12319          *   ($x, $y)    = (undef, $x); # 2 scalars on RHS: unsafe
12320          */
12321         if (rhs)
12322             (*scalars_p)++;
12323         flags = AAS_SAFE_SCALAR;
12324         break;
12325
12326     case OP_PUSHMARK:
12327     case OP_STUB:
12328         /* these are all no-ops; they don't push a potentially common SV
12329          * onto the stack, so they are neither AAS_DANGEROUS nor
12330          * AAS_SAFE_SCALAR */
12331         return 0;
12332
12333     case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
12334         break;
12335
12336     case OP_NULL:
12337     case OP_LIST:
12338         /* these do nothing but may have children; but their children
12339          * should also be treated as top-level */
12340         kid_top = top;
12341         break;
12342
12343     default:
12344         if (PL_opargs[o->op_type] & OA_DANGEROUS) {
12345             (*scalars_p) += 2;
12346             return AAS_DANGEROUS;
12347         }
12348
12349         if (   (PL_opargs[o->op_type] & OA_TARGLEX)
12350             && (o->op_private & OPpTARGET_MY))
12351         {
12352             (*scalars_p)++;
12353             return S_aassign_padcheck(aTHX_ o, rhs)
12354                 ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
12355         }
12356
12357         /* if its an unrecognised, non-dangerous op, assume that it
12358          * it the cause of at least one safe scalar */
12359         (*scalars_p)++;
12360         flags = AAS_SAFE_SCALAR;
12361         break;
12362     }
12363
12364     if (o->op_flags & OPf_KIDS) {
12365         OP *kid;
12366         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
12367             flags |= S_aassign_scan(aTHX_ kid, rhs, kid_top, scalars_p);
12368     }
12369     return flags;
12370 }
12371
12372
12373 /* Check for in place reverse and sort assignments like "@a = reverse @a"
12374    and modify the optree to make them work inplace */
12375
12376 STATIC void
12377 S_inplace_aassign(pTHX_ OP *o) {
12378
12379     OP *modop, *modop_pushmark;
12380     OP *oright;
12381     OP *oleft, *oleft_pushmark;
12382
12383     PERL_ARGS_ASSERT_INPLACE_AASSIGN;
12384
12385     assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
12386
12387     assert(cUNOPo->op_first->op_type == OP_NULL);
12388     modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
12389     assert(modop_pushmark->op_type == OP_PUSHMARK);
12390     modop = OpSIBLING(modop_pushmark);
12391
12392     if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
12393         return;
12394
12395     /* no other operation except sort/reverse */
12396     if (OpHAS_SIBLING(modop))
12397         return;
12398
12399     assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
12400     if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
12401
12402     if (modop->op_flags & OPf_STACKED) {
12403         /* skip sort subroutine/block */
12404         assert(oright->op_type == OP_NULL);
12405         oright = OpSIBLING(oright);
12406     }
12407
12408     assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
12409     oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
12410     assert(oleft_pushmark->op_type == OP_PUSHMARK);
12411     oleft = OpSIBLING(oleft_pushmark);
12412
12413     /* Check the lhs is an array */
12414     if (!oleft ||
12415         (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
12416         || OpHAS_SIBLING(oleft)
12417         || (oleft->op_private & OPpLVAL_INTRO)
12418     )
12419         return;
12420
12421     /* Only one thing on the rhs */
12422     if (OpHAS_SIBLING(oright))
12423         return;
12424
12425     /* check the array is the same on both sides */
12426     if (oleft->op_type == OP_RV2AV) {
12427         if (oright->op_type != OP_RV2AV
12428             || !cUNOPx(oright)->op_first
12429             || cUNOPx(oright)->op_first->op_type != OP_GV
12430             || cUNOPx(oleft )->op_first->op_type != OP_GV
12431             || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
12432                cGVOPx_gv(cUNOPx(oright)->op_first)
12433         )
12434             return;
12435     }
12436     else if (oright->op_type != OP_PADAV
12437         || oright->op_targ != oleft->op_targ
12438     )
12439         return;
12440
12441     /* This actually is an inplace assignment */
12442
12443     modop->op_private |= OPpSORT_INPLACE;
12444
12445     /* transfer MODishness etc from LHS arg to RHS arg */
12446     oright->op_flags = oleft->op_flags;
12447
12448     /* remove the aassign op and the lhs */
12449     op_null(o);
12450     op_null(oleft_pushmark);
12451     if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
12452         op_null(cUNOPx(oleft)->op_first);
12453     op_null(oleft);
12454 }
12455
12456
12457
12458 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
12459  * that potentially represent a series of one or more aggregate derefs
12460  * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
12461  * the whole chain to a single OP_MULTIDEREF op (maybe with a few
12462  * additional ops left in too).
12463  *
12464  * The caller will have already verified that the first few ops in the
12465  * chain following 'start' indicate a multideref candidate, and will have
12466  * set 'orig_o' to the point further on in the chain where the first index
12467  * expression (if any) begins.  'orig_action' specifies what type of
12468  * beginning has already been determined by the ops between start..orig_o
12469  * (e.g.  $lex_ary[], $pkg_ary->{}, expr->[], etc).
12470  *
12471  * 'hints' contains any hints flags that need adding (currently just
12472  * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
12473  */
12474
12475 void
12476 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
12477 {
12478     dVAR;
12479     int pass;
12480     UNOP_AUX_item *arg_buf = NULL;
12481     bool reset_start_targ  = FALSE; /* start->op_targ needs zeroing */
12482     int index_skip         = -1;    /* don't output index arg on this action */
12483
12484     /* similar to regex compiling, do two passes; the first pass
12485      * determines whether the op chain is convertible and calculates the
12486      * buffer size; the second pass populates the buffer and makes any
12487      * changes necessary to ops (such as moving consts to the pad on
12488      * threaded builds).
12489      *
12490      * NB: for things like Coverity, note that both passes take the same
12491      * path through the logic tree (except for 'if (pass)' bits), since
12492      * both passes are following the same op_next chain; and in
12493      * particular, if it would return early on the second pass, it would
12494      * already have returned early on the first pass.
12495      */
12496     for (pass = 0; pass < 2; pass++) {
12497         OP *o                = orig_o;
12498         UV action            = orig_action;
12499         OP *first_elem_op    = NULL;  /* first seen aelem/helem */
12500         OP *top_op           = NULL;  /* highest [ah]elem/exists/del/rv2[ah]v */
12501         int action_count     = 0;     /* number of actions seen so far */
12502         int action_ix        = 0;     /* action_count % (actions per IV) */
12503         bool next_is_hash    = FALSE; /* is the next lookup to be a hash? */
12504         bool is_last         = FALSE; /* no more derefs to follow */
12505         bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
12506         UNOP_AUX_item *arg     = arg_buf;
12507         UNOP_AUX_item *action_ptr = arg_buf;
12508
12509         if (pass)
12510             action_ptr->uv = 0;
12511         arg++;
12512
12513         switch (action) {
12514         case MDEREF_HV_gvsv_vivify_rv2hv_helem:
12515         case MDEREF_HV_gvhv_helem:
12516             next_is_hash = TRUE;
12517             /* FALLTHROUGH */
12518         case MDEREF_AV_gvsv_vivify_rv2av_aelem:
12519         case MDEREF_AV_gvav_aelem:
12520             if (pass) {
12521 #ifdef USE_ITHREADS
12522                 arg->pad_offset = cPADOPx(start)->op_padix;
12523                 /* stop it being swiped when nulled */
12524                 cPADOPx(start)->op_padix = 0;
12525 #else
12526                 arg->sv = cSVOPx(start)->op_sv;
12527                 cSVOPx(start)->op_sv = NULL;
12528 #endif
12529             }
12530             arg++;
12531             break;
12532
12533         case MDEREF_HV_padhv_helem:
12534         case MDEREF_HV_padsv_vivify_rv2hv_helem:
12535             next_is_hash = TRUE;
12536             /* FALLTHROUGH */
12537         case MDEREF_AV_padav_aelem:
12538         case MDEREF_AV_padsv_vivify_rv2av_aelem:
12539             if (pass) {
12540                 arg->pad_offset = start->op_targ;
12541                 /* we skip setting op_targ = 0 for now, since the intact
12542                  * OP_PADXV is needed by S_check_hash_fields_and_hekify */
12543                 reset_start_targ = TRUE;
12544             }
12545             arg++;
12546             break;
12547
12548         case MDEREF_HV_pop_rv2hv_helem:
12549             next_is_hash = TRUE;
12550             /* FALLTHROUGH */
12551         case MDEREF_AV_pop_rv2av_aelem:
12552             break;
12553
12554         default:
12555             NOT_REACHED; /* NOTREACHED */
12556             return;
12557         }
12558
12559         while (!is_last) {
12560             /* look for another (rv2av/hv; get index;
12561              * aelem/helem/exists/delele) sequence */
12562
12563             OP *kid;
12564             bool is_deref;
12565             bool ok;
12566             UV index_type = MDEREF_INDEX_none;
12567
12568             if (action_count) {
12569                 /* if this is not the first lookup, consume the rv2av/hv  */
12570
12571                 /* for N levels of aggregate lookup, we normally expect
12572                  * that the first N-1 [ah]elem ops will be flagged as
12573                  * /DEREF (so they autovivifiy if necessary), and the last
12574                  * lookup op not to be.
12575                  * For other things (like @{$h{k1}{k2}}) extra scope or
12576                  * leave ops can appear, so abandon the effort in that
12577                  * case */
12578                 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
12579                     return;
12580
12581                 /* rv2av or rv2hv sKR/1 */
12582
12583                 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12584                                             |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12585                 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
12586                     return;
12587
12588                 /* at this point, we wouldn't expect any of these
12589                  * possible private flags:
12590                  * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
12591                  * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
12592                  */
12593                 ASSUME(!(o->op_private &
12594                     ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
12595
12596                 hints = (o->op_private & OPpHINT_STRICT_REFS);
12597
12598                 /* make sure the type of the previous /DEREF matches the
12599                  * type of the next lookup */
12600                 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
12601                 top_op = o;
12602
12603                 action = next_is_hash
12604                             ? MDEREF_HV_vivify_rv2hv_helem
12605                             : MDEREF_AV_vivify_rv2av_aelem;
12606                 o = o->op_next;
12607             }
12608
12609             /* if this is the second pass, and we're at the depth where
12610              * previously we encountered a non-simple index expression,
12611              * stop processing the index at this point */
12612             if (action_count != index_skip) {
12613
12614                 /* look for one or more simple ops that return an array
12615                  * index or hash key */
12616
12617                 switch (o->op_type) {
12618                 case OP_PADSV:
12619                     /* it may be a lexical var index */
12620                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
12621                                             |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12622                     ASSUME(!(o->op_private &
12623                             ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
12624
12625                     if (   OP_GIMME(o,0) == G_SCALAR
12626                         && !(o->op_flags & (OPf_REF|OPf_MOD))
12627                         && o->op_private == 0)
12628                     {
12629                         if (pass)
12630                             arg->pad_offset = o->op_targ;
12631                         arg++;
12632                         index_type = MDEREF_INDEX_padsv;
12633                         o = o->op_next;
12634                     }
12635                     break;
12636
12637                 case OP_CONST:
12638                     if (next_is_hash) {
12639                         /* it's a constant hash index */
12640                         if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
12641                             /* "use constant foo => FOO; $h{+foo}" for
12642                              * some weird FOO, can leave you with constants
12643                              * that aren't simple strings. It's not worth
12644                              * the extra hassle for those edge cases */
12645                             break;
12646
12647                         if (pass) {
12648                             UNOP *rop = NULL;
12649                             OP * helem_op = o->op_next;
12650
12651                             ASSUME(   helem_op->op_type == OP_HELEM
12652                                    || helem_op->op_type == OP_NULL);
12653                             if (helem_op->op_type == OP_HELEM) {
12654                                 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
12655                                 if (   helem_op->op_private & OPpLVAL_INTRO
12656                                     || rop->op_type != OP_RV2HV
12657                                 )
12658                                     rop = NULL;
12659                             }
12660                             S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo);
12661
12662 #ifdef USE_ITHREADS
12663                             /* Relocate sv to the pad for thread safety */
12664                             op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
12665                             arg->pad_offset = o->op_targ;
12666                             o->op_targ = 0;
12667 #else
12668                             arg->sv = cSVOPx_sv(o);
12669 #endif
12670                         }
12671                     }
12672                     else {
12673                         /* it's a constant array index */
12674                         IV iv;
12675                         SV *ix_sv = cSVOPo->op_sv;
12676                         if (!SvIOK(ix_sv))
12677                             break;
12678                         iv = SvIV(ix_sv);
12679
12680                         if (   action_count == 0
12681                             && iv >= -128
12682                             && iv <= 127
12683                             && (   action == MDEREF_AV_padav_aelem
12684                                 || action == MDEREF_AV_gvav_aelem)
12685                         )
12686                             maybe_aelemfast = TRUE;
12687
12688                         if (pass) {
12689                             arg->iv = iv;
12690                             SvREFCNT_dec_NN(cSVOPo->op_sv);
12691                         }
12692                     }
12693                     if (pass)
12694                         /* we've taken ownership of the SV */
12695                         cSVOPo->op_sv = NULL;
12696                     arg++;
12697                     index_type = MDEREF_INDEX_const;
12698                     o = o->op_next;
12699                     break;
12700
12701                 case OP_GV:
12702                     /* it may be a package var index */
12703
12704                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_SPECIAL)));
12705                     ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
12706                     if (  (o->op_flags &~ OPf_SPECIAL) != OPf_WANT_SCALAR
12707                         || o->op_private != 0
12708                     )
12709                         break;
12710
12711                     kid = o->op_next;
12712                     if (kid->op_type != OP_RV2SV)
12713                         break;
12714
12715                     ASSUME(!(kid->op_flags &
12716                             ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
12717                              |OPf_SPECIAL|OPf_PARENS)));
12718                     ASSUME(!(kid->op_private &
12719                                     ~(OPpARG1_MASK
12720                                      |OPpHINT_STRICT_REFS|OPpOUR_INTRO
12721                                      |OPpDEREF|OPpLVAL_INTRO)));
12722                     if(   (kid->op_flags &~ OPf_PARENS)
12723                             != (OPf_WANT_SCALAR|OPf_KIDS)
12724                        || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
12725                     )
12726                         break;
12727
12728                     if (pass) {
12729 #ifdef USE_ITHREADS
12730                         arg->pad_offset = cPADOPx(o)->op_padix;
12731                         /* stop it being swiped when nulled */
12732                         cPADOPx(o)->op_padix = 0;
12733 #else
12734                         arg->sv = cSVOPx(o)->op_sv;
12735                         cSVOPo->op_sv = NULL;
12736 #endif
12737                     }
12738                     arg++;
12739                     index_type = MDEREF_INDEX_gvsv;
12740                     o = kid->op_next;
12741                     break;
12742
12743                 } /* switch */
12744             } /* action_count != index_skip */
12745
12746             action |= index_type;
12747
12748
12749             /* at this point we have either:
12750              *   * detected what looks like a simple index expression,
12751              *     and expect the next op to be an [ah]elem, or
12752              *     an nulled  [ah]elem followed by a delete or exists;
12753              *  * found a more complex expression, so something other
12754              *    than the above follows.
12755              */
12756
12757             /* possibly an optimised away [ah]elem (where op_next is
12758              * exists or delete) */
12759             if (o->op_type == OP_NULL)
12760                 o = o->op_next;
12761
12762             /* at this point we're looking for an OP_AELEM, OP_HELEM,
12763              * OP_EXISTS or OP_DELETE */
12764
12765             /* if something like arybase (a.k.a $[ ) is in scope,
12766              * abandon optimisation attempt */
12767             if (  (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
12768                && PL_check[o->op_type] != Perl_ck_null)
12769                 return;
12770
12771             if (   o->op_type != OP_AELEM
12772                 || (o->op_private &
12773                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
12774                 )
12775                 maybe_aelemfast = FALSE;
12776
12777             /* look for aelem/helem/exists/delete. If it's not the last elem
12778              * lookup, it *must* have OPpDEREF_AV/HV, but not many other
12779              * flags; if it's the last, then it mustn't have
12780              * OPpDEREF_AV/HV, but may have lots of other flags, like
12781              * OPpLVAL_INTRO etc
12782              */
12783
12784             if (   index_type == MDEREF_INDEX_none
12785                 || (   o->op_type != OP_AELEM  && o->op_type != OP_HELEM
12786                     && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
12787             )
12788                 ok = FALSE;
12789             else {
12790                 /* we have aelem/helem/exists/delete with valid simple index */
12791
12792                 is_deref =    (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
12793                            && (   (o->op_private & OPpDEREF) == OPpDEREF_AV
12794                                || (o->op_private & OPpDEREF) == OPpDEREF_HV);
12795
12796                 if (is_deref) {
12797                     ASSUME(!(o->op_flags &
12798                                  ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
12799                     ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
12800
12801                     ok =    (o->op_flags &~ OPf_PARENS)
12802                                == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
12803                          && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
12804                 }
12805                 else if (o->op_type == OP_EXISTS) {
12806                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12807                                 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12808                     ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
12809                     ok =  !(o->op_private & ~OPpARG1_MASK);
12810                 }
12811                 else if (o->op_type == OP_DELETE) {
12812                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12813                                 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12814                     ASSUME(!(o->op_private &
12815                                     ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
12816                     /* don't handle slices or 'local delete'; the latter
12817                      * is fairly rare, and has a complex runtime */
12818                     ok =  !(o->op_private & ~OPpARG1_MASK);
12819                     if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
12820                         /* skip handling run-tome error */
12821                         ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
12822                 }
12823                 else {
12824                     ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
12825                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
12826                                             |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
12827                     ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
12828                                     |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
12829                     ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
12830                 }
12831             }
12832
12833             if (ok) {
12834                 if (!first_elem_op)
12835                     first_elem_op = o;
12836                 top_op = o;
12837                 if (is_deref) {
12838                     next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
12839                     o = o->op_next;
12840                 }
12841                 else {
12842                     is_last = TRUE;
12843                     action |= MDEREF_FLAG_last;
12844                 }
12845             }
12846             else {
12847                 /* at this point we have something that started
12848                  * promisingly enough (with rv2av or whatever), but failed
12849                  * to find a simple index followed by an
12850                  * aelem/helem/exists/delete. If this is the first action,
12851                  * give up; but if we've already seen at least one
12852                  * aelem/helem, then keep them and add a new action with
12853                  * MDEREF_INDEX_none, which causes it to do the vivify
12854                  * from the end of the previous lookup, and do the deref,
12855                  * but stop at that point. So $a[0][expr] will do one
12856                  * av_fetch, vivify and deref, then continue executing at
12857                  * expr */
12858                 if (!action_count)
12859                     return;
12860                 is_last = TRUE;
12861                 index_skip = action_count;
12862                 action |= MDEREF_FLAG_last;
12863             }
12864
12865             if (pass)
12866                 action_ptr->uv |= (action << (action_ix * MDEREF_SHIFT));
12867             action_ix++;
12868             action_count++;
12869             /* if there's no space for the next action, create a new slot
12870              * for it *before* we start adding args for that action */
12871             if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
12872                 action_ptr = arg;
12873                 if (pass)
12874                     arg->uv = 0;
12875                 arg++;
12876                 action_ix = 0;
12877             }
12878         } /* while !is_last */
12879
12880         /* success! */
12881
12882         if (pass) {
12883             OP *mderef;
12884             OP *p, *q;
12885
12886             mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
12887             if (index_skip == -1) {
12888                 mderef->op_flags = o->op_flags
12889                         & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
12890                 if (o->op_type == OP_EXISTS)
12891                     mderef->op_private = OPpMULTIDEREF_EXISTS;
12892                 else if (o->op_type == OP_DELETE)
12893                     mderef->op_private = OPpMULTIDEREF_DELETE;
12894                 else
12895                     mderef->op_private = o->op_private
12896                         & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
12897             }
12898             /* accumulate strictness from every level (although I don't think
12899              * they can actually vary) */
12900             mderef->op_private |= hints;
12901
12902             /* integrate the new multideref op into the optree and the
12903              * op_next chain.
12904              *
12905              * In general an op like aelem or helem has two child
12906              * sub-trees: the aggregate expression (a_expr) and the
12907              * index expression (i_expr):
12908              *
12909              *     aelem
12910              *       |
12911              *     a_expr - i_expr
12912              *
12913              * The a_expr returns an AV or HV, while the i-expr returns an
12914              * index. In general a multideref replaces most or all of a
12915              * multi-level tree, e.g.
12916              *
12917              *     exists
12918              *       |
12919              *     ex-aelem
12920              *       |
12921              *     rv2av  - i_expr1
12922              *       |
12923              *     helem
12924              *       |
12925              *     rv2hv  - i_expr2
12926              *       |
12927              *     aelem
12928              *       |
12929              *     a_expr - i_expr3
12930              *
12931              * With multideref, all the i_exprs will be simple vars or
12932              * constants, except that i_expr1 may be arbitrary in the case
12933              * of MDEREF_INDEX_none.
12934              *
12935              * The bottom-most a_expr will be either:
12936              *   1) a simple var (so padXv or gv+rv2Xv);
12937              *   2) a simple scalar var dereferenced (e.g. $r->[0]):
12938              *      so a simple var with an extra rv2Xv;
12939              *   3) or an arbitrary expression.
12940              *
12941              * 'start', the first op in the execution chain, will point to
12942              *   1),2): the padXv or gv op;
12943              *   3):    the rv2Xv which forms the last op in the a_expr
12944              *          execution chain, and the top-most op in the a_expr
12945              *          subtree.
12946              *
12947              * For all cases, the 'start' node is no longer required,
12948              * but we can't free it since one or more external nodes
12949              * may point to it. E.g. consider
12950              *     $h{foo} = $a ? $b : $c
12951              * Here, both the op_next and op_other branches of the
12952              * cond_expr point to the gv[*h] of the hash expression, so
12953              * we can't free the 'start' op.
12954              *
12955              * For expr->[...], we need to save the subtree containing the
12956              * expression; for the other cases, we just need to save the
12957              * start node.
12958              * So in all cases, we null the start op and keep it around by
12959              * making it the child of the multideref op; for the expr->
12960              * case, the expr will be a subtree of the start node.
12961              *
12962              * So in the simple 1,2 case the  optree above changes to
12963              *
12964              *     ex-exists
12965              *       |
12966              *     multideref
12967              *       |
12968              *     ex-gv (or ex-padxv)
12969              *
12970              *  with the op_next chain being
12971              *
12972              *  -> ex-gv -> multideref -> op-following-ex-exists ->
12973              *
12974              *  In the 3 case, we have
12975              *
12976              *     ex-exists
12977              *       |
12978              *     multideref
12979              *       |
12980              *     ex-rv2xv
12981              *       |
12982              *    rest-of-a_expr
12983              *      subtree
12984              *
12985              *  and
12986              *
12987              *  -> rest-of-a_expr subtree ->
12988              *    ex-rv2xv -> multideref -> op-following-ex-exists ->
12989              *
12990              *
12991              * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
12992              * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
12993              * multideref attached as the child, e.g.
12994              *
12995              *     exists
12996              *       |
12997              *     ex-aelem
12998              *       |
12999              *     ex-rv2av  - i_expr1
13000              *       |
13001              *     multideref
13002              *       |
13003              *     ex-whatever
13004              *
13005              */
13006
13007             /* if we free this op, don't free the pad entry */
13008             if (reset_start_targ)
13009                 start->op_targ = 0;
13010
13011
13012             /* Cut the bit we need to save out of the tree and attach to
13013              * the multideref op, then free the rest of the tree */
13014
13015             /* find parent of node to be detached (for use by splice) */
13016             p = first_elem_op;
13017             if (   orig_action == MDEREF_AV_pop_rv2av_aelem
13018                 || orig_action == MDEREF_HV_pop_rv2hv_helem)
13019             {
13020                 /* there is an arbitrary expression preceding us, e.g.
13021                  * expr->[..]? so we need to save the 'expr' subtree */
13022                 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
13023                     p = cUNOPx(p)->op_first;
13024                 ASSUME(   start->op_type == OP_RV2AV
13025                        || start->op_type == OP_RV2HV);
13026             }
13027             else {
13028                 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
13029                  * above for exists/delete. */
13030                 while (   (p->op_flags & OPf_KIDS)
13031                        && cUNOPx(p)->op_first != start
13032                 )
13033                     p = cUNOPx(p)->op_first;
13034             }
13035             ASSUME(cUNOPx(p)->op_first == start);
13036
13037             /* detach from main tree, and re-attach under the multideref */
13038             op_sibling_splice(mderef, NULL, 0,
13039                     op_sibling_splice(p, NULL, 1, NULL));
13040             op_null(start);
13041
13042             start->op_next = mderef;
13043
13044             mderef->op_next = index_skip == -1 ? o->op_next : o;
13045
13046             /* excise and free the original tree, and replace with
13047              * the multideref op */
13048             p = op_sibling_splice(top_op, NULL, -1, mderef);
13049             while (p) {
13050                 q = OpSIBLING(p);
13051                 op_free(p);
13052                 p = q;
13053             }
13054             op_null(top_op);
13055         }
13056         else {
13057             Size_t size = arg - arg_buf;
13058
13059             if (maybe_aelemfast && action_count == 1)
13060                 return;
13061
13062             arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
13063                                 sizeof(UNOP_AUX_item) * (size + 1));
13064             /* for dumping etc: store the length in a hidden first slot;
13065              * we set the op_aux pointer to the second slot */
13066             arg_buf->uv = size;
13067             arg_buf++;
13068         }
13069     } /* for (pass = ...) */
13070 }
13071
13072
13073
13074 /* mechanism for deferring recursion in rpeep() */
13075
13076 #define MAX_DEFERRED 4
13077
13078 #define DEFER(o) \
13079   STMT_START { \
13080     if (defer_ix == (MAX_DEFERRED-1)) { \
13081         OP **defer = defer_queue[defer_base]; \
13082         CALL_RPEEP(*defer); \
13083         S_prune_chain_head(defer); \
13084         defer_base = (defer_base + 1) % MAX_DEFERRED; \
13085         defer_ix--; \
13086     } \
13087     defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
13088   } STMT_END
13089
13090 #define IS_AND_OP(o)   (o->op_type == OP_AND)
13091 #define IS_OR_OP(o)    (o->op_type == OP_OR)
13092
13093
13094 /* A peephole optimizer.  We visit the ops in the order they're to execute.
13095  * See the comments at the top of this file for more details about when
13096  * peep() is called */
13097
13098 void
13099 Perl_rpeep(pTHX_ OP *o)
13100 {
13101     dVAR;
13102     OP* oldop = NULL;
13103     OP* oldoldop = NULL;
13104     OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
13105     int defer_base = 0;
13106     int defer_ix = -1;
13107     OP *fop;
13108     OP *sop;
13109
13110     if (!o || o->op_opt)
13111         return;
13112     ENTER;
13113     SAVEOP();
13114     SAVEVPTR(PL_curcop);
13115     for (;; o = o->op_next) {
13116         if (o && o->op_opt)
13117             o = NULL;
13118         if (!o) {
13119             while (defer_ix >= 0) {
13120                 OP **defer =
13121                         defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
13122                 CALL_RPEEP(*defer);
13123                 S_prune_chain_head(defer);
13124             }
13125             break;
13126         }
13127
13128       redo:
13129         /* By default, this op has now been optimised. A couple of cases below
13130            clear this again.  */
13131         o->op_opt = 1;
13132         PL_op = o;
13133
13134         /* look for a series of 1 or more aggregate derefs, e.g.
13135          *   $a[1]{foo}[$i]{$k}
13136          * and replace with a single OP_MULTIDEREF op.
13137          * Each index must be either a const, or a simple variable,
13138          *
13139          * First, look for likely combinations of starting ops,
13140          * corresponding to (global and lexical variants of)
13141          *     $a[...]   $h{...}
13142          *     $r->[...] $r->{...}
13143          *     (preceding expression)->[...]
13144          *     (preceding expression)->{...}
13145          * and if so, call maybe_multideref() to do a full inspection
13146          * of the op chain and if appropriate, replace with an
13147          * OP_MULTIDEREF
13148          */
13149         {
13150             UV action;
13151             OP *o2 = o;
13152             U8 hints = 0;
13153
13154             switch (o2->op_type) {
13155             case OP_GV:
13156                 /* $pkg[..]   :   gv[*pkg]
13157                  * $pkg->[...]:   gv[*pkg]; rv2sv sKM/DREFAV */
13158
13159                 /* Fail if there are new op flag combinations that we're
13160                  * not aware of, rather than:
13161                  *  * silently failing to optimise, or
13162                  *  * silently optimising the flag away.
13163                  * If this ASSUME starts failing, examine what new flag
13164                  * has been added to the op, and decide whether the
13165                  * optimisation should still occur with that flag, then
13166                  * update the code accordingly. This applies to all the
13167                  * other ASSUMEs in the block of code too.
13168                  */
13169                 ASSUME(!(o2->op_flags &
13170                             ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
13171                 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
13172
13173                 o2 = o2->op_next;
13174
13175                 if (o2->op_type == OP_RV2AV) {
13176                     action = MDEREF_AV_gvav_aelem;
13177                     goto do_deref;
13178                 }
13179
13180                 if (o2->op_type == OP_RV2HV) {
13181                     action = MDEREF_HV_gvhv_helem;
13182                     goto do_deref;
13183                 }
13184
13185                 if (o2->op_type != OP_RV2SV)
13186                     break;
13187
13188                 /* at this point we've seen gv,rv2sv, so the only valid
13189                  * construct left is $pkg->[] or $pkg->{} */
13190
13191                 ASSUME(!(o2->op_flags & OPf_STACKED));
13192                 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13193                             != (OPf_WANT_SCALAR|OPf_MOD))
13194                     break;
13195
13196                 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
13197                                     |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
13198                 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
13199                     break;
13200                 if (   (o2->op_private & OPpDEREF) != OPpDEREF_AV
13201                     && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
13202                     break;
13203
13204                 o2 = o2->op_next;
13205                 if (o2->op_type == OP_RV2AV) {
13206                     action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
13207                     goto do_deref;
13208                 }
13209                 if (o2->op_type == OP_RV2HV) {
13210                     action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
13211                     goto do_deref;
13212                 }
13213                 break;
13214
13215             case OP_PADSV:
13216                 /* $lex->[...]: padsv[$lex] sM/DREFAV */
13217
13218                 ASSUME(!(o2->op_flags &
13219                     ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
13220                 if ((o2->op_flags &
13221                         (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13222                      != (OPf_WANT_SCALAR|OPf_MOD))
13223                     break;
13224
13225                 ASSUME(!(o2->op_private &
13226                                 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
13227                 /* skip if state or intro, or not a deref */
13228                 if (      o2->op_private != OPpDEREF_AV
13229                        && o2->op_private != OPpDEREF_HV)
13230                     break;
13231
13232                 o2 = o2->op_next;
13233                 if (o2->op_type == OP_RV2AV) {
13234                     action = MDEREF_AV_padsv_vivify_rv2av_aelem;
13235                     goto do_deref;
13236                 }
13237                 if (o2->op_type == OP_RV2HV) {
13238                     action = MDEREF_HV_padsv_vivify_rv2hv_helem;
13239                     goto do_deref;
13240                 }
13241                 break;
13242
13243             case OP_PADAV:
13244             case OP_PADHV:
13245                 /*    $lex[..]:  padav[@lex:1,2] sR *
13246                  * or $lex{..}:  padhv[%lex:1,2] sR */
13247                 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
13248                                             OPf_REF|OPf_SPECIAL)));
13249                 if ((o2->op_flags &
13250                         (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13251                      != (OPf_WANT_SCALAR|OPf_REF))
13252                     break;
13253                 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
13254                     break;
13255                 /* OPf_PARENS isn't currently used in this case;
13256                  * if that changes, let us know! */
13257                 ASSUME(!(o2->op_flags & OPf_PARENS));
13258
13259                 /* at this point, we wouldn't expect any of the remaining
13260                  * possible private flags:
13261                  * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
13262                  * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
13263                  *
13264                  * OPpSLICEWARNING shouldn't affect runtime
13265                  */
13266                 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
13267
13268                 action = o2->op_type == OP_PADAV
13269                             ? MDEREF_AV_padav_aelem
13270                             : MDEREF_HV_padhv_helem;
13271                 o2 = o2->op_next;
13272                 S_maybe_multideref(aTHX_ o, o2, action, 0);
13273                 break;
13274
13275
13276             case OP_RV2AV:
13277             case OP_RV2HV:
13278                 action = o2->op_type == OP_RV2AV
13279                             ? MDEREF_AV_pop_rv2av_aelem
13280                             : MDEREF_HV_pop_rv2hv_helem;
13281                 /* FALLTHROUGH */
13282             do_deref:
13283                 /* (expr)->[...]:  rv2av sKR/1;
13284                  * (expr)->{...}:  rv2hv sKR/1; */
13285
13286                 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
13287
13288                 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
13289                                 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
13290                 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
13291                     break;
13292
13293                 /* at this point, we wouldn't expect any of these
13294                  * possible private flags:
13295                  * OPpMAYBE_LVSUB, OPpLVAL_INTRO
13296                  * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
13297                  */
13298                 ASSUME(!(o2->op_private &
13299                     ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
13300                      |OPpOUR_INTRO)));
13301                 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
13302
13303                 o2 = o2->op_next;
13304
13305                 S_maybe_multideref(aTHX_ o, o2, action, hints);
13306                 break;
13307
13308             default:
13309                 break;
13310             }
13311         }
13312
13313
13314         switch (o->op_type) {
13315         case OP_DBSTATE:
13316             PL_curcop = ((COP*)o);              /* for warnings */
13317             break;
13318         case OP_NEXTSTATE:
13319             PL_curcop = ((COP*)o);              /* for warnings */
13320
13321             /* Optimise a "return ..." at the end of a sub to just be "...".
13322              * This saves 2 ops. Before:
13323              * 1  <;> nextstate(main 1 -e:1) v ->2
13324              * 4  <@> return K ->5
13325              * 2    <0> pushmark s ->3
13326              * -    <1> ex-rv2sv sK/1 ->4
13327              * 3      <#> gvsv[*cat] s ->4
13328              *
13329              * After:
13330              * -  <@> return K ->-
13331              * -    <0> pushmark s ->2
13332              * -    <1> ex-rv2sv sK/1 ->-
13333              * 2      <$> gvsv(*cat) s ->3
13334              */
13335             {
13336                 OP *next = o->op_next;
13337                 OP *sibling = OpSIBLING(o);
13338                 if (   OP_TYPE_IS(next, OP_PUSHMARK)
13339                     && OP_TYPE_IS(sibling, OP_RETURN)
13340                     && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
13341                     && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
13342                        ||OP_TYPE_IS(sibling->op_next->op_next,
13343                                     OP_LEAVESUBLV))
13344                     && cUNOPx(sibling)->op_first == next
13345                     && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
13346                     && next->op_next
13347                 ) {
13348                     /* Look through the PUSHMARK's siblings for one that
13349                      * points to the RETURN */
13350                     OP *top = OpSIBLING(next);
13351                     while (top && top->op_next) {
13352                         if (top->op_next == sibling) {
13353                             top->op_next = sibling->op_next;
13354                             o->op_next = next->op_next;
13355                             break;
13356                         }
13357                         top = OpSIBLING(top);
13358                     }
13359                 }
13360             }
13361
13362             /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
13363              *
13364              * This latter form is then suitable for conversion into padrange
13365              * later on. Convert:
13366              *
13367              *   nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
13368              *
13369              * into:
13370              *
13371              *   nextstate1 ->     listop     -> nextstate3
13372              *                 /            \
13373              *         pushmark -> padop1 -> padop2
13374              */
13375             if (o->op_next && (
13376                     o->op_next->op_type == OP_PADSV
13377                  || o->op_next->op_type == OP_PADAV
13378                  || o->op_next->op_type == OP_PADHV
13379                 )
13380                 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
13381                 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
13382                 && o->op_next->op_next->op_next && (
13383                     o->op_next->op_next->op_next->op_type == OP_PADSV
13384                  || o->op_next->op_next->op_next->op_type == OP_PADAV
13385                  || o->op_next->op_next->op_next->op_type == OP_PADHV
13386                 )
13387                 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
13388                 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
13389                 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
13390                 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
13391             ) {
13392                 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
13393
13394                 pad1 =    o->op_next;
13395                 ns2  = pad1->op_next;
13396                 pad2 =  ns2->op_next;
13397                 ns3  = pad2->op_next;
13398
13399                 /* we assume here that the op_next chain is the same as
13400                  * the op_sibling chain */
13401                 assert(OpSIBLING(o)    == pad1);
13402                 assert(OpSIBLING(pad1) == ns2);
13403                 assert(OpSIBLING(ns2)  == pad2);
13404                 assert(OpSIBLING(pad2) == ns3);
13405
13406                 /* excise and delete ns2 */
13407                 op_sibling_splice(NULL, pad1, 1, NULL);
13408                 op_free(ns2);
13409
13410                 /* excise pad1 and pad2 */
13411                 op_sibling_splice(NULL, o, 2, NULL);
13412
13413                 /* create new listop, with children consisting of:
13414                  * a new pushmark, pad1, pad2. */
13415                 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
13416                 newop->op_flags |= OPf_PARENS;
13417                 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
13418
13419                 /* insert newop between o and ns3 */
13420                 op_sibling_splice(NULL, o, 0, newop);
13421
13422                 /*fixup op_next chain */
13423                 newpm = cUNOPx(newop)->op_first; /* pushmark */
13424                 o    ->op_next = newpm;
13425                 newpm->op_next = pad1;
13426                 pad1 ->op_next = pad2;
13427                 pad2 ->op_next = newop; /* listop */
13428                 newop->op_next = ns3;
13429
13430                 /* Ensure pushmark has this flag if padops do */
13431                 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
13432                     newpm->op_flags |= OPf_MOD;
13433                 }
13434
13435                 break;
13436             }
13437
13438             /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
13439                to carry two labels. For now, take the easier option, and skip
13440                this optimisation if the first NEXTSTATE has a label.  */
13441             if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
13442                 OP *nextop = o->op_next;
13443                 while (nextop && nextop->op_type == OP_NULL)
13444                     nextop = nextop->op_next;
13445
13446                 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
13447                     op_null(o);
13448                     if (oldop)
13449                         oldop->op_next = nextop;
13450                     /* Skip (old)oldop assignment since the current oldop's
13451                        op_next already points to the next op.  */
13452                     continue;
13453                 }
13454             }
13455             break;
13456
13457         case OP_CONCAT:
13458             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
13459                 if (o->op_next->op_private & OPpTARGET_MY) {
13460                     if (o->op_flags & OPf_STACKED) /* chained concats */
13461                         break; /* ignore_optimization */
13462                     else {
13463                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
13464                         o->op_targ = o->op_next->op_targ;
13465                         o->op_next->op_targ = 0;
13466                         o->op_private |= OPpTARGET_MY;
13467                     }
13468                 }
13469                 op_null(o->op_next);
13470             }
13471             break;
13472         case OP_STUB:
13473             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
13474                 break; /* Scalar stub must produce undef.  List stub is noop */
13475             }
13476             goto nothin;
13477         case OP_NULL:
13478             if (o->op_targ == OP_NEXTSTATE
13479                 || o->op_targ == OP_DBSTATE)
13480             {
13481                 PL_curcop = ((COP*)o);
13482             }
13483             /* XXX: We avoid setting op_seq here to prevent later calls
13484                to rpeep() from mistakenly concluding that optimisation
13485                has already occurred. This doesn't fix the real problem,
13486                though (See 20010220.007). AMS 20010719 */
13487             /* op_seq functionality is now replaced by op_opt */
13488             o->op_opt = 0;
13489             /* FALLTHROUGH */
13490         case OP_SCALAR:
13491         case OP_LINESEQ:
13492         case OP_SCOPE:
13493         nothin:
13494             if (oldop) {
13495                 oldop->op_next = o->op_next;
13496                 o->op_opt = 0;
13497                 continue;
13498             }
13499             break;
13500
13501         case OP_PUSHMARK:
13502
13503             /* Given
13504                  5 repeat/DOLIST
13505                  3   ex-list
13506                  1     pushmark
13507                  2     scalar or const
13508                  4   const[0]
13509                convert repeat into a stub with no kids.
13510              */
13511             if (o->op_next->op_type == OP_CONST
13512              || (  o->op_next->op_type == OP_PADSV
13513                 && !(o->op_next->op_private & OPpLVAL_INTRO))
13514              || (  o->op_next->op_type == OP_GV
13515                 && o->op_next->op_next->op_type == OP_RV2SV
13516                 && !(o->op_next->op_next->op_private
13517                         & (OPpLVAL_INTRO|OPpOUR_INTRO))))
13518             {
13519                 const OP *kid = o->op_next->op_next;
13520                 if (o->op_next->op_type == OP_GV)
13521                    kid = kid->op_next;
13522                 /* kid is now the ex-list.  */
13523                 if (kid->op_type == OP_NULL
13524                  && (kid = kid->op_next)->op_type == OP_CONST
13525                     /* kid is now the repeat count.  */
13526                  && kid->op_next->op_type == OP_REPEAT
13527                  && kid->op_next->op_private & OPpREPEAT_DOLIST
13528                  && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
13529                  && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0)
13530                 {
13531                     o = kid->op_next; /* repeat */
13532                     assert(oldop);
13533                     oldop->op_next = o;
13534                     op_free(cBINOPo->op_first);
13535                     op_free(cBINOPo->op_last );
13536                     o->op_flags &=~ OPf_KIDS;
13537                     /* stub is a baseop; repeat is a binop */
13538                     STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
13539                     OpTYPE_set(o, OP_STUB);
13540                     o->op_private = 0;
13541                     break;
13542                 }
13543             }
13544
13545             /* Convert a series of PAD ops for my vars plus support into a
13546              * single padrange op. Basically
13547              *
13548              *    pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
13549              *
13550              * becomes, depending on circumstances, one of
13551              *
13552              *    padrange  ----------------------------------> (list) -> rest
13553              *    padrange  --------------------------------------------> rest
13554              *
13555              * where all the pad indexes are sequential and of the same type
13556              * (INTRO or not).
13557              * We convert the pushmark into a padrange op, then skip
13558              * any other pad ops, and possibly some trailing ops.
13559              * Note that we don't null() the skipped ops, to make it
13560              * easier for Deparse to undo this optimisation (and none of
13561              * the skipped ops are holding any resourses). It also makes
13562              * it easier for find_uninit_var(), as it can just ignore
13563              * padrange, and examine the original pad ops.
13564              */
13565         {
13566             OP *p;
13567             OP *followop = NULL; /* the op that will follow the padrange op */
13568             U8 count = 0;
13569             U8 intro = 0;
13570             PADOFFSET base = 0; /* init only to stop compiler whining */
13571             bool gvoid = 0;     /* init only to stop compiler whining */
13572             bool defav = 0;  /* seen (...) = @_ */
13573             bool reuse = 0;  /* reuse an existing padrange op */
13574
13575             /* look for a pushmark -> gv[_] -> rv2av */
13576
13577             {
13578                 OP *rv2av, *q;
13579                 p = o->op_next;
13580                 if (   p->op_type == OP_GV
13581                     && cGVOPx_gv(p) == PL_defgv
13582                     && (rv2av = p->op_next)
13583                     && rv2av->op_type == OP_RV2AV
13584                     && !(rv2av->op_flags & OPf_REF)
13585                     && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
13586                     && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
13587                 ) {
13588                     q = rv2av->op_next;
13589                     if (q->op_type == OP_NULL)
13590                         q = q->op_next;
13591                     if (q->op_type == OP_PUSHMARK) {
13592                         defav = 1;
13593                         p = q;
13594                     }
13595                 }
13596             }
13597             if (!defav) {
13598                 p = o;
13599             }
13600
13601             /* scan for PAD ops */
13602
13603             for (p = p->op_next; p; p = p->op_next) {
13604                 if (p->op_type == OP_NULL)
13605                     continue;
13606
13607                 if ((     p->op_type != OP_PADSV
13608                        && p->op_type != OP_PADAV
13609                        && p->op_type != OP_PADHV
13610                     )
13611                       /* any private flag other than INTRO? e.g. STATE */
13612                    || (p->op_private & ~OPpLVAL_INTRO)
13613                 )
13614                     break;
13615
13616                 /* let $a[N] potentially be optimised into AELEMFAST_LEX
13617                  * instead */
13618                 if (   p->op_type == OP_PADAV
13619                     && p->op_next
13620                     && p->op_next->op_type == OP_CONST
13621                     && p->op_next->op_next
13622                     && p->op_next->op_next->op_type == OP_AELEM
13623                 )
13624                     break;
13625
13626                 /* for 1st padop, note what type it is and the range
13627                  * start; for the others, check that it's the same type
13628                  * and that the targs are contiguous */
13629                 if (count == 0) {
13630                     intro = (p->op_private & OPpLVAL_INTRO);
13631                     base = p->op_targ;
13632                     gvoid = OP_GIMME(p,0) == G_VOID;
13633                 }
13634                 else {
13635                     if ((p->op_private & OPpLVAL_INTRO) != intro)
13636                         break;
13637                     /* Note that you'd normally  expect targs to be
13638                      * contiguous in my($a,$b,$c), but that's not the case
13639                      * when external modules start doing things, e.g.
13640                      i* Function::Parameters */
13641                     if (p->op_targ != base + count)
13642                         break;
13643                     assert(p->op_targ == base + count);
13644                     /* Either all the padops or none of the padops should
13645                        be in void context.  Since we only do the optimisa-
13646                        tion for av/hv when the aggregate itself is pushed
13647                        on to the stack (one item), there is no need to dis-
13648                        tinguish list from scalar context.  */
13649                     if (gvoid != (OP_GIMME(p,0) == G_VOID))
13650                         break;
13651                 }
13652
13653                 /* for AV, HV, only when we're not flattening */
13654                 if (   p->op_type != OP_PADSV
13655                     && !gvoid
13656                     && !(p->op_flags & OPf_REF)
13657                 )
13658                     break;
13659
13660                 if (count >= OPpPADRANGE_COUNTMASK)
13661                     break;
13662
13663                 /* there's a biggest base we can fit into a
13664                  * SAVEt_CLEARPADRANGE in pp_padrange */
13665                 if (intro && base >
13666                         (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)))
13667                     break;
13668
13669                 /* Success! We've got another valid pad op to optimise away */
13670                 count++;
13671                 followop = p->op_next;
13672             }
13673
13674             if (count < 1 || (count == 1 && !defav))
13675                 break;
13676
13677             /* pp_padrange in specifically compile-time void context
13678              * skips pushing a mark and lexicals; in all other contexts
13679              * (including unknown till runtime) it pushes a mark and the
13680              * lexicals. We must be very careful then, that the ops we
13681              * optimise away would have exactly the same effect as the
13682              * padrange.
13683              * In particular in void context, we can only optimise to
13684              * a padrange if see see the complete sequence
13685              *     pushmark, pad*v, ...., list
13686              * which has the net effect of of leaving the markstack as it
13687              * was.  Not pushing on to the stack (whereas padsv does touch
13688              * the stack) makes no difference in void context.
13689              */
13690             assert(followop);
13691             if (gvoid) {
13692                 if (followop->op_type == OP_LIST
13693                         && OP_GIMME(followop,0) == G_VOID
13694                    )
13695                 {
13696                     followop = followop->op_next; /* skip OP_LIST */
13697
13698                     /* consolidate two successive my(...);'s */
13699
13700                     if (   oldoldop
13701                         && oldoldop->op_type == OP_PADRANGE
13702                         && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
13703                         && (oldoldop->op_private & OPpLVAL_INTRO) == intro
13704                         && !(oldoldop->op_flags & OPf_SPECIAL)
13705                     ) {
13706                         U8 old_count;
13707                         assert(oldoldop->op_next == oldop);
13708                         assert(   oldop->op_type == OP_NEXTSTATE
13709                                || oldop->op_type == OP_DBSTATE);
13710                         assert(oldop->op_next == o);
13711
13712                         old_count
13713                             = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
13714
13715                        /* Do not assume pad offsets for $c and $d are con-
13716                           tiguous in
13717                             my ($a,$b,$c);
13718                             my ($d,$e,$f);
13719                         */
13720                         if (  oldoldop->op_targ + old_count == base
13721                            && old_count < OPpPADRANGE_COUNTMASK - count) {
13722                             base = oldoldop->op_targ;
13723                             count += old_count;
13724                             reuse = 1;
13725                         }
13726                     }
13727
13728                     /* if there's any immediately following singleton
13729                      * my var's; then swallow them and the associated
13730                      * nextstates; i.e.
13731                      *    my ($a,$b); my $c; my $d;
13732                      * is treated as
13733                      *    my ($a,$b,$c,$d);
13734                      */
13735
13736                     while (    ((p = followop->op_next))
13737                             && (  p->op_type == OP_PADSV
13738                                || p->op_type == OP_PADAV
13739                                || p->op_type == OP_PADHV)
13740                             && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
13741                             && (p->op_private & OPpLVAL_INTRO) == intro
13742                             && !(p->op_private & ~OPpLVAL_INTRO)
13743                             && p->op_next
13744                             && (   p->op_next->op_type == OP_NEXTSTATE
13745                                 || p->op_next->op_type == OP_DBSTATE)
13746                             && count < OPpPADRANGE_COUNTMASK
13747                             && base + count == p->op_targ
13748                     ) {
13749                         count++;
13750                         followop = p->op_next;
13751                     }
13752                 }
13753                 else
13754                     break;
13755             }
13756
13757             if (reuse) {
13758                 assert(oldoldop->op_type == OP_PADRANGE);
13759                 oldoldop->op_next = followop;
13760                 oldoldop->op_private = (intro | count);
13761                 o = oldoldop;
13762                 oldop = NULL;
13763                 oldoldop = NULL;
13764             }
13765             else {
13766                 /* Convert the pushmark into a padrange.
13767                  * To make Deparse easier, we guarantee that a padrange was
13768                  * *always* formerly a pushmark */
13769                 assert(o->op_type == OP_PUSHMARK);
13770                 o->op_next = followop;
13771                 OpTYPE_set(o, OP_PADRANGE);
13772                 o->op_targ = base;
13773                 /* bit 7: INTRO; bit 6..0: count */
13774                 o->op_private = (intro | count);
13775                 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
13776                               | gvoid * OPf_WANT_VOID
13777                               | (defav ? OPf_SPECIAL : 0));
13778             }
13779             break;
13780         }
13781
13782         case OP_PADAV:
13783         case OP_PADSV:
13784         case OP_PADHV:
13785         /* Skip over state($x) in void context.  */
13786         if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
13787          && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
13788         {
13789             oldop->op_next = o->op_next;
13790             goto redo_nextstate;
13791         }
13792         if (o->op_type != OP_PADAV)
13793             break;
13794         /* FALLTHROUGH */
13795         case OP_GV:
13796             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
13797                 OP* const pop = (o->op_type == OP_PADAV) ?
13798                             o->op_next : o->op_next->op_next;
13799                 IV i;
13800                 if (pop && pop->op_type == OP_CONST &&
13801                     ((PL_op = pop->op_next)) &&
13802                     pop->op_next->op_type == OP_AELEM &&
13803                     !(pop->op_next->op_private &
13804                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
13805                     (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
13806                 {
13807                     GV *gv;
13808                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
13809                         no_bareword_allowed(pop);
13810                     if (o->op_type == OP_GV)
13811                         op_null(o->op_next);
13812                     op_null(pop->op_next);
13813                     op_null(pop);
13814                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
13815                     o->op_next = pop->op_next->op_next;
13816                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
13817                     o->op_private = (U8)i;
13818                     if (o->op_type == OP_GV) {
13819                         gv = cGVOPo_gv;
13820                         GvAVn(gv);
13821                         o->op_type = OP_AELEMFAST;
13822                     }
13823                     else
13824                         o->op_type = OP_AELEMFAST_LEX;
13825                 }
13826                 if (o->op_type != OP_GV)
13827                     break;
13828             }
13829
13830             /* Remove $foo from the op_next chain in void context.  */
13831             if (oldop
13832              && (  o->op_next->op_type == OP_RV2SV
13833                 || o->op_next->op_type == OP_RV2AV
13834                 || o->op_next->op_type == OP_RV2HV  )
13835              && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
13836              && !(o->op_next->op_private & OPpLVAL_INTRO))
13837             {
13838                 oldop->op_next = o->op_next->op_next;
13839                 /* Reprocess the previous op if it is a nextstate, to
13840                    allow double-nextstate optimisation.  */
13841               redo_nextstate:
13842                 if (oldop->op_type == OP_NEXTSTATE) {
13843                     oldop->op_opt = 0;
13844                     o = oldop;
13845                     oldop = oldoldop;
13846                     oldoldop = NULL;
13847                     goto redo;
13848                 }
13849                 o = oldop;
13850             }
13851             else if (o->op_next->op_type == OP_RV2SV) {
13852                 if (!(o->op_next->op_private & OPpDEREF)) {
13853                     op_null(o->op_next);
13854                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
13855                                                                | OPpOUR_INTRO);
13856                     o->op_next = o->op_next->op_next;
13857                     OpTYPE_set(o, OP_GVSV);
13858                 }
13859             }
13860             else if (o->op_next->op_type == OP_READLINE
13861                     && o->op_next->op_next->op_type == OP_CONCAT
13862                     && (o->op_next->op_next->op_flags & OPf_STACKED))
13863             {
13864                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
13865                 OpTYPE_set(o, OP_RCATLINE);
13866                 o->op_flags |= OPf_STACKED;
13867                 op_null(o->op_next->op_next);
13868                 op_null(o->op_next);
13869             }
13870
13871             break;
13872
13873 #define HV_OR_SCALARHV(op)                                   \
13874     (  (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \
13875        ? (op)                                                  \
13876        : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \
13877        && (  cUNOPx(op)->op_first->op_type == OP_PADHV          \
13878           || cUNOPx(op)->op_first->op_type == OP_RV2HV)          \
13879          ? cUNOPx(op)->op_first                                   \
13880          : NULL)
13881
13882         case OP_NOT:
13883             if ((fop = HV_OR_SCALARHV(cUNOP->op_first)))
13884                 fop->op_private |= OPpTRUEBOOL;
13885             break;
13886
13887         case OP_AND:
13888         case OP_OR:
13889         case OP_DOR:
13890             fop = cLOGOP->op_first;
13891             sop = OpSIBLING(fop);
13892             while (cLOGOP->op_other->op_type == OP_NULL)
13893                 cLOGOP->op_other = cLOGOP->op_other->op_next;
13894             while (o->op_next && (   o->op_type == o->op_next->op_type
13895                                   || o->op_next->op_type == OP_NULL))
13896                 o->op_next = o->op_next->op_next;
13897
13898             /* if we're an OR and our next is a AND in void context, we'll
13899                follow it's op_other on short circuit, same for reverse.
13900                We can't do this with OP_DOR since if it's true, its return
13901                value is the underlying value which must be evaluated
13902                by the next op */
13903             if (o->op_next &&
13904                 (
13905                     (IS_AND_OP(o) && IS_OR_OP(o->op_next))
13906                  || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
13907                 )
13908                 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
13909             ) {
13910                 o->op_next = ((LOGOP*)o->op_next)->op_other;
13911             }
13912             DEFER(cLOGOP->op_other);
13913
13914             o->op_opt = 1;
13915             fop = HV_OR_SCALARHV(fop);
13916             if (sop) sop = HV_OR_SCALARHV(sop);
13917             if (fop || sop
13918             ){
13919                 OP * nop = o;
13920                 OP * lop = o;
13921                 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
13922                     while (nop && nop->op_next) {
13923                         switch (nop->op_next->op_type) {
13924                             case OP_NOT:
13925                             case OP_AND:
13926                             case OP_OR:
13927                             case OP_DOR:
13928                                 lop = nop = nop->op_next;
13929                                 break;
13930                             case OP_NULL:
13931                                 nop = nop->op_next;
13932                                 break;
13933                             default:
13934                                 nop = NULL;
13935                                 break;
13936                         }
13937                     }
13938                 }
13939                 if (fop) {
13940                     if (  (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
13941                       || o->op_type == OP_AND  )
13942                         fop->op_private |= OPpTRUEBOOL;
13943                     else if (!(lop->op_flags & OPf_WANT))
13944                         fop->op_private |= OPpMAYBE_TRUEBOOL;
13945                 }
13946                 if (  (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
13947                    && sop)
13948                     sop->op_private |= OPpTRUEBOOL;
13949             }
13950
13951
13952             break;
13953
13954         case OP_COND_EXPR:
13955             if ((fop = HV_OR_SCALARHV(cLOGOP->op_first)))
13956                 fop->op_private |= OPpTRUEBOOL;
13957 #undef HV_OR_SCALARHV
13958             /* GERONIMO! */ /* FALLTHROUGH */
13959
13960         case OP_MAPWHILE:
13961         case OP_GREPWHILE:
13962         case OP_ANDASSIGN:
13963         case OP_ORASSIGN:
13964         case OP_DORASSIGN:
13965         case OP_RANGE:
13966         case OP_ONCE:
13967             while (cLOGOP->op_other->op_type == OP_NULL)
13968                 cLOGOP->op_other = cLOGOP->op_other->op_next;
13969             DEFER(cLOGOP->op_other);
13970             break;
13971
13972         case OP_ENTERLOOP:
13973         case OP_ENTERITER:
13974             while (cLOOP->op_redoop->op_type == OP_NULL)
13975                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
13976             while (cLOOP->op_nextop->op_type == OP_NULL)
13977                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
13978             while (cLOOP->op_lastop->op_type == OP_NULL)
13979                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
13980             /* a while(1) loop doesn't have an op_next that escapes the
13981              * loop, so we have to explicitly follow the op_lastop to
13982              * process the rest of the code */
13983             DEFER(cLOOP->op_lastop);
13984             break;
13985
13986         case OP_ENTERTRY:
13987             assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
13988             DEFER(cLOGOPo->op_other);
13989             break;
13990
13991         case OP_SUBST:
13992             assert(!(cPMOP->op_pmflags & PMf_ONCE));
13993             while (cPMOP->op_pmstashstartu.op_pmreplstart &&
13994                    cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
13995                 cPMOP->op_pmstashstartu.op_pmreplstart
13996                     = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
13997             DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
13998             break;
13999
14000         case OP_SORT: {
14001             OP *oright;
14002
14003             if (o->op_flags & OPf_SPECIAL) {
14004                 /* first arg is a code block */
14005                 OP * const nullop = OpSIBLING(cLISTOP->op_first);
14006                 OP * kid          = cUNOPx(nullop)->op_first;
14007
14008                 assert(nullop->op_type == OP_NULL);
14009                 assert(kid->op_type == OP_SCOPE
14010                  || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
14011                 /* since OP_SORT doesn't have a handy op_other-style
14012                  * field that can point directly to the start of the code
14013                  * block, store it in the otherwise-unused op_next field
14014                  * of the top-level OP_NULL. This will be quicker at
14015                  * run-time, and it will also allow us to remove leading
14016                  * OP_NULLs by just messing with op_nexts without
14017                  * altering the basic op_first/op_sibling layout. */
14018                 kid = kLISTOP->op_first;
14019                 assert(
14020                       (kid->op_type == OP_NULL
14021                       && (  kid->op_targ == OP_NEXTSTATE
14022                          || kid->op_targ == OP_DBSTATE  ))
14023                     || kid->op_type == OP_STUB
14024                     || kid->op_type == OP_ENTER);
14025                 nullop->op_next = kLISTOP->op_next;
14026                 DEFER(nullop->op_next);
14027             }
14028
14029             /* check that RHS of sort is a single plain array */
14030             oright = cUNOPo->op_first;
14031             if (!oright || oright->op_type != OP_PUSHMARK)
14032                 break;
14033
14034             if (o->op_private & OPpSORT_INPLACE)
14035                 break;
14036
14037             /* reverse sort ... can be optimised.  */
14038             if (!OpHAS_SIBLING(cUNOPo)) {
14039                 /* Nothing follows us on the list. */
14040                 OP * const reverse = o->op_next;
14041
14042                 if (reverse->op_type == OP_REVERSE &&
14043                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
14044                     OP * const pushmark = cUNOPx(reverse)->op_first;
14045                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
14046                         && (OpSIBLING(cUNOPx(pushmark)) == o)) {
14047                         /* reverse -> pushmark -> sort */
14048                         o->op_private |= OPpSORT_REVERSE;
14049                         op_null(reverse);
14050                         pushmark->op_next = oright->op_next;
14051                         op_null(oright);
14052                     }
14053                 }
14054             }
14055
14056             break;
14057         }
14058
14059         case OP_REVERSE: {
14060             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
14061             OP *gvop = NULL;
14062             LISTOP *enter, *exlist;
14063
14064             if (o->op_private & OPpSORT_INPLACE)
14065                 break;
14066
14067             enter = (LISTOP *) o->op_next;
14068             if (!enter)
14069                 break;
14070             if (enter->op_type == OP_NULL) {
14071                 enter = (LISTOP *) enter->op_next;
14072                 if (!enter)
14073                     break;
14074             }
14075             /* for $a (...) will have OP_GV then OP_RV2GV here.
14076                for (...) just has an OP_GV.  */
14077             if (enter->op_type == OP_GV) {
14078                 gvop = (OP *) enter;
14079                 enter = (LISTOP *) enter->op_next;
14080                 if (!enter)
14081                     break;
14082                 if (enter->op_type == OP_RV2GV) {
14083                   enter = (LISTOP *) enter->op_next;
14084                   if (!enter)
14085                     break;
14086                 }
14087             }
14088
14089             if (enter->op_type != OP_ENTERITER)
14090                 break;
14091
14092             iter = enter->op_next;
14093             if (!iter || iter->op_type != OP_ITER)
14094                 break;
14095
14096             expushmark = enter->op_first;
14097             if (!expushmark || expushmark->op_type != OP_NULL
14098                 || expushmark->op_targ != OP_PUSHMARK)
14099                 break;
14100
14101             exlist = (LISTOP *) OpSIBLING(expushmark);
14102             if (!exlist || exlist->op_type != OP_NULL
14103                 || exlist->op_targ != OP_LIST)
14104                 break;
14105
14106             if (exlist->op_last != o) {
14107                 /* Mmm. Was expecting to point back to this op.  */
14108                 break;
14109             }
14110             theirmark = exlist->op_first;
14111             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
14112                 break;
14113
14114             if (OpSIBLING(theirmark) != o) {
14115                 /* There's something between the mark and the reverse, eg
14116                    for (1, reverse (...))
14117                    so no go.  */
14118                 break;
14119             }
14120
14121             ourmark = ((LISTOP *)o)->op_first;
14122             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
14123                 break;
14124
14125             ourlast = ((LISTOP *)o)->op_last;
14126             if (!ourlast || ourlast->op_next != o)
14127                 break;
14128
14129             rv2av = OpSIBLING(ourmark);
14130             if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
14131                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
14132                 /* We're just reversing a single array.  */
14133                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
14134                 enter->op_flags |= OPf_STACKED;
14135             }
14136
14137             /* We don't have control over who points to theirmark, so sacrifice
14138                ours.  */
14139             theirmark->op_next = ourmark->op_next;
14140             theirmark->op_flags = ourmark->op_flags;
14141             ourlast->op_next = gvop ? gvop : (OP *) enter;
14142             op_null(ourmark);
14143             op_null(o);
14144             enter->op_private |= OPpITER_REVERSED;
14145             iter->op_private |= OPpITER_REVERSED;
14146
14147             break;
14148         }
14149
14150         case OP_QR:
14151         case OP_MATCH:
14152             if (!(cPMOP->op_pmflags & PMf_ONCE)) {
14153                 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
14154             }
14155             break;
14156
14157         case OP_RUNCV:
14158             if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
14159              && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
14160             {
14161                 SV *sv;
14162                 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
14163                 else {
14164                     sv = newRV((SV *)PL_compcv);
14165                     sv_rvweaken(sv);
14166                     SvREADONLY_on(sv);
14167                 }
14168                 OpTYPE_set(o, OP_CONST);
14169                 o->op_flags |= OPf_SPECIAL;
14170                 cSVOPo->op_sv = sv;
14171             }
14172             break;
14173
14174         case OP_SASSIGN:
14175             if (OP_GIMME(o,0) == G_VOID
14176              || (  o->op_next->op_type == OP_LINESEQ
14177                 && (  o->op_next->op_next->op_type == OP_LEAVESUB
14178                    || (  o->op_next->op_next->op_type == OP_RETURN
14179                       && !CvLVALUE(PL_compcv)))))
14180             {
14181                 OP *right = cBINOP->op_first;
14182                 if (right) {
14183                     /*   sassign
14184                     *      RIGHT
14185                     *      substr
14186                     *         pushmark
14187                     *         arg1
14188                     *         arg2
14189                     *         ...
14190                     * becomes
14191                     *
14192                     *  ex-sassign
14193                     *     substr
14194                     *        pushmark
14195                     *        RIGHT
14196                     *        arg1
14197                     *        arg2
14198                     *        ...
14199                     */
14200                     OP *left = OpSIBLING(right);
14201                     if (left->op_type == OP_SUBSTR
14202                          && (left->op_private & 7) < 4) {
14203                         op_null(o);
14204                         /* cut out right */
14205                         op_sibling_splice(o, NULL, 1, NULL);
14206                         /* and insert it as second child of OP_SUBSTR */
14207                         op_sibling_splice(left, cBINOPx(left)->op_first, 0,
14208                                     right);
14209                         left->op_private |= OPpSUBSTR_REPL_FIRST;
14210                         left->op_flags =
14211                             (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
14212                     }
14213                 }
14214             }
14215             break;
14216
14217         case OP_AASSIGN: {
14218             int l, r, lr, lscalars, rscalars;
14219
14220             /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
14221                Note that we do this now rather than in newASSIGNOP(),
14222                since only by now are aliased lexicals flagged as such
14223
14224                See the essay "Common vars in list assignment" above for
14225                the full details of the rationale behind all the conditions
14226                below.
14227
14228                PL_generation sorcery:
14229                To detect whether there are common vars, the global var
14230                PL_generation is incremented for each assign op we scan.
14231                Then we run through all the lexical variables on the LHS,
14232                of the assignment, setting a spare slot in each of them to
14233                PL_generation.  Then we scan the RHS, and if any lexicals
14234                already have that value, we know we've got commonality.
14235                Also, if the generation number is already set to
14236                PERL_INT_MAX, then the variable is involved in aliasing, so
14237                we also have potential commonality in that case.
14238              */
14239
14240             PL_generation++;
14241             /* scan LHS */
14242             lscalars = 0;
14243             l = S_aassign_scan(aTHX_ cLISTOPo->op_last,  FALSE, 1, &lscalars);
14244             /* scan RHS */
14245             rscalars = 0;
14246             r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, 1, &rscalars);
14247             lr = (l|r);
14248
14249
14250             /* After looking for things which are *always* safe, this main
14251              * if/else chain selects primarily based on the type of the
14252              * LHS, gradually working its way down from the more dangerous
14253              * to the more restrictive and thus safer cases */
14254
14255             if (   !l                      /* () = ....; */
14256                 || !r                      /* .... = (); */
14257                 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
14258                 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
14259                 || (lscalars < 2)          /* ($x, undef) = ... */
14260             ) {
14261                 NOOP; /* always safe */
14262             }
14263             else if (l & AAS_DANGEROUS) {
14264                 /* always dangerous */
14265                 o->op_private |= OPpASSIGN_COMMON_SCALAR;
14266                 o->op_private |= OPpASSIGN_COMMON_AGG;
14267             }
14268             else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
14269                 /* package vars are always dangerous - too many
14270                  * aliasing possibilities */
14271                 if (l & AAS_PKG_SCALAR)
14272                     o->op_private |= OPpASSIGN_COMMON_SCALAR;
14273                 if (l & AAS_PKG_AGG)
14274                     o->op_private |= OPpASSIGN_COMMON_AGG;
14275             }
14276             else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
14277                           |AAS_LEX_SCALAR|AAS_LEX_AGG))
14278             {
14279                 /* LHS contains only lexicals and safe ops */
14280
14281                 if (l & (AAS_MY_AGG|AAS_LEX_AGG))
14282                     o->op_private |= OPpASSIGN_COMMON_AGG;
14283
14284                 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
14285                     if (lr & AAS_LEX_SCALAR_COMM)
14286                         o->op_private |= OPpASSIGN_COMMON_SCALAR;
14287                     else if (   !(l & AAS_LEX_SCALAR)
14288                              && (r & AAS_DEFAV))
14289                     {
14290                         /* falsely mark
14291                          *    my (...) = @_
14292                          * as scalar-safe for performance reasons.
14293                          * (it will still have been marked _AGG if necessary */
14294                         NOOP;
14295                     }
14296                     else if (r  & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
14297                         o->op_private |= OPpASSIGN_COMMON_RC1;
14298                 }
14299             }
14300
14301             /* ... = ($x)
14302              * may have to handle aggregate on LHS, but we can't
14303              * have common scalars. */
14304             if (rscalars < 2)
14305                 o->op_private &=
14306                         ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
14307
14308             break;
14309         }
14310
14311         case OP_CUSTOM: {
14312             Perl_cpeep_t cpeep =
14313                 XopENTRYCUSTOM(o, xop_peep);
14314             if (cpeep)
14315                 cpeep(aTHX_ o, oldop);
14316             break;
14317         }
14318
14319         }
14320         /* did we just null the current op? If so, re-process it to handle
14321          * eliding "empty" ops from the chain */
14322         if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
14323             o->op_opt = 0;
14324             o = oldop;
14325         }
14326         else {
14327             oldoldop = oldop;
14328             oldop = o;
14329         }
14330     }
14331     LEAVE;
14332 }
14333
14334 void
14335 Perl_peep(pTHX_ OP *o)
14336 {
14337     CALL_RPEEP(o);
14338 }
14339
14340 /*
14341 =head1 Custom Operators
14342
14343 =for apidoc Ao||custom_op_xop
14344 Return the XOP structure for a given custom op.  This macro should be
14345 considered internal to C<OP_NAME> and the other access macros: use them instead.
14346 This macro does call a function.  Prior
14347 to 5.19.6, this was implemented as a
14348 function.
14349
14350 =cut
14351 */
14352
14353 XOPRETANY
14354 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
14355 {
14356     SV *keysv;
14357     HE *he = NULL;
14358     XOP *xop;
14359
14360     static const XOP xop_null = { 0, 0, 0, 0, 0 };
14361
14362     PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
14363     assert(o->op_type == OP_CUSTOM);
14364
14365     /* This is wrong. It assumes a function pointer can be cast to IV,
14366      * which isn't guaranteed, but this is what the old custom OP code
14367      * did. In principle it should be safer to Copy the bytes of the
14368      * pointer into a PV: since the new interface is hidden behind
14369      * functions, this can be changed later if necessary.  */
14370     /* Change custom_op_xop if this ever happens */
14371     keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
14372
14373     if (PL_custom_ops)
14374         he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
14375
14376     /* assume noone will have just registered a desc */
14377     if (!he && PL_custom_op_names &&
14378         (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
14379     ) {
14380         const char *pv;
14381         STRLEN l;
14382
14383         /* XXX does all this need to be shared mem? */
14384         Newxz(xop, 1, XOP);
14385         pv = SvPV(HeVAL(he), l);
14386         XopENTRY_set(xop, xop_name, savepvn(pv, l));
14387         if (PL_custom_op_descs &&
14388             (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
14389         ) {
14390             pv = SvPV(HeVAL(he), l);
14391             XopENTRY_set(xop, xop_desc, savepvn(pv, l));
14392         }
14393         Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
14394     }
14395     else {
14396         if (!he)
14397             xop = (XOP *)&xop_null;
14398         else
14399             xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
14400     }
14401     {
14402         XOPRETANY any;
14403         if(field == XOPe_xop_ptr) {
14404             any.xop_ptr = xop;
14405         } else {
14406             const U32 flags = XopFLAGS(xop);
14407             if(flags & field) {
14408                 switch(field) {
14409                 case XOPe_xop_name:
14410                     any.xop_name = xop->xop_name;
14411                     break;
14412                 case XOPe_xop_desc:
14413                     any.xop_desc = xop->xop_desc;
14414                     break;
14415                 case XOPe_xop_class:
14416                     any.xop_class = xop->xop_class;
14417                     break;
14418                 case XOPe_xop_peep:
14419                     any.xop_peep = xop->xop_peep;
14420                     break;
14421                 default:
14422                     NOT_REACHED; /* NOTREACHED */
14423                     break;
14424                 }
14425             } else {
14426                 switch(field) {
14427                 case XOPe_xop_name:
14428                     any.xop_name = XOPd_xop_name;
14429                     break;
14430                 case XOPe_xop_desc:
14431                     any.xop_desc = XOPd_xop_desc;
14432                     break;
14433                 case XOPe_xop_class:
14434                     any.xop_class = XOPd_xop_class;
14435                     break;
14436                 case XOPe_xop_peep:
14437                     any.xop_peep = XOPd_xop_peep;
14438                     break;
14439                 default:
14440                     NOT_REACHED; /* NOTREACHED */
14441                     break;
14442                 }
14443             }
14444         }
14445         /* Some gcc releases emit a warning for this function:
14446          * op.c: In function 'Perl_custom_op_get_field':
14447          * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
14448          * Whether this is true, is currently unknown. */
14449         return any;
14450     }
14451 }
14452
14453 /*
14454 =for apidoc Ao||custom_op_register
14455 Register a custom op.  See L<perlguts/"Custom Operators">.
14456
14457 =cut
14458 */
14459
14460 void
14461 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
14462 {
14463     SV *keysv;
14464
14465     PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
14466
14467     /* see the comment in custom_op_xop */
14468     keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
14469
14470     if (!PL_custom_ops)
14471         PL_custom_ops = newHV();
14472
14473     if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
14474         Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
14475 }
14476
14477 /*
14478
14479 =for apidoc core_prototype
14480
14481 This function assigns the prototype of the named core function to C<sv>, or
14482 to a new mortal SV if C<sv> is C<NULL>.  It returns the modified C<sv>, or
14483 C<NULL> if the core function has no prototype.  C<code> is a code as returned
14484 by C<keyword()>.  It must not be equal to 0.
14485
14486 =cut
14487 */
14488
14489 SV *
14490 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
14491                           int * const opnum)
14492 {
14493     int i = 0, n = 0, seen_question = 0, defgv = 0;
14494     I32 oa;
14495 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
14496     char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
14497     bool nullret = FALSE;
14498
14499     PERL_ARGS_ASSERT_CORE_PROTOTYPE;
14500
14501     assert (code);
14502
14503     if (!sv) sv = sv_newmortal();
14504
14505 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
14506
14507     switch (code < 0 ? -code : code) {
14508     case KEY_and   : case KEY_chop: case KEY_chomp:
14509     case KEY_cmp   : case KEY_defined: case KEY_delete: case KEY_exec  :
14510     case KEY_exists: case KEY_eq     : case KEY_ge    : case KEY_goto  :
14511     case KEY_grep  : case KEY_gt     : case KEY_last  : case KEY_le    :
14512     case KEY_lt    : case KEY_map    : case KEY_ne    : case KEY_next  :
14513     case KEY_or    : case KEY_print  : case KEY_printf: case KEY_qr    :
14514     case KEY_redo  : case KEY_require: case KEY_return: case KEY_say   :
14515     case KEY_select: case KEY_sort   : case KEY_split : case KEY_system:
14516     case KEY_x     : case KEY_xor    :
14517         if (!opnum) return NULL; nullret = TRUE; goto findopnum;
14518     case KEY_glob:    retsetpvs("_;", OP_GLOB);
14519     case KEY_keys:    retsetpvs("\\[%@]", OP_KEYS);
14520     case KEY_values:  retsetpvs("\\[%@]", OP_VALUES);
14521     case KEY_each:    retsetpvs("\\[%@]", OP_EACH);
14522     case KEY_push:    retsetpvs("\\@@", OP_PUSH);
14523     case KEY_unshift: retsetpvs("\\@@", OP_UNSHIFT);
14524     case KEY_pop:     retsetpvs(";\\@", OP_POP);
14525     case KEY_shift:   retsetpvs(";\\@", OP_SHIFT);
14526     case KEY_pos:     retsetpvs(";\\[$*]", OP_POS);
14527     case KEY_splice:
14528         retsetpvs("\\@;$$@", OP_SPLICE);
14529     case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
14530         retsetpvs("", 0);
14531     case KEY_evalbytes:
14532         name = "entereval"; break;
14533     case KEY_readpipe:
14534         name = "backtick";
14535     }
14536
14537 #undef retsetpvs
14538
14539   findopnum:
14540     while (i < MAXO) {  /* The slow way. */
14541         if (strEQ(name, PL_op_name[i])
14542             || strEQ(name, PL_op_desc[i]))
14543         {
14544             if (nullret) { assert(opnum); *opnum = i; return NULL; }
14545             goto found;
14546         }
14547         i++;
14548     }
14549     return NULL;
14550   found:
14551     defgv = PL_opargs[i] & OA_DEFGV;
14552     oa = PL_opargs[i] >> OASHIFT;
14553     while (oa) {
14554         if (oa & OA_OPTIONAL && !seen_question && (
14555               !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
14556         )) {
14557             seen_question = 1;
14558             str[n++] = ';';
14559         }
14560         if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
14561             && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
14562             /* But globs are already references (kinda) */
14563             && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
14564         ) {
14565             str[n++] = '\\';
14566         }
14567         if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
14568          && !scalar_mod_type(NULL, i)) {
14569             str[n++] = '[';
14570             str[n++] = '$';
14571             str[n++] = '@';
14572             str[n++] = '%';
14573             if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
14574             str[n++] = '*';
14575             str[n++] = ']';
14576         }
14577         else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
14578         if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
14579             str[n-1] = '_'; defgv = 0;
14580         }
14581         oa = oa >> 4;
14582     }
14583     if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
14584     str[n++] = '\0';
14585     sv_setpvn(sv, str, n - 1);
14586     if (opnum) *opnum = i;
14587     return sv;
14588 }
14589
14590 OP *
14591 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
14592                       const int opnum)
14593 {
14594     OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
14595     OP *o;
14596
14597     PERL_ARGS_ASSERT_CORESUB_OP;
14598
14599     switch(opnum) {
14600     case 0:
14601         return op_append_elem(OP_LINESEQ,
14602                        argop,
14603                        newSLICEOP(0,
14604                                   newSVOP(OP_CONST, 0, newSViv(-code % 3)),
14605                                   newOP(OP_CALLER,0)
14606                        )
14607                );
14608     case OP_SELECT: /* which represents OP_SSELECT as well */
14609         if (code)
14610             return newCONDOP(
14611                          0,
14612                          newBINOP(OP_GT, 0,
14613                                   newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
14614                                   newSVOP(OP_CONST, 0, newSVuv(1))
14615                                  ),
14616                          coresub_op(newSVuv((UV)OP_SSELECT), 0,
14617                                     OP_SSELECT),
14618                          coresub_op(coreargssv, 0, OP_SELECT)
14619                    );
14620         /* FALLTHROUGH */
14621     default:
14622         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
14623         case OA_BASEOP:
14624             return op_append_elem(
14625                         OP_LINESEQ, argop,
14626                         newOP(opnum,
14627                               opnum == OP_WANTARRAY || opnum == OP_RUNCV
14628                                 ? OPpOFFBYONE << 8 : 0)
14629                    );
14630         case OA_BASEOP_OR_UNOP:
14631             if (opnum == OP_ENTEREVAL) {
14632                 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
14633                 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
14634             }
14635             else o = newUNOP(opnum,0,argop);
14636             if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
14637             else {
14638           onearg:
14639               if (is_handle_constructor(o, 1))
14640                 argop->op_private |= OPpCOREARGS_DEREF1;
14641               if (scalar_mod_type(NULL, opnum))
14642                 argop->op_private |= OPpCOREARGS_SCALARMOD;
14643             }
14644             return o;
14645         default:
14646             o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
14647             if (is_handle_constructor(o, 2))
14648                 argop->op_private |= OPpCOREARGS_DEREF2;
14649             if (opnum == OP_SUBSTR) {
14650                 o->op_private |= OPpMAYBE_LVSUB;
14651                 return o;
14652             }
14653             else goto onearg;
14654         }
14655     }
14656 }
14657
14658 void
14659 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
14660                                SV * const *new_const_svp)
14661 {
14662     const char *hvname;
14663     bool is_const = !!CvCONST(old_cv);
14664     SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
14665
14666     PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
14667
14668     if (is_const && new_const_svp && old_const_sv == *new_const_svp)
14669         return;
14670         /* They are 2 constant subroutines generated from
14671            the same constant. This probably means that
14672            they are really the "same" proxy subroutine
14673            instantiated in 2 places. Most likely this is
14674            when a constant is exported twice.  Don't warn.
14675         */
14676     if (
14677         (ckWARN(WARN_REDEFINE)
14678          && !(
14679                 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
14680              && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
14681              && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
14682                  strEQ(hvname, "autouse"))
14683              )
14684         )
14685      || (is_const
14686          && ckWARN_d(WARN_REDEFINE)
14687          && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
14688         )
14689     )
14690         Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
14691                           is_const
14692                             ? "Constant subroutine %"SVf" redefined"
14693                             : "Subroutine %"SVf" redefined",
14694                           SVfARG(name));
14695 }
14696
14697 /*
14698 =head1 Hook manipulation
14699
14700 These functions provide convenient and thread-safe means of manipulating
14701 hook variables.
14702
14703 =cut
14704 */
14705
14706 /*
14707 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
14708
14709 Puts a C function into the chain of check functions for a specified op
14710 type.  This is the preferred way to manipulate the L</PL_check> array.
14711 C<opcode> specifies which type of op is to be affected.  C<new_checker>
14712 is a pointer to the C function that is to be added to that opcode's
14713 check chain, and C<old_checker_p> points to the storage location where a
14714 pointer to the next function in the chain will be stored.  The value of
14715 C<new_pointer> is written into the L</PL_check> array, while the value
14716 previously stored there is written to C<*old_checker_p>.
14717
14718 The function should be defined like this:
14719
14720     static OP *new_checker(pTHX_ OP *op) { ... }
14721
14722 It is intended to be called in this manner:
14723
14724     new_checker(aTHX_ op)
14725
14726 C<old_checker_p> should be defined like this:
14727
14728     static Perl_check_t old_checker_p;
14729
14730 L</PL_check> is global to an entire process, and a module wishing to
14731 hook op checking may find itself invoked more than once per process,
14732 typically in different threads.  To handle that situation, this function
14733 is idempotent.  The location C<*old_checker_p> must initially (once
14734 per process) contain a null pointer.  A C variable of static duration
14735 (declared at file scope, typically also marked C<static> to give
14736 it internal linkage) will be implicitly initialised appropriately,
14737 if it does not have an explicit initialiser.  This function will only
14738 actually modify the check chain if it finds C<*old_checker_p> to be null.
14739 This function is also thread safe on the small scale.  It uses appropriate
14740 locking to avoid race conditions in accessing L</PL_check>.
14741
14742 When this function is called, the function referenced by C<new_checker>
14743 must be ready to be called, except for C<*old_checker_p> being unfilled.
14744 In a threading situation, C<new_checker> may be called immediately,
14745 even before this function has returned.  C<*old_checker_p> will always
14746 be appropriately set before C<new_checker> is called.  If C<new_checker>
14747 decides not to do anything special with an op that it is given (which
14748 is the usual case for most uses of op check hooking), it must chain the
14749 check function referenced by C<*old_checker_p>.
14750
14751 If you want to influence compilation of calls to a specific subroutine,
14752 then use L</cv_set_call_checker> rather than hooking checking of all
14753 C<entersub> ops.
14754
14755 =cut
14756 */
14757
14758 void
14759 Perl_wrap_op_checker(pTHX_ Optype opcode,
14760     Perl_check_t new_checker, Perl_check_t *old_checker_p)
14761 {
14762     dVAR;
14763
14764     PERL_UNUSED_CONTEXT;
14765     PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
14766     if (*old_checker_p) return;
14767     OP_CHECK_MUTEX_LOCK;
14768     if (!*old_checker_p) {
14769         *old_checker_p = PL_check[opcode];
14770         PL_check[opcode] = new_checker;
14771     }
14772     OP_CHECK_MUTEX_UNLOCK;
14773 }
14774
14775 #include "XSUB.h"
14776
14777 /* Efficient sub that returns a constant scalar value. */
14778 static void
14779 const_sv_xsub(pTHX_ CV* cv)
14780 {
14781     dXSARGS;
14782     SV *const sv = MUTABLE_SV(XSANY.any_ptr);
14783     PERL_UNUSED_ARG(items);
14784     if (!sv) {
14785         XSRETURN(0);
14786     }
14787     EXTEND(sp, 1);
14788     ST(0) = sv;
14789     XSRETURN(1);
14790 }
14791
14792 static void
14793 const_av_xsub(pTHX_ CV* cv)
14794 {
14795     dXSARGS;
14796     AV * const av = MUTABLE_AV(XSANY.any_ptr);
14797     SP -= items;
14798     assert(av);
14799 #ifndef DEBUGGING
14800     if (!av) {
14801         XSRETURN(0);
14802     }
14803 #endif
14804     if (SvRMAGICAL(av))
14805         Perl_croak(aTHX_ "Magical list constants are not supported");
14806     if (GIMME_V != G_ARRAY) {
14807         EXTEND(SP, 1);
14808         ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
14809         XSRETURN(1);
14810     }
14811     EXTEND(SP, AvFILLp(av)+1);
14812     Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
14813     XSRETURN(AvFILLp(av)+1);
14814 }
14815
14816 /*
14817  * ex: set ts=8 sts=4 sw=4 et:
14818  */