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  * Note that during the build of miniperl, a temporary copy of this file
  26  * is made, called opmini.c.
  27  *
  28  * A Perl program is compiled into a tree of OP nodes. Each op contains:
  29  *  * structural OP pointers to its children and siblings (op_sibling,
  30  *    op_first etc) that define the tree structure;
  31  *  * execution order OP pointers (op_next, plus sometimes op_other,
  32  *    op_lastop  etc) that define the execution sequence plus variants;
  33  *  * a pointer to the C "pp" function that would execute the op;
  34  *  * any data specific to that op.
  35  * For example, an OP_CONST op points to the pp_const() function and to an
  36  * SV containing the constant value. When pp_const() is executed, its job
  37  * is to push that SV onto the stack.
  38  *
  39  * OPs are mainly created by the newFOO() functions, which are mainly
  40  * called from the parser (in perly.y) as the code is parsed. For example
  41  * the Perl code $a + $b * $c would cause the equivalent of the following
  42  * to be called (oversimplifying a bit):
  43  *
  44  *  newBINOP(OP_ADD, flags,
  45  *      newSVREF($a),
  46  *      newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
  47  *  )
  48  *
  49  * As the parser reduces low-level rules, it creates little op subtrees;
  50  * as higher-level rules are resolved, these subtrees get joined together
  51  * as branches on a bigger subtree, until eventually a top-level rule like
  52  * a subroutine definition is reduced, at which point there is one large
  53  * parse tree left.
  54  *
  55  * The execution order pointers (op_next) are generated as the subtrees
  56  * are joined together. Consider this sub-expression: A*B + C/D: at the
  57  * point when it's just been parsed, the op tree looks like:
  58  *
  59  *   [+]
  60  *    |
  61  *   [*]------[/]
  62  *    |        |
  63  *    A---B    C---D
  64  *
  65  * with the intended execution order being:
  66  *
  67  *   [PREV] => A => B => [*] => C => D => [/] =>  [+] => [NEXT]
  68  *
  69  * At this point all the nodes' op_next pointers will have been set,
  70  * except that:
  71  *    * we don't know what the [NEXT] node will be yet;
  72  *    * we don't know what the [PREV] node will be yet, but when it gets
  73  *      created and needs its op_next set, it needs to be set to point to
  74  *      A, which is non-obvious.
  75  * To handle both those cases, we temporarily set the top node's
  76  * op_next to point to the first node to be executed in this subtree (A in
  77  * this case). This means that initially a subtree's op_next chain,
  78  * starting from the top node, will visit each node in execution sequence
  79  * then point back at the top node.
  80  * When we embed this subtree in a larger tree, its top op_next is used
  81  * to get the start node, then is set to point to its new neighbour.
  82  * For example the two separate [*],A,B and [/],C,D subtrees would
  83  * initially have had:
  84  *   [*] => A;  A => B;  B => [*]
  85  * and
  86  *   [/] => C;  C => D;  D => [/]
  87  * When these two subtrees were joined together to make the [+] subtree,
  88  * [+]'s op_next was set to [*]'s op_next, i.e. A; then [*]'s op_next was
  89  * set to point to [/]'s op_next, i.e. C.
  90  *
  91  * This op_next linking is done by the LINKLIST() macro and its underlying
  92  * op_linklist() function. Given a top-level op, if its op_next is
  93  * non-null, it's already been linked, so leave it. Otherwise link it with
  94  * its children as described above, possibly recursively if any of the
  95  * children have a null op_next.
  96  *
  97  * In summary: given a subtree, its top-level node's op_next will either
  98  * be:
  99  *   NULL: the subtree hasn't been LINKLIST()ed yet;
 100  *   fake: points to the start op for this subtree;
 101  *   real: once the subtree has been embedded into a larger tree
 102  */
 103
 104 /*
 105
 106 Here's an older description from Larry.
 107
 108 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
 109
 110     A bottom-up pass
 111     A top-down pass
 112     An execution-order pass
 113
 114 The bottom-up pass is represented by all the "newOP" routines and
 115 the ck_ routines.  The bottom-upness is actually driven by yacc.
 116 So at the point that a ck_ routine fires, we have no idea what the
 117 context is, either upward in the syntax tree, or either forward or
 118 backward in the execution order.  (The bottom-up parser builds that
 119 part of the execution order it knows about, but if you follow the "next"
 120 links around, you'll find it's actually a closed loop through the
 121 top level node.)
 122
 123 Whenever the bottom-up parser gets to a node that supplies context to
 124 its components, it invokes that portion of the top-down pass that applies
 125 to that part of the subtree (and marks the top node as processed, so
 126 if a node further up supplies context, it doesn't have to take the
 127 plunge again).  As a particular subcase of this, as the new node is
 128 built, it takes all the closed execution loops of its subcomponents
 129 and links them into a new closed loop for the higher level node.  But
 130 it's still not the real execution order.
 131
 132 The actual execution order is not known till we get a grammar reduction
 133 to a top-level unit like a subroutine or file that will be called by
 134 "name" rather than via a "next" pointer.  At that point, we can call
 135 into peep() to do that code's portion of the 3rd pass.  It has to be
 136 recursive, but it's recursive on basic blocks, not on tree nodes.
 137 */
 138
 139 /* To implement user lexical pragmas, there needs to be a way at run time to
 140    get the compile time state of %^H for that block.  Storing %^H in every
 141    block (or even COP) would be very expensive, so a different approach is
 142    taken.  The (running) state of %^H is serialised into a tree of HE-like
 143    structs.  Stores into %^H are chained onto the current leaf as a struct
 144    refcounted_he * with the key and the value.  Deletes from %^H are saved
 145    with a value of PL_sv_placeholder.  The state of %^H at any point can be
 146    turned back into a regular HV by walking back up the tree from that point's
 147    leaf, ignoring any key you've already seen (placeholder or not), storing
 148    the rest into the HV structure, then removing the placeholders. Hence
 149    memory is only used to store the %^H deltas from the enclosing COP, rather
 150    than the entire %^H on each COP.
 151
 152    To cause actions on %^H to write out the serialisation records, it has
 153    magic type 'H'. This magic (itself) does nothing, but its presence causes
 154    the values to gain magic type 'h', which has entries for set and clear.
 155    C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
 156    record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
 157    saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
 158    it will be correctly restored when any inner compiling scope is exited.
 159 */
 160
 161 #include "EXTERN.h"
 162 #define PERL_IN_OP_C
 163 #include "perl.h"
 164 #include "keywords.h"
 165 #include "feature.h"
 166 #include "regcomp.h"
 167
 168 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
 169 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
 170 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
 171
 172 static const char array_passed_to_stat[] = "Array passed to stat will be coerced to a scalar";
 173
 174 /* Used to avoid recursion through the op tree in scalarvoid() and
 175    op_free()
 176 */
 177
 178 #define dDEFER_OP  \
 179     SSize_t defer_stack_alloc = 0; \
 180     SSize_t defer_ix = -1; \
 181     OP **defer_stack = NULL;
 182 #define DEFER_OP_CLEANUP Safefree(defer_stack)
 183 #define DEFERRED_OP_STEP 100
 184 #define DEFER_OP(o) \
 185   STMT_START { \
 186     if (UNLIKELY(defer_ix == (defer_stack_alloc-1))) {    \
 187         defer_stack_alloc += DEFERRED_OP_STEP; \
 188         assert(defer_stack_alloc > 0); \
 189         Renew(defer_stack, defer_stack_alloc, OP *); \
 190     } \
 191     defer_stack[++defer_ix] = o; \
 192   } STMT_END
 193 #define DEFER_REVERSE(count)                            \
 194     STMT_START {                                        \
 195         UV cnt = (count);                               \
 196         if (cnt > 1) {                                  \
 197             OP **top = defer_stack + defer_ix;          \
 198             /* top - (cnt) + 1 isn't safe here */       \
 199             OP **bottom = top - (cnt - 1);              \
 200             OP *tmp;                                    \
 201             assert(bottom >= defer_stack);              \
 202             while (top > bottom) {                      \
 203                 tmp = *top;                             \
 204                 *top-- = *bottom;                       \
 205                 *bottom++ = tmp;                        \
 206             }                                           \
 207         }                                               \
 208     } STMT_END;
 209
 210 #define POP_DEFERRED_OP() (defer_ix >= 0 ? defer_stack[defer_ix--] : (OP *)NULL)
 211
 212 /* remove any leading "empty" ops from the op_next chain whose first
 213  * node's address is stored in op_p. Store the updated address of the
 214  * first node in op_p.
 215  */
 216
 217 STATIC void
 218 S_prune_chain_head(OP** op_p)
 219 {
 220     while (*op_p
 221         && (   (*op_p)->op_type == OP_NULL
 222             || (*op_p)->op_type == OP_SCOPE
 223             || (*op_p)->op_type == OP_SCALAR
 224             || (*op_p)->op_type == OP_LINESEQ)
 225     )
 226         *op_p = (*op_p)->op_next;
 227 }
 228
 229
 230 /* See the explanatory comments above struct opslab in op.h. */
 231
 232 #ifdef PERL_DEBUG_READONLY_OPS
 233 #  define PERL_SLAB_SIZE 128
 234 #  define PERL_MAX_SLAB_SIZE 4096
 235 #  include <sys/mman.h>
 236 #endif
 237
 238 #ifndef PERL_SLAB_SIZE
 239 #  define PERL_SLAB_SIZE 64
 240 #endif
 241 #ifndef PERL_MAX_SLAB_SIZE
 242 #  define PERL_MAX_SLAB_SIZE 2048
 243 #endif
 244
 245 /* rounds up to nearest pointer */
 246 #define SIZE_TO_PSIZE(x)        (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
 247 #define DIFF(o,p)               ((size_t)((I32 **)(p) - (I32**)(o)))
 248
 249 static OPSLAB *
 250 S_new_slab(pTHX_ size_t sz)
 251 {
 252 #ifdef PERL_DEBUG_READONLY_OPS
 253     OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
 254                                    PROT_READ|PROT_WRITE,
 255                                    MAP_ANON|MAP_PRIVATE, -1, 0);
 256     DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
 257                           (unsigned long) sz, slab));
 258     if (slab == MAP_FAILED) {
 259         perror("mmap failed");
 260         abort();
 261     }
 262     slab->opslab_size = (U16)sz;
 263 #else
 264     OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
 265 #endif
 266 #ifndef WIN32
 267     /* The context is unused in non-Windows */
 268     PERL_UNUSED_CONTEXT;
 269 #endif
 270     slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
 271     return slab;
 272 }
 273
 274 /* requires double parens and aTHX_ */
 275 #define DEBUG_S_warn(args)                                             \
 276     DEBUG_S(                                                            \
 277         PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
 278     )
 279
 280 void *
 281 Perl_Slab_Alloc(pTHX_ size_t sz)
 282 {
 283     OPSLAB *slab;
 284     OPSLAB *slab2;
 285     OPSLOT *slot;
 286     OP *o;
 287     size_t opsz, space;
 288
 289     /* We only allocate ops from the slab during subroutine compilation.
 290        We find the slab via PL_compcv, hence that must be non-NULL. It could
 291        also be pointing to a subroutine which is now fully set up (CvROOT()
 292        pointing to the top of the optree for that sub), or a subroutine
 293        which isn't using the slab allocator. If our sanity checks aren't met,
 294        don't use a slab, but allocate the OP directly from the heap.  */
 295     if (!PL_compcv || CvROOT(PL_compcv)
 296      || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
 297     {
 298         o = (OP*)PerlMemShared_calloc(1, sz);
 299         goto gotit;
 300     }
 301
 302     /* While the subroutine is under construction, the slabs are accessed via
 303        CvSTART(), to avoid needing to expand PVCV by one pointer for something
 304        unneeded at runtime. Once a subroutine is constructed, the slabs are
 305        accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
 306        allocated yet.  See the commit message for 8be227ab5eaa23f2 for more
 307        details.  */
 308     if (!CvSTART(PL_compcv)) {
 309         CvSTART(PL_compcv) =
 310             (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
 311         CvSLABBED_on(PL_compcv);
 312         slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
 313     }
 314     else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
 315
 316     opsz = SIZE_TO_PSIZE(sz);
 317     sz = opsz + OPSLOT_HEADER_P;
 318
 319     /* The slabs maintain a free list of OPs. In particular, constant folding
 320        will free up OPs, so it makes sense to re-use them where possible. A
 321        freed up slot is used in preference to a new allocation.  */
 322     if (slab->opslab_freed) {
 323         OP **too = &slab->opslab_freed;
 324         o = *too;
 325         DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", (void*)o, (void*)slab));
 326         while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
 327             DEBUG_S_warn((aTHX_ "Alas! too small"));
 328             o = *(too = &o->op_next);
 329             if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", (void*)o)); }
 330         }
 331         if (o) {
 332             *too = o->op_next;
 333             Zero(o, opsz, I32 *);
 334             o->op_slabbed = 1;
 335             goto gotit;
 336         }
 337     }
 338
 339 #define INIT_OPSLOT \
 340             slot->opslot_slab = slab;                   \
 341             slot->opslot_next = slab2->opslab_first;    \
 342             slab2->opslab_first = slot;                 \
 343             o = &slot->opslot_op;                       \
 344             o->op_slabbed = 1
 345
 346     /* The partially-filled slab is next in the chain. */
 347     slab2 = slab->opslab_next ? slab->opslab_next : slab;
 348     if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
 349         /* Remaining space is too small. */
 350
 351         /* If we can fit a BASEOP, add it to the free chain, so as not
 352            to waste it. */
 353         if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
 354             slot = &slab2->opslab_slots;
 355             INIT_OPSLOT;
 356             o->op_type = OP_FREED;
 357             o->op_next = slab->opslab_freed;
 358             slab->opslab_freed = o;
 359         }
 360
 361         /* Create a new slab.  Make this one twice as big. */
 362         slot = slab2->opslab_first;
 363         while (slot->opslot_next) slot = slot->opslot_next;
 364         slab2 = S_new_slab(aTHX_
 365                             (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
 366                                         ? PERL_MAX_SLAB_SIZE
 367                                         : (DIFF(slab2, slot)+1)*2);
 368         slab2->opslab_next = slab->opslab_next;
 369         slab->opslab_next = slab2;
 370     }
 371     assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
 372
 373     /* Create a new op slot */
 374     slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
 375     assert(slot >= &slab2->opslab_slots);
 376     if (DIFF(&slab2->opslab_slots, slot)
 377          < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
 378         slot = &slab2->opslab_slots;
 379     INIT_OPSLOT;
 380     DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab));
 381
 382   gotit:
 383     /* moresib == 0, op_sibling == 0 implies a solitary unattached op */
 384     assert(!o->op_moresib);
 385     assert(!o->op_sibparent);
 386
 387     return (void *)o;
 388 }
 389
 390 #undef INIT_OPSLOT
 391
 392 #ifdef PERL_DEBUG_READONLY_OPS
 393 void
 394 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
 395 {
 396     PERL_ARGS_ASSERT_SLAB_TO_RO;
 397
 398     if (slab->opslab_readonly) return;
 399     slab->opslab_readonly = 1;
 400     for (; slab; slab = slab->opslab_next) {
 401         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
 402                               (unsigned long) slab->opslab_size, slab));*/
 403         if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
 404             Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
 405                              (unsigned long)slab->opslab_size, errno);
 406     }
 407 }
 408
 409 void
 410 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
 411 {
 412     OPSLAB *slab2;
 413
 414     PERL_ARGS_ASSERT_SLAB_TO_RW;
 415
 416     if (!slab->opslab_readonly) return;
 417     slab2 = slab;
 418     for (; slab2; slab2 = slab2->opslab_next) {
 419         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
 420                               (unsigned long) size, slab2));*/
 421         if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
 422                      PROT_READ|PROT_WRITE)) {
 423             Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
 424                              (unsigned long)slab2->opslab_size, errno);
 425         }
 426     }
 427     slab->opslab_readonly = 0;
 428 }
 429
 430 #else
 431 #  define Slab_to_rw(op)    NOOP
 432 #endif
 433
 434 /* This cannot possibly be right, but it was copied from the old slab
 435    allocator, to which it was originally added, without explanation, in
 436    commit 083fcd5. */
 437 #ifdef NETWARE
 438 #    define PerlMemShared PerlMem
 439 #endif
 440
 441 /* make freed ops die if they're inadvertently executed */
 442 #ifdef DEBUGGING
 443 static OP *
 444 S_pp_freed(pTHX)
 445 {
 446     DIE(aTHX_ "panic: freed op 0x%p called\n", PL_op);
 447 }
 448 #endif
 449
 450 void
 451 Perl_Slab_Free(pTHX_ void *op)
 452 {
 453     OP * const o = (OP *)op;
 454     OPSLAB *slab;
 455
 456     PERL_ARGS_ASSERT_SLAB_FREE;
 457
 458 #ifdef DEBUGGING
 459     o->op_ppaddr = S_pp_freed;
 460 #endif
 461
 462     if (!o->op_slabbed) {
 463         if (!o->op_static)
 464             PerlMemShared_free(op);
 465         return;
 466     }
 467
 468     slab = OpSLAB(o);
 469     /* If this op is already freed, our refcount will get screwy. */
 470     assert(o->op_type != OP_FREED);
 471     o->op_type = OP_FREED;
 472     o->op_next = slab->opslab_freed;
 473     slab->opslab_freed = o;
 474     DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", (void*)o, (void*)slab));
 475     OpslabREFCNT_dec_padok(slab);
 476 }
 477
 478 void
 479 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
 480 {
 481     const bool havepad = !!PL_comppad;
 482     PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
 483     if (havepad) {
 484         ENTER;
 485         PAD_SAVE_SETNULLPAD();
 486     }
 487     opslab_free(slab);
 488     if (havepad) LEAVE;
 489 }
 490
 491 void
 492 Perl_opslab_free(pTHX_ OPSLAB *slab)
 493 {
 494     OPSLAB *slab2;
 495     PERL_ARGS_ASSERT_OPSLAB_FREE;
 496     PERL_UNUSED_CONTEXT;
 497     DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
 498     assert(slab->opslab_refcnt == 1);
 499     do {
 500         slab2 = slab->opslab_next;
 501 #ifdef DEBUGGING
 502         slab->opslab_refcnt = ~(size_t)0;
 503 #endif
 504 #ifdef PERL_DEBUG_READONLY_OPS
 505         DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
 506                                                (void*)slab));
 507         if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
 508             perror("munmap failed");
 509             abort();
 510         }
 511 #else
 512         PerlMemShared_free(slab);
 513 #endif
 514         slab = slab2;
 515     } while (slab);
 516 }
 517
 518 void
 519 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
 520 {
 521     OPSLAB *slab2;
 522 #ifdef DEBUGGING
 523     size_t savestack_count = 0;
 524 #endif
 525     PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
 526     slab2 = slab;
 527     do {
 528         OPSLOT *slot;
 529         for (slot = slab2->opslab_first;
 530              slot->opslot_next;
 531              slot = slot->opslot_next) {
 532             if (slot->opslot_op.op_type != OP_FREED
 533              && !(slot->opslot_op.op_savefree
 534 #ifdef DEBUGGING
 535                   && ++savestack_count
 536 #endif
 537                  )
 538             ) {
 539                 assert(slot->opslot_op.op_slabbed);
 540                 op_free(&slot->opslot_op);
 541                 if (slab->opslab_refcnt == 1) goto free;
 542             }
 543         }
 544     } while ((slab2 = slab2->opslab_next));
 545     /* > 1 because the CV still holds a reference count. */
 546     if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
 547 #ifdef DEBUGGING
 548         assert(savestack_count == slab->opslab_refcnt-1);
 549 #endif
 550         /* Remove the CV’s reference count. */
 551         slab->opslab_refcnt--;
 552         return;
 553     }
 554    free:
 555     opslab_free(slab);
 556 }
 557
 558 #ifdef PERL_DEBUG_READONLY_OPS
 559 OP *
 560 Perl_op_refcnt_inc(pTHX_ OP *o)
 561 {
 562     if(o) {
 563         OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
 564         if (slab && slab->opslab_readonly) {
 565             Slab_to_rw(slab);
 566             ++o->op_targ;
 567             Slab_to_ro(slab);
 568         } else {
 569             ++o->op_targ;
 570         }
 571     }
 572     return o;
 573
 574 }
 575
 576 PADOFFSET
 577 Perl_op_refcnt_dec(pTHX_ OP *o)
 578 {
 579     PADOFFSET result;
 580     OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
 581
 582     PERL_ARGS_ASSERT_OP_REFCNT_DEC;
 583
 584     if (slab && slab->opslab_readonly) {
 585         Slab_to_rw(slab);
 586         result = --o->op_targ;
 587         Slab_to_ro(slab);
 588     } else {
 589         result = --o->op_targ;
 590     }
 591     return result;
 592 }
 593 #endif
 594 /*
 595  * In the following definition, the ", (OP*)0" is just to make the compiler
 596  * think the expression is of the right type: croak actually does a Siglongjmp.
 597  */
 598 #define CHECKOP(type,o) \
 599     ((PL_op_mask && PL_op_mask[type])                           \
 600      ? ( op_free((OP*)o),                                       \
 601          Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]),  \
 602          (OP*)0 )                                               \
 603      : PL_check[type](aTHX_ (OP*)o))
 604
 605 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
 606
 607 #define OpTYPE_set(o,type) \
 608     STMT_START {                                \
 609         o->op_type = (OPCODE)type;              \
 610         o->op_ppaddr = PL_ppaddr[type];         \
 611     } STMT_END
 612
 613 STATIC OP *
 614 S_no_fh_allowed(pTHX_ OP *o)
 615 {
 616     PERL_ARGS_ASSERT_NO_FH_ALLOWED;
 617
 618     yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
 619                  OP_DESC(o)));
 620     return o;
 621 }
 622
 623 STATIC OP *
 624 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
 625 {
 626     PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
 627     yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
 628     return o;
 629 }
 630
 631 STATIC OP *
 632 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
 633 {
 634     PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
 635
 636     yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
 637     return o;
 638 }
 639
 640 STATIC void
 641 S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid)
 642 {
 643     PERL_ARGS_ASSERT_BAD_TYPE_PV;
 644
 645     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
 646                  (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);
 647 }
 648
 649 /* remove flags var, its unused in all callers, move to to right end since gv
 650   and kid are always the same */
 651 STATIC void
 652 S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)
 653 {
 654     SV * const namesv = cv_name((CV *)gv, NULL, 0);
 655     PERL_ARGS_ASSERT_BAD_TYPE_GV;
 656
 657     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %" SVf " must be %s (not %s)",
 658                  (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
 659 }
 660
 661 STATIC void
 662 S_no_bareword_allowed(pTHX_ OP *o)
 663 {
 664     PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
 665
 666     qerror(Perl_mess(aTHX_
 667                      "Bareword \"%" SVf "\" not allowed while \"strict subs\" in use",
 668                      SVfARG(cSVOPo_sv)));
 669     o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
 670 }
 671
 672 /* "register" allocation */
 673
 674 PADOFFSET
 675 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
 676 {
 677     PADOFFSET off;
 678     const bool is_our = (PL_parser->in_my == KEY_our);
 679
 680     PERL_ARGS_ASSERT_ALLOCMY;
 681
 682     if (flags & ~SVf_UTF8)
 683         Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
 684                    (UV)flags);
 685
 686     /* complain about "my $<special_var>" etc etc */
 687     if (   len
 688         && !(  is_our
 689             || isALPHA(name[1])
 690             || (   (flags & SVf_UTF8)
 691                 && isIDFIRST_utf8_safe((U8 *)name+1, name + len))
 692             || (name[1] == '_' && len > 2)))
 693     {
 694         if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
 695          && isASCII(name[1])
 696          && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
 697             /* diag_listed_as: Can't use global %s in "%s" */
 698             yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
 699                               name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
 700                               PL_parser->in_my == KEY_state ? "state" : "my"));
 701         } else {
 702             yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
 703                               PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
 704         }
 705     }
 706
 707     /* allocate a spare slot and store the name in that slot */
 708
 709     off = pad_add_name_pvn(name, len,
 710                        (is_our ? padadd_OUR :
 711                         PL_parser->in_my == KEY_state ? padadd_STATE : 0),
 712                     PL_parser->in_my_stash,
 713                     (is_our
 714                         /* $_ is always in main::, even with our */
 715                         ? (PL_curstash && !memEQs(name,len,"$_")
 716                             ? PL_curstash
 717                             : PL_defstash)
 718                         : NULL
 719                     )
 720     );
 721     /* anon sub prototypes contains state vars should always be cloned,
 722      * otherwise the state var would be shared between anon subs */
 723
 724     if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
 725         CvCLONE_on(PL_compcv);
 726
 727     return off;
 728 }
 729
 730 /*
 731 =head1 Optree Manipulation Functions
 732
 733 =for apidoc alloccopstash
 734
 735 Available only under threaded builds, this function allocates an entry in
 736 C<PL_stashpad> for the stash passed to it.
 737
 738 =cut
 739 */
 740
 741 #ifdef USE_ITHREADS
 742 PADOFFSET
 743 Perl_alloccopstash(pTHX_ HV *hv)
 744 {
 745     PADOFFSET off = 0, o = 1;
 746     bool found_slot = FALSE;
 747
 748     PERL_ARGS_ASSERT_ALLOCCOPSTASH;
 749
 750     if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
 751
 752     for (; o < PL_stashpadmax; ++o) {
 753         if (PL_stashpad[o] == hv) return PL_stashpadix = o;
 754         if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
 755             found_slot = TRUE, off = o;
 756     }
 757     if (!found_slot) {
 758         Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
 759         Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
 760         off = PL_stashpadmax;
 761         PL_stashpadmax += 10;
 762     }
 763
 764     PL_stashpad[PL_stashpadix = off] = hv;
 765     return off;
 766 }
 767 #endif
 768
 769 /* free the body of an op without examining its contents.
 770  * Always use this rather than FreeOp directly */
 771
 772 static void
 773 S_op_destroy(pTHX_ OP *o)
 774 {
 775     FreeOp(o);
 776 }
 777
 778 /* Destructor */
 779
 780 /*
 781 =for apidoc Am|void|op_free|OP *o
 782
 783 Free an op.  Only use this when an op is no longer linked to from any
 784 optree.
 785
 786 =cut
 787 */
 788
 789 void
 790 Perl_op_free(pTHX_ OP *o)
 791 {
 792     dVAR;
 793     OPCODE type;
 794     dDEFER_OP;
 795
 796     do {
 797
 798         /* Though ops may be freed twice, freeing the op after its slab is a
 799            big no-no. */
 800         assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
 801         /* During the forced freeing of ops after compilation failure, kidops
 802            may be freed before their parents. */
 803         if (!o || o->op_type == OP_FREED)
 804             continue;
 805
 806         type = o->op_type;
 807
 808         /* an op should only ever acquire op_private flags that we know about.
 809          * If this fails, you may need to fix something in regen/op_private.
 810          * Don't bother testing if:
 811          *   * the op_ppaddr doesn't match the op; someone may have
 812          *     overridden the op and be doing strange things with it;
 813          *   * we've errored, as op flags are often left in an
 814          *     inconsistent state then. Note that an error when
 815          *     compiling the main program leaves PL_parser NULL, so
 816          *     we can't spot faults in the main code, only
 817          *     evaled/required code */
 818 #ifdef DEBUGGING
 819         if (   o->op_ppaddr == PL_ppaddr[o->op_type]
 820             && PL_parser
 821             && !PL_parser->error_count)
 822         {
 823             assert(!(o->op_private & ~PL_op_private_valid[type]));
 824         }
 825 #endif
 826
 827         if (o->op_private & OPpREFCOUNTED) {
 828             switch (type) {
 829             case OP_LEAVESUB:
 830             case OP_LEAVESUBLV:
 831             case OP_LEAVEEVAL:
 832             case OP_LEAVE:
 833             case OP_SCOPE:
 834             case OP_LEAVEWRITE:
 835                 {
 836                 PADOFFSET refcnt;
 837                 OP_REFCNT_LOCK;
 838                 refcnt = OpREFCNT_dec(o);
 839                 OP_REFCNT_UNLOCK;
 840                 if (refcnt) {
 841                     /* Need to find and remove any pattern match ops from the list
 842                        we maintain for reset().  */
 843                     find_and_forget_pmops(o);
 844                     continue;
 845                 }
 846                 }
 847                 break;
 848             default:
 849                 break;
 850             }
 851         }
 852
 853         /* Call the op_free hook if it has been set. Do it now so that it's called
 854          * at the right time for refcounted ops, but still before all of the kids
 855          * are freed. */
 856         CALL_OPFREEHOOK(o);
 857
 858         if (o->op_flags & OPf_KIDS) {
 859             OP *kid, *nextkid;
 860             for (kid = cUNOPo->op_first; kid; kid = nextkid) {
 861                 nextkid = OpSIBLING(kid); /* Get before next freeing kid */
 862                 if (!kid || kid->op_type == OP_FREED)
 863                     /* During the forced freeing of ops after
 864                        compilation failure, kidops may be freed before
 865                        their parents. */
 866                     continue;
 867                 if (!(kid->op_flags & OPf_KIDS))
 868                     /* If it has no kids, just free it now */
 869                     op_free(kid);
 870                 else
 871                     DEFER_OP(kid);
 872             }
 873         }
 874         if (type == OP_NULL)
 875             type = (OPCODE)o->op_targ;
 876
 877         if (o->op_slabbed)
 878             Slab_to_rw(OpSLAB(o));
 879
 880         /* COP* is not cleared by op_clear() so that we may track line
 881          * numbers etc even after null() */
 882         if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
 883             cop_free((COP*)o);
 884         }
 885
 886         op_clear(o);
 887         FreeOp(o);
 888         if (PL_op == o)
 889             PL_op = NULL;
 890     } while ( (o = POP_DEFERRED_OP()) );
 891
 892     DEFER_OP_CLEANUP;
 893 }
 894
 895 /* S_op_clear_gv(): free a GV attached to an OP */
 896
 897 STATIC
 898 #ifdef USE_ITHREADS
 899 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
 900 #else
 901 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
 902 #endif
 903 {
 904
 905     GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
 906             || o->op_type == OP_MULTIDEREF)
 907 #ifdef USE_ITHREADS
 908                 && PL_curpad
 909                 ? ((GV*)PAD_SVl(*ixp)) : NULL;
 910 #else
 911                 ? (GV*)(*svp) : NULL;
 912 #endif
 913     /* It's possible during global destruction that the GV is freed
 914        before the optree. Whilst the SvREFCNT_inc is happy to bump from
 915        0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
 916        will trigger an assertion failure, because the entry to sv_clear
 917        checks that the scalar is not already freed.  A check of for
 918        !SvIS_FREED(gv) turns out to be invalid, because during global
 919        destruction the reference count can be forced down to zero
 920        (with SVf_BREAK set).  In which case raising to 1 and then
 921        dropping to 0 triggers cleanup before it should happen.  I
 922        *think* that this might actually be a general, systematic,
 923        weakness of the whole idea of SVf_BREAK, in that code *is*
 924        allowed to raise and lower references during global destruction,
 925        so any *valid* code that happens to do this during global
 926        destruction might well trigger premature cleanup.  */
 927     bool still_valid = gv && SvREFCNT(gv);
 928
 929     if (still_valid)
 930         SvREFCNT_inc_simple_void(gv);
 931 #ifdef USE_ITHREADS
 932     if (*ixp > 0) {
 933         pad_swipe(*ixp, TRUE);
 934         *ixp = 0;
 935     }
 936 #else
 937     SvREFCNT_dec(*svp);
 938     *svp = NULL;
 939 #endif
 940     if (still_valid) {
 941         int try_downgrade = SvREFCNT(gv) == 2;
 942         SvREFCNT_dec_NN(gv);
 943         if (try_downgrade)
 944             gv_try_downgrade(gv);
 945     }
 946 }
 947
 948
 949 void
 950 Perl_op_clear(pTHX_ OP *o)
 951 {
 952
 953     dVAR;
 954
 955     PERL_ARGS_ASSERT_OP_CLEAR;
 956
 957     switch (o->op_type) {
 958     case OP_NULL:       /* Was holding old type, if any. */
 959         /* FALLTHROUGH */
 960     case OP_ENTERTRY:
 961     case OP_ENTEREVAL:  /* Was holding hints. */
 962     case OP_ARGDEFELEM: /* Was holding signature index. */
 963         o->op_targ = 0;
 964         break;
 965     default:
 966         if (!(o->op_flags & OPf_REF)
 967             || (PL_check[o->op_type] != Perl_ck_ftst))
 968             break;
 969         /* FALLTHROUGH */
 970     case OP_GVSV:
 971     case OP_GV:
 972     case OP_AELEMFAST:
 973 #ifdef USE_ITHREADS
 974             S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
 975 #else
 976             S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
 977 #endif
 978         break;
 979     case OP_METHOD_REDIR:
 980     case OP_METHOD_REDIR_SUPER:
 981 #ifdef USE_ITHREADS
 982         if (cMETHOPx(o)->op_rclass_targ) {
 983             pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
 984             cMETHOPx(o)->op_rclass_targ = 0;
 985         }
 986 #else
 987         SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
 988         cMETHOPx(o)->op_rclass_sv = NULL;
 989 #endif
 990         /* FALLTHROUGH */
 991     case OP_METHOD_NAMED:
 992     case OP_METHOD_SUPER:
 993         SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
 994         cMETHOPx(o)->op_u.op_meth_sv = NULL;
 995 #ifdef USE_ITHREADS
 996         if (o->op_targ) {
 997             pad_swipe(o->op_targ, 1);
 998             o->op_targ = 0;
 999         }
1000 #endif
1001         break;
1002     case OP_CONST:
1003     case OP_HINTSEVAL:
1004         SvREFCNT_dec(cSVOPo->op_sv);
1005         cSVOPo->op_sv = NULL;
1006 #ifdef USE_ITHREADS
1007         /** Bug #15654
1008           Even if op_clear does a pad_free for the target of the op,
1009           pad_free doesn't actually remove the sv that exists in the pad;
1010           instead it lives on. This results in that it could be reused as
1011           a target later on when the pad was reallocated.
1012         **/
1013         if(o->op_targ) {
1014           pad_swipe(o->op_targ,1);
1015           o->op_targ = 0;
1016         }
1017 #endif
1018         break;
1019     case OP_DUMP:
1020     case OP_GOTO:
1021     case OP_NEXT:
1022     case OP_LAST:
1023     case OP_REDO:
1024         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
1025             break;
1026         /* FALLTHROUGH */
1027     case OP_TRANS:
1028     case OP_TRANSR:
1029         if (   (o->op_type == OP_TRANS || o->op_type == OP_TRANSR)
1030             && (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)))
1031         {
1032 #ifdef USE_ITHREADS
1033             if (cPADOPo->op_padix > 0) {
1034                 pad_swipe(cPADOPo->op_padix, TRUE);
1035                 cPADOPo->op_padix = 0;
1036             }
1037 #else
1038             SvREFCNT_dec(cSVOPo->op_sv);
1039             cSVOPo->op_sv = NULL;
1040 #endif
1041         }
1042         else {
1043             PerlMemShared_free(cPVOPo->op_pv);
1044             cPVOPo->op_pv = NULL;
1045         }
1046         break;
1047     case OP_SUBST:
1048         op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
1049         goto clear_pmop;
1050
1051     case OP_SPLIT:
1052         if (     (o->op_private & OPpSPLIT_ASSIGN) /* @array  = split */
1053             && !(o->op_flags & OPf_STACKED))       /* @{expr} = split */
1054         {
1055             if (o->op_private & OPpSPLIT_LEX)
1056                 pad_free(cPMOPo->op_pmreplrootu.op_pmtargetoff);
1057             else
1058 #ifdef USE_ITHREADS
1059                 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
1060 #else
1061                 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
1062 #endif
1063         }
1064         /* FALLTHROUGH */
1065     case OP_MATCH:
1066     case OP_QR:
1067     clear_pmop:
1068         if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
1069             op_free(cPMOPo->op_code_list);
1070         cPMOPo->op_code_list = NULL;
1071         forget_pmop(cPMOPo);
1072         cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
1073         /* we use the same protection as the "SAFE" version of the PM_ macros
1074          * here since sv_clean_all might release some PMOPs
1075          * after PL_regex_padav has been cleared
1076          * and the clearing of PL_regex_padav needs to
1077          * happen before sv_clean_all
1078          */
1079 #ifdef USE_ITHREADS
1080         if(PL_regex_pad) {        /* We could be in destruction */
1081             const IV offset = (cPMOPo)->op_pmoffset;
1082             ReREFCNT_dec(PM_GETRE(cPMOPo));
1083             PL_regex_pad[offset] = &PL_sv_undef;
1084             sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
1085                            sizeof(offset));
1086         }
1087 #else
1088         ReREFCNT_dec(PM_GETRE(cPMOPo));
1089         PM_SETRE(cPMOPo, NULL);
1090 #endif
1091
1092         break;
1093
1094     case OP_ARGCHECK:
1095         PerlMemShared_free(cUNOP_AUXo->op_aux);
1096         break;
1097
1098     case OP_MULTICONCAT:
1099         {
1100             UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
1101             /* aux[PERL_MULTICONCAT_IX_PLAIN_PV] and/or
1102              * aux[PERL_MULTICONCAT_IX_UTF8_PV] point to plain and/or
1103              * utf8 shared strings */
1104             char *p1 = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
1105             char *p2 = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
1106             if (p1)
1107                 PerlMemShared_free(p1);
1108             if (p2 && p1 != p2)
1109                 PerlMemShared_free(p2);
1110             PerlMemShared_free(aux);
1111         }
1112         break;
1113
1114     case OP_MULTIDEREF:
1115         {
1116             UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1117             UV actions = items->uv;
1118             bool last = 0;
1119             bool is_hash = FALSE;
1120
1121             while (!last) {
1122                 switch (actions & MDEREF_ACTION_MASK) {
1123
1124                 case MDEREF_reload:
1125                     actions = (++items)->uv;
1126                     continue;
1127
1128                 case MDEREF_HV_padhv_helem:
1129                     is_hash = TRUE;
1130                     /* FALLTHROUGH */
1131                 case MDEREF_AV_padav_aelem:
1132                     pad_free((++items)->pad_offset);
1133                     goto do_elem;
1134
1135                 case MDEREF_HV_gvhv_helem:
1136                     is_hash = TRUE;
1137                     /* FALLTHROUGH */
1138                 case MDEREF_AV_gvav_aelem:
1139 #ifdef USE_ITHREADS
1140                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1141 #else
1142                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1143 #endif
1144                     goto do_elem;
1145
1146                 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1147                     is_hash = TRUE;
1148                     /* FALLTHROUGH */
1149                 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1150 #ifdef USE_ITHREADS
1151                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1152 #else
1153                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1154 #endif
1155                     goto do_vivify_rv2xv_elem;
1156
1157                 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1158                     is_hash = TRUE;
1159                     /* FALLTHROUGH */
1160                 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1161                     pad_free((++items)->pad_offset);
1162                     goto do_vivify_rv2xv_elem;
1163
1164                 case MDEREF_HV_pop_rv2hv_helem:
1165                 case MDEREF_HV_vivify_rv2hv_helem:
1166                     is_hash = TRUE;
1167                     /* FALLTHROUGH */
1168                 do_vivify_rv2xv_elem:
1169                 case MDEREF_AV_pop_rv2av_aelem:
1170                 case MDEREF_AV_vivify_rv2av_aelem:
1171                 do_elem:
1172                     switch (actions & MDEREF_INDEX_MASK) {
1173                     case MDEREF_INDEX_none:
1174                         last = 1;
1175                         break;
1176                     case MDEREF_INDEX_const:
1177                         if (is_hash) {
1178 #ifdef USE_ITHREADS
1179                             /* see RT #15654 */
1180                             pad_swipe((++items)->pad_offset, 1);
1181 #else
1182                             SvREFCNT_dec((++items)->sv);
1183 #endif
1184                         }
1185                         else
1186                             items++;
1187                         break;
1188                     case MDEREF_INDEX_padsv:
1189                         pad_free((++items)->pad_offset);
1190                         break;
1191                     case MDEREF_INDEX_gvsv:
1192 #ifdef USE_ITHREADS
1193                         S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1194 #else
1195                         S_op_clear_gv(aTHX_ o, &((++items)->sv));
1196 #endif
1197                         break;
1198                     }
1199
1200                     if (actions & MDEREF_FLAG_last)
1201                         last = 1;
1202                     is_hash = FALSE;
1203
1204                     break;
1205
1206                 default:
1207                     assert(0);
1208                     last = 1;
1209                     break;
1210
1211                 } /* switch */
1212
1213                 actions >>= MDEREF_SHIFT;
1214             } /* while */
1215
1216             /* start of malloc is at op_aux[-1], where the length is
1217              * stored */
1218             PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1219         }
1220         break;
1221     }
1222
1223     if (o->op_targ > 0) {
1224         pad_free(o->op_targ);
1225         o->op_targ = 0;
1226     }
1227 }
1228
1229 STATIC void
1230 S_cop_free(pTHX_ COP* cop)
1231 {
1232     PERL_ARGS_ASSERT_COP_FREE;
1233
1234     CopFILE_free(cop);
1235     if (! specialWARN(cop->cop_warnings))
1236         PerlMemShared_free(cop->cop_warnings);
1237     cophh_free(CopHINTHASH_get(cop));
1238     if (PL_curcop == cop)
1239        PL_curcop = NULL;
1240 }
1241
1242 STATIC void
1243 S_forget_pmop(pTHX_ PMOP *const o)
1244 {
1245     HV * const pmstash = PmopSTASH(o);
1246
1247     PERL_ARGS_ASSERT_FORGET_PMOP;
1248
1249     if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1250         MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1251         if (mg) {
1252             PMOP **const array = (PMOP**) mg->mg_ptr;
1253             U32 count = mg->mg_len / sizeof(PMOP**);
1254             U32 i = count;
1255
1256             while (i--) {
1257                 if (array[i] == o) {
1258                     /* Found it. Move the entry at the end to overwrite it.  */
1259                     array[i] = array[--count];
1260                     mg->mg_len = count * sizeof(PMOP**);
1261                     /* Could realloc smaller at this point always, but probably
1262                        not worth it. Probably worth free()ing if we're the
1263                        last.  */
1264                     if(!count) {
1265                         Safefree(mg->mg_ptr);
1266                         mg->mg_ptr = NULL;
1267                     }
1268                     break;
1269                 }
1270             }
1271         }
1272     }
1273     if (PL_curpm == o)
1274         PL_curpm = NULL;
1275 }
1276
1277 STATIC void
1278 S_find_and_forget_pmops(pTHX_ OP *o)
1279 {
1280     PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1281
1282     if (o->op_flags & OPf_KIDS) {
1283         OP *kid = cUNOPo->op_first;
1284         while (kid) {
1285             switch (kid->op_type) {
1286             case OP_SUBST:
1287             case OP_SPLIT:
1288             case OP_MATCH:
1289             case OP_QR:
1290                 forget_pmop((PMOP*)kid);
1291             }
1292             find_and_forget_pmops(kid);
1293             kid = OpSIBLING(kid);
1294         }
1295     }
1296 }
1297
1298 /*
1299 =for apidoc Am|void|op_null|OP *o
1300
1301 Neutralizes an op when it is no longer needed, but is still linked to from
1302 other ops.
1303
1304 =cut
1305 */
1306
1307 void
1308 Perl_op_null(pTHX_ OP *o)
1309 {
1310     dVAR;
1311
1312     PERL_ARGS_ASSERT_OP_NULL;
1313
1314     if (o->op_type == OP_NULL)
1315         return;
1316     op_clear(o);
1317     o->op_targ = o->op_type;
1318     OpTYPE_set(o, OP_NULL);
1319 }
1320
1321 void
1322 Perl_op_refcnt_lock(pTHX)
1323   PERL_TSA_ACQUIRE(PL_op_mutex)
1324 {
1325 #ifdef USE_ITHREADS
1326     dVAR;
1327 #endif
1328     PERL_UNUSED_CONTEXT;
1329     OP_REFCNT_LOCK;
1330 }
1331
1332 void
1333 Perl_op_refcnt_unlock(pTHX)
1334   PERL_TSA_RELEASE(PL_op_mutex)
1335 {
1336 #ifdef USE_ITHREADS
1337     dVAR;
1338 #endif
1339     PERL_UNUSED_CONTEXT;
1340     OP_REFCNT_UNLOCK;
1341 }
1342
1343
1344 /*
1345 =for apidoc op_sibling_splice
1346
1347 A general function for editing the structure of an existing chain of
1348 op_sibling nodes.  By analogy with the perl-level C<splice()> function, allows
1349 you to delete zero or more sequential nodes, replacing them with zero or
1350 more different nodes.  Performs the necessary op_first/op_last
1351 housekeeping on the parent node and op_sibling manipulation on the
1352 children.  The last deleted node will be marked as as the last node by
1353 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1354
1355 Note that op_next is not manipulated, and nodes are not freed; that is the
1356 responsibility of the caller.  It also won't create a new list op for an
1357 empty list etc; use higher-level functions like op_append_elem() for that.
1358
1359 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1360 the splicing doesn't affect the first or last op in the chain.
1361
1362 C<start> is the node preceding the first node to be spliced.  Node(s)
1363 following it will be deleted, and ops will be inserted after it.  If it is
1364 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1365 beginning.
1366
1367 C<del_count> is the number of nodes to delete.  If zero, no nodes are deleted.
1368 If -1 or greater than or equal to the number of remaining kids, all
1369 remaining kids are deleted.
1370
1371 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1372 If C<NULL>, no nodes are inserted.
1373
1374 The head of the chain of deleted ops is returned, or C<NULL> if no ops were
1375 deleted.
1376
1377 For example:
1378
1379     action                    before      after         returns
1380     ------                    -----       -----         -------
1381
1382                               P           P
1383     splice(P, A, 2, X-Y-Z)    |           |             B-C
1384                               A-B-C-D     A-X-Y-Z-D
1385
1386                               P           P
1387     splice(P, NULL, 1, X-Y)   |           |             A
1388                               A-B-C-D     X-Y-B-C-D
1389
1390                               P           P
1391     splice(P, NULL, 3, NULL)  |           |             A-B-C
1392                               A-B-C-D     D
1393
1394                               P           P
1395     splice(P, B, 0, X-Y)      |           |             NULL
1396                               A-B-C-D     A-B-X-Y-C-D
1397
1398
1399 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1400 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
1401
1402 =cut
1403 */
1404
1405 OP *
1406 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1407 {
1408     OP *first;
1409     OP *rest;
1410     OP *last_del = NULL;
1411     OP *last_ins = NULL;
1412
1413     if (start)
1414         first = OpSIBLING(start);
1415     else if (!parent)
1416         goto no_parent;
1417     else
1418         first = cLISTOPx(parent)->op_first;
1419
1420     assert(del_count >= -1);
1421
1422     if (del_count && first) {
1423         last_del = first;
1424         while (--del_count && OpHAS_SIBLING(last_del))
1425             last_del = OpSIBLING(last_del);
1426         rest = OpSIBLING(last_del);
1427         OpLASTSIB_set(last_del, NULL);
1428     }
1429     else
1430         rest = first;
1431
1432     if (insert) {
1433         last_ins = insert;
1434         while (OpHAS_SIBLING(last_ins))
1435             last_ins = OpSIBLING(last_ins);
1436         OpMAYBESIB_set(last_ins, rest, NULL);
1437     }
1438     else
1439         insert = rest;
1440
1441     if (start) {
1442         OpMAYBESIB_set(start, insert, NULL);
1443     }
1444     else {
1445         if (!parent)
1446             goto no_parent;
1447         cLISTOPx(parent)->op_first = insert;
1448         if (insert)
1449             parent->op_flags |= OPf_KIDS;
1450         else
1451             parent->op_flags &= ~OPf_KIDS;
1452     }
1453
1454     if (!rest) {
1455         /* update op_last etc */
1456         U32 type;
1457         OP *lastop;
1458
1459         if (!parent)
1460             goto no_parent;
1461
1462         /* ought to use OP_CLASS(parent) here, but that can't handle
1463          * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1464          * either */
1465         type = parent->op_type;
1466         if (type == OP_CUSTOM) {
1467             dTHX;
1468             type = XopENTRYCUSTOM(parent, xop_class);
1469         }
1470         else {
1471             if (type == OP_NULL)
1472                 type = parent->op_targ;
1473             type = PL_opargs[type] & OA_CLASS_MASK;
1474         }
1475
1476         lastop = last_ins ? last_ins : start ? start : NULL;
1477         if (   type == OA_BINOP
1478             || type == OA_LISTOP
1479             || type == OA_PMOP
1480             || type == OA_LOOP
1481         )
1482             cLISTOPx(parent)->op_last = lastop;
1483
1484         if (lastop)
1485             OpLASTSIB_set(lastop, parent);
1486     }
1487     return last_del ? first : NULL;
1488
1489   no_parent:
1490     Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1491 }
1492
1493 /*
1494 =for apidoc op_parent
1495
1496 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1497
1498 =cut
1499 */
1500
1501 OP *
1502 Perl_op_parent(OP *o)
1503 {
1504     PERL_ARGS_ASSERT_OP_PARENT;
1505     while (OpHAS_SIBLING(o))
1506         o = OpSIBLING(o);
1507     return o->op_sibparent;
1508 }
1509
1510 /* replace the sibling following start with a new UNOP, which becomes
1511  * the parent of the original sibling; e.g.
1512  *
1513  *  op_sibling_newUNOP(P, A, unop-args...)
1514  *
1515  *  P              P
1516  *  |      becomes |
1517  *  A-B-C          A-U-C
1518  *                   |
1519  *                   B
1520  *
1521  * where U is the new UNOP.
1522  *
1523  * parent and start args are the same as for op_sibling_splice();
1524  * type and flags args are as newUNOP().
1525  *
1526  * Returns the new UNOP.
1527  */
1528
1529 STATIC OP *
1530 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1531 {
1532     OP *kid, *newop;
1533
1534     kid = op_sibling_splice(parent, start, 1, NULL);
1535     newop = newUNOP(type, flags, kid);
1536     op_sibling_splice(parent, start, 0, newop);
1537     return newop;
1538 }
1539
1540
1541 /* lowest-level newLOGOP-style function - just allocates and populates
1542  * the struct. Higher-level stuff should be done by S_new_logop() /
1543  * newLOGOP(). This function exists mainly to avoid op_first assignment
1544  * being spread throughout this file.
1545  */
1546
1547 LOGOP *
1548 Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1549 {
1550     dVAR;
1551     LOGOP *logop;
1552     OP *kid = first;
1553     NewOp(1101, logop, 1, LOGOP);
1554     OpTYPE_set(logop, type);
1555     logop->op_first = first;
1556     logop->op_other = other;
1557     if (first)
1558         logop->op_flags = OPf_KIDS;
1559     while (kid && OpHAS_SIBLING(kid))
1560         kid = OpSIBLING(kid);
1561     if (kid)
1562         OpLASTSIB_set(kid, (OP*)logop);
1563     return logop;
1564 }
1565
1566
1567 /* Contextualizers */
1568
1569 /*
1570 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1571
1572 Applies a syntactic context to an op tree representing an expression.
1573 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
1574 or C<G_VOID> to specify the context to apply.  The modified op tree
1575 is returned.
1576
1577 =cut
1578 */
1579
1580 OP *
1581 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1582 {
1583     PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1584     switch (context) {
1585         case G_SCALAR: return scalar(o);
1586         case G_ARRAY:  return list(o);
1587         case G_VOID:   return scalarvoid(o);
1588         default:
1589             Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1590                        (long) context);
1591     }
1592 }
1593
1594 /*
1595
1596 =for apidoc Am|OP*|op_linklist|OP *o
1597 This function is the implementation of the L</LINKLIST> macro.  It should
1598 not be called directly.
1599
1600 =cut
1601 */
1602
1603 OP *
1604 Perl_op_linklist(pTHX_ OP *o)
1605 {
1606     OP *first;
1607
1608     PERL_ARGS_ASSERT_OP_LINKLIST;
1609
1610     if (o->op_next)
1611         return o->op_next;
1612
1613     /* establish postfix order */
1614     first = cUNOPo->op_first;
1615     if (first) {
1616         OP *kid;
1617         o->op_next = LINKLIST(first);
1618         kid = first;
1619         for (;;) {
1620             OP *sibl = OpSIBLING(kid);
1621             if (sibl) {
1622                 kid->op_next = LINKLIST(sibl);
1623                 kid = sibl;
1624             } else {
1625                 kid->op_next = o;
1626                 break;
1627             }
1628         }
1629     }
1630     else
1631         o->op_next = o;
1632
1633     return o->op_next;
1634 }
1635
1636 static OP *
1637 S_scalarkids(pTHX_ OP *o)
1638 {
1639     if (o && o->op_flags & OPf_KIDS) {
1640         OP *kid;
1641         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1642             scalar(kid);
1643     }
1644     return o;
1645 }
1646
1647 STATIC OP *
1648 S_scalarboolean(pTHX_ OP *o)
1649 {
1650     PERL_ARGS_ASSERT_SCALARBOOLEAN;
1651
1652     if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1653          !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1654         (o->op_type == OP_NOT     && cUNOPo->op_first->op_type == OP_SASSIGN &&
1655          cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1656          !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
1657         if (ckWARN(WARN_SYNTAX)) {
1658             const line_t oldline = CopLINE(PL_curcop);
1659
1660             if (PL_parser && PL_parser->copline != NOLINE) {
1661                 /* This ensures that warnings are reported at the first line
1662                    of the conditional, not the last.  */
1663                 CopLINE_set(PL_curcop, PL_parser->copline);
1664             }
1665             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1666             CopLINE_set(PL_curcop, oldline);
1667         }
1668     }
1669     return scalar(o);
1670 }
1671
1672 static SV *
1673 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1674 {
1675     assert(o);
1676     assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1677            o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1678     {
1679         const char funny  = o->op_type == OP_PADAV
1680                          || o->op_type == OP_RV2AV ? '@' : '%';
1681         if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1682             GV *gv;
1683             if (cUNOPo->op_first->op_type != OP_GV
1684              || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1685                 return NULL;
1686             return varname(gv, funny, 0, NULL, 0, subscript_type);
1687         }
1688         return
1689             varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1690     }
1691 }
1692
1693 static SV *
1694 S_op_varname(pTHX_ const OP *o)
1695 {
1696     return S_op_varname_subscript(aTHX_ o, 1);
1697 }
1698
1699 static void
1700 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1701 { /* or not so pretty :-) */
1702     if (o->op_type == OP_CONST) {
1703         *retsv = cSVOPo_sv;
1704         if (SvPOK(*retsv)) {
1705             SV *sv = *retsv;
1706             *retsv = sv_newmortal();
1707             pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1708                       PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1709         }
1710         else if (!SvOK(*retsv))
1711             *retpv = "undef";
1712     }
1713     else *retpv = "...";
1714 }
1715
1716 static void
1717 S_scalar_slice_warning(pTHX_ const OP *o)
1718 {
1719     OP *kid;
1720     const bool h = o->op_type == OP_HSLICE
1721                 || (o->op_type == OP_NULL && o->op_targ == OP_HSLICE);
1722     const char lbrack =
1723         h ? '{' : '[';
1724     const char rbrack =
1725         h ? '}' : ']';
1726     SV *name;
1727     SV *keysv = NULL; /* just to silence compiler warnings */
1728     const char *key = NULL;
1729
1730     if (!(o->op_private & OPpSLICEWARNING))
1731         return;
1732     if (PL_parser && PL_parser->error_count)
1733         /* This warning can be nonsensical when there is a syntax error. */
1734         return;
1735
1736     kid = cLISTOPo->op_first;
1737     kid = OpSIBLING(kid); /* get past pushmark */
1738     /* weed out false positives: any ops that can return lists */
1739     switch (kid->op_type) {
1740     case OP_BACKTICK:
1741     case OP_GLOB:
1742     case OP_READLINE:
1743     case OP_MATCH:
1744     case OP_RV2AV:
1745     case OP_EACH:
1746     case OP_VALUES:
1747     case OP_KEYS:
1748     case OP_SPLIT:
1749     case OP_LIST:
1750     case OP_SORT:
1751     case OP_REVERSE:
1752     case OP_ENTERSUB:
1753     case OP_CALLER:
1754     case OP_LSTAT:
1755     case OP_STAT:
1756     case OP_READDIR:
1757     case OP_SYSTEM:
1758     case OP_TMS:
1759     case OP_LOCALTIME:
1760     case OP_GMTIME:
1761     case OP_ENTEREVAL:
1762         return;
1763     }
1764
1765     /* Don't warn if we have a nulled list either. */
1766     if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1767         return;
1768
1769     assert(OpSIBLING(kid));
1770     name = S_op_varname(aTHX_ OpSIBLING(kid));
1771     if (!name) /* XS module fiddling with the op tree */
1772         return;
1773     S_op_pretty(aTHX_ kid, &keysv, &key);
1774     assert(SvPOK(name));
1775     sv_chop(name,SvPVX(name)+1);
1776     if (key)
1777        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1778         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1779                    "Scalar value @%" SVf "%c%s%c better written as $%" SVf
1780                    "%c%s%c",
1781                     SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1782                     lbrack, key, rbrack);
1783     else
1784        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1785         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1786                    "Scalar value @%" SVf "%c%" SVf "%c better written as $%"
1787                     SVf "%c%" SVf "%c",
1788                     SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1789                     SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1790 }
1791
1792 OP *
1793 Perl_scalar(pTHX_ OP *o)
1794 {
1795     OP *kid;
1796
1797     /* assumes no premature commitment */
1798     if (!o || (PL_parser && PL_parser->error_count)
1799          || (o->op_flags & OPf_WANT)
1800          || o->op_type == OP_RETURN)
1801     {
1802         return o;
1803     }
1804
1805     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1806
1807     switch (o->op_type) {
1808     case OP_REPEAT:
1809         scalar(cBINOPo->op_first);
1810         if (o->op_private & OPpREPEAT_DOLIST) {
1811             kid = cLISTOPx(cUNOPo->op_first)->op_first;
1812             assert(kid->op_type == OP_PUSHMARK);
1813             if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1814                 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1815                 o->op_private &=~ OPpREPEAT_DOLIST;
1816             }
1817         }
1818         break;
1819     case OP_OR:
1820     case OP_AND:
1821     case OP_COND_EXPR:
1822         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
1823             scalar(kid);
1824         break;
1825         /* FALLTHROUGH */
1826     case OP_SPLIT:
1827     case OP_MATCH:
1828     case OP_QR:
1829     case OP_SUBST:
1830     case OP_NULL:
1831     default:
1832         if (o->op_flags & OPf_KIDS) {
1833             for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1834                 scalar(kid);
1835         }
1836         break;
1837     case OP_LEAVE:
1838     case OP_LEAVETRY:
1839         kid = cLISTOPo->op_first;
1840         scalar(kid);
1841         kid = OpSIBLING(kid);
1842     do_kids:
1843         while (kid) {
1844             OP *sib = OpSIBLING(kid);
1845             if (sib && kid->op_type != OP_LEAVEWHEN
1846              && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
1847                 || (  sib->op_targ != OP_NEXTSTATE
1848                    && sib->op_targ != OP_DBSTATE  )))
1849                 scalarvoid(kid);
1850             else
1851                 scalar(kid);
1852             kid = sib;
1853         }
1854         PL_curcop = &PL_compiling;
1855         break;
1856     case OP_SCOPE:
1857     case OP_LINESEQ:
1858     case OP_LIST:
1859         kid = cLISTOPo->op_first;
1860         goto do_kids;
1861     case OP_SORT:
1862         Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1863         break;
1864     case OP_KVHSLICE:
1865     case OP_KVASLICE:
1866     {
1867         /* Warn about scalar context */
1868         const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1869         const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1870         SV *name;
1871         SV *keysv;
1872         const char *key = NULL;
1873
1874         /* This warning can be nonsensical when there is a syntax error. */
1875         if (PL_parser && PL_parser->error_count)
1876             break;
1877
1878         if (!ckWARN(WARN_SYNTAX)) break;
1879
1880         kid = cLISTOPo->op_first;
1881         kid = OpSIBLING(kid); /* get past pushmark */
1882         assert(OpSIBLING(kid));
1883         name = S_op_varname(aTHX_ OpSIBLING(kid));
1884         if (!name) /* XS module fiddling with the op tree */
1885             break;
1886         S_op_pretty(aTHX_ kid, &keysv, &key);
1887         assert(SvPOK(name));
1888         sv_chop(name,SvPVX(name)+1);
1889         if (key)
1890   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1891             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1892                        "%%%" SVf "%c%s%c in scalar context better written "
1893                        "as $%" SVf "%c%s%c",
1894                         SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1895                         lbrack, key, rbrack);
1896         else
1897   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1898             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1899                        "%%%" SVf "%c%" SVf "%c in scalar context better "
1900                        "written as $%" SVf "%c%" SVf "%c",
1901                         SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1902                         SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1903     }
1904     }
1905     return o;
1906 }
1907
1908 OP *
1909 Perl_scalarvoid(pTHX_ OP *arg)
1910 {
1911     dVAR;
1912     OP *kid;
1913     SV* sv;
1914     OP *o = arg;
1915     dDEFER_OP;
1916
1917     PERL_ARGS_ASSERT_SCALARVOID;
1918
1919     do {
1920         U8 want;
1921         SV *useless_sv = NULL;
1922         const char* useless = NULL;
1923
1924         if (o->op_type == OP_NEXTSTATE
1925             || o->op_type == OP_DBSTATE
1926             || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1927                                           || o->op_targ == OP_DBSTATE)))
1928             PL_curcop = (COP*)o;                /* for warning below */
1929
1930         /* assumes no premature commitment */
1931         want = o->op_flags & OPf_WANT;
1932         if ((want && want != OPf_WANT_SCALAR)
1933             || (PL_parser && PL_parser->error_count)
1934             || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1935         {
1936             continue;
1937         }
1938
1939         if ((o->op_private & OPpTARGET_MY)
1940             && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1941         {
1942             /* newASSIGNOP has already applied scalar context, which we
1943                leave, as if this op is inside SASSIGN.  */
1944             continue;
1945         }
1946
1947         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1948
1949         switch (o->op_type) {
1950         default:
1951             if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1952                 break;
1953             /* FALLTHROUGH */
1954         case OP_REPEAT:
1955             if (o->op_flags & OPf_STACKED)
1956                 break;
1957             if (o->op_type == OP_REPEAT)
1958                 scalar(cBINOPo->op_first);
1959             goto func_ops;
1960         case OP_CONCAT:
1961             if ((o->op_flags & OPf_STACKED) &&
1962                     !(o->op_private & OPpCONCAT_NESTED))
1963                 break;
1964             goto func_ops;
1965         case OP_SUBSTR:
1966             if (o->op_private == 4)
1967                 break;
1968             /* FALLTHROUGH */
1969         case OP_WANTARRAY:
1970         case OP_GV:
1971         case OP_SMARTMATCH:
1972         case OP_AV2ARYLEN:
1973         case OP_REF:
1974         case OP_REFGEN:
1975         case OP_SREFGEN:
1976         case OP_DEFINED:
1977         case OP_HEX:
1978         case OP_OCT:
1979         case OP_LENGTH:
1980         case OP_VEC:
1981         case OP_INDEX:
1982         case OP_RINDEX:
1983         case OP_SPRINTF:
1984         case OP_KVASLICE:
1985         case OP_KVHSLICE:
1986         case OP_UNPACK:
1987         case OP_PACK:
1988         case OP_JOIN:
1989         case OP_LSLICE:
1990         case OP_ANONLIST:
1991         case OP_ANONHASH:
1992         case OP_SORT:
1993         case OP_REVERSE:
1994         case OP_RANGE:
1995         case OP_FLIP:
1996         case OP_FLOP:
1997         case OP_CALLER:
1998         case OP_FILENO:
1999         case OP_EOF:
2000         case OP_TELL:
2001         case OP_GETSOCKNAME:
2002         case OP_GETPEERNAME:
2003         case OP_READLINK:
2004         case OP_TELLDIR:
2005         case OP_GETPPID:
2006         case OP_GETPGRP:
2007         case OP_GETPRIORITY:
2008         case OP_TIME:
2009         case OP_TMS:
2010         case OP_LOCALTIME:
2011         case OP_GMTIME:
2012         case OP_GHBYNAME:
2013         case OP_GHBYADDR:
2014         case OP_GHOSTENT:
2015         case OP_GNBYNAME:
2016         case OP_GNBYADDR:
2017         case OP_GNETENT:
2018         case OP_GPBYNAME:
2019         case OP_GPBYNUMBER:
2020         case OP_GPROTOENT:
2021         case OP_GSBYNAME:
2022         case OP_GSBYPORT:
2023         case OP_GSERVENT:
2024         case OP_GPWNAM:
2025         case OP_GPWUID:
2026         case OP_GGRNAM:
2027         case OP_GGRGID:
2028         case OP_GETLOGIN:
2029         case OP_PROTOTYPE:
2030         case OP_RUNCV:
2031         func_ops:
2032             useless = OP_DESC(o);
2033             break;
2034
2035         case OP_GVSV:
2036         case OP_PADSV:
2037         case OP_PADAV:
2038         case OP_PADHV:
2039         case OP_PADANY:
2040         case OP_AELEM:
2041         case OP_AELEMFAST:
2042         case OP_AELEMFAST_LEX:
2043         case OP_ASLICE:
2044         case OP_HELEM:
2045         case OP_HSLICE:
2046             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
2047                 /* Otherwise it's "Useless use of grep iterator" */
2048                 useless = OP_DESC(o);
2049             break;
2050
2051         case OP_SPLIT:
2052             if (!(o->op_private & OPpSPLIT_ASSIGN))
2053                 useless = OP_DESC(o);
2054             break;
2055
2056         case OP_NOT:
2057             kid = cUNOPo->op_first;
2058             if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2059                 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2060                 goto func_ops;
2061             }
2062             useless = "negative pattern binding (!~)";
2063             break;
2064
2065         case OP_SUBST:
2066             if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2067                 useless = "non-destructive substitution (s///r)";
2068             break;
2069
2070         case OP_TRANSR:
2071             useless = "non-destructive transliteration (tr///r)";
2072             break;
2073
2074         case OP_RV2GV:
2075         case OP_RV2SV:
2076         case OP_RV2AV:
2077         case OP_RV2HV:
2078             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
2079                 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
2080                 useless = "a variable";
2081             break;
2082
2083         case OP_CONST:
2084             sv = cSVOPo_sv;
2085             if (cSVOPo->op_private & OPpCONST_STRICT)
2086                 no_bareword_allowed(o);
2087             else {
2088                 if (ckWARN(WARN_VOID)) {
2089                     NV nv;
2090                     /* don't warn on optimised away booleans, eg
2091                      * use constant Foo, 5; Foo || print; */
2092                     if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2093                         useless = NULL;
2094                     /* the constants 0 and 1 are permitted as they are
2095                        conventionally used as dummies in constructs like
2096                        1 while some_condition_with_side_effects;  */
2097                     else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2098                         useless = NULL;
2099                     else if (SvPOK(sv)) {
2100                         SV * const dsv = newSVpvs("");
2101                         useless_sv
2102                             = Perl_newSVpvf(aTHX_
2103                                             "a constant (%s)",
2104                                             pv_pretty(dsv, SvPVX_const(sv),
2105                                                       SvCUR(sv), 32, NULL, NULL,
2106                                                       PERL_PV_PRETTY_DUMP
2107                                                       | PERL_PV_ESCAPE_NOCLEAR
2108                                                       | PERL_PV_ESCAPE_UNI_DETECT));
2109                         SvREFCNT_dec_NN(dsv);
2110                     }
2111                     else if (SvOK(sv)) {
2112                         useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv));
2113                     }
2114                     else
2115                         useless = "a constant (undef)";
2116                 }
2117             }
2118             op_null(o);         /* don't execute or even remember it */
2119             break;
2120
2121         case OP_POSTINC:
2122             OpTYPE_set(o, OP_PREINC);  /* pre-increment is faster */
2123             break;
2124
2125         case OP_POSTDEC:
2126             OpTYPE_set(o, OP_PREDEC);  /* pre-decrement is faster */
2127             break;
2128
2129         case OP_I_POSTINC:
2130             OpTYPE_set(o, OP_I_PREINC);        /* pre-increment is faster */
2131             break;
2132
2133         case OP_I_POSTDEC:
2134             OpTYPE_set(o, OP_I_PREDEC);        /* pre-decrement is faster */
2135             break;
2136
2137         case OP_SASSIGN: {
2138             OP *rv2gv;
2139             UNOP *refgen, *rv2cv;
2140             LISTOP *exlist;
2141
2142             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2143                 break;
2144
2145             rv2gv = ((BINOP *)o)->op_last;
2146             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2147                 break;
2148
2149             refgen = (UNOP *)((BINOP *)o)->op_first;
2150
2151             if (!refgen || (refgen->op_type != OP_REFGEN
2152                             && refgen->op_type != OP_SREFGEN))
2153                 break;
2154
2155             exlist = (LISTOP *)refgen->op_first;
2156             if (!exlist || exlist->op_type != OP_NULL
2157                 || exlist->op_targ != OP_LIST)
2158                 break;
2159
2160             if (exlist->op_first->op_type != OP_PUSHMARK
2161                 && exlist->op_first != exlist->op_last)
2162                 break;
2163
2164             rv2cv = (UNOP*)exlist->op_last;
2165
2166             if (rv2cv->op_type != OP_RV2CV)
2167                 break;
2168
2169             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2170             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2171             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2172
2173             o->op_private |= OPpASSIGN_CV_TO_GV;
2174             rv2gv->op_private |= OPpDONT_INIT_GV;
2175             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2176
2177             break;
2178         }
2179
2180         case OP_AASSIGN: {
2181             inplace_aassign(o);
2182             break;
2183         }
2184
2185         case OP_OR:
2186         case OP_AND:
2187             kid = cLOGOPo->op_first;
2188             if (kid->op_type == OP_NOT
2189                 && (kid->op_flags & OPf_KIDS)) {
2190                 if (o->op_type == OP_AND) {
2191                     OpTYPE_set(o, OP_OR);
2192                 } else {
2193                     OpTYPE_set(o, OP_AND);
2194                 }
2195                 op_null(kid);
2196             }
2197             /* FALLTHROUGH */
2198
2199         case OP_DOR:
2200         case OP_COND_EXPR:
2201         case OP_ENTERGIVEN:
2202         case OP_ENTERWHEN:
2203             for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2204                 if (!(kid->op_flags & OPf_KIDS))
2205                     scalarvoid(kid);
2206                 else
2207                     DEFER_OP(kid);
2208         break;
2209
2210         case OP_NULL:
2211             if (o->op_flags & OPf_STACKED)
2212                 break;
2213             /* FALLTHROUGH */
2214         case OP_NEXTSTATE:
2215         case OP_DBSTATE:
2216         case OP_ENTERTRY:
2217         case OP_ENTER:
2218             if (!(o->op_flags & OPf_KIDS))
2219                 break;
2220             /* FALLTHROUGH */
2221         case OP_SCOPE:
2222         case OP_LEAVE:
2223         case OP_LEAVETRY:
2224         case OP_LEAVELOOP:
2225         case OP_LINESEQ:
2226         case OP_LEAVEGIVEN:
2227         case OP_LEAVEWHEN:
2228         kids:
2229             for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2230                 if (!(kid->op_flags & OPf_KIDS))
2231                     scalarvoid(kid);
2232                 else
2233                     DEFER_OP(kid);
2234             break;
2235         case OP_LIST:
2236             /* If the first kid after pushmark is something that the padrange
2237                optimisation would reject, then null the list and the pushmark.
2238             */
2239             if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2240                 && (  !(kid = OpSIBLING(kid))
2241                       || (  kid->op_type != OP_PADSV
2242                             && kid->op_type != OP_PADAV
2243                             && kid->op_type != OP_PADHV)
2244                       || kid->op_private & ~OPpLVAL_INTRO
2245                       || !(kid = OpSIBLING(kid))
2246                       || (  kid->op_type != OP_PADSV
2247                             && kid->op_type != OP_PADAV
2248                             && kid->op_type != OP_PADHV)
2249                       || kid->op_private & ~OPpLVAL_INTRO)
2250             ) {
2251                 op_null(cUNOPo->op_first); /* NULL the pushmark */
2252                 op_null(o); /* NULL the list */
2253             }
2254             goto kids;
2255         case OP_ENTEREVAL:
2256             scalarkids(o);
2257             break;
2258         case OP_SCALAR:
2259             scalar(o);
2260             break;
2261         }
2262
2263         if (useless_sv) {
2264             /* mortalise it, in case warnings are fatal.  */
2265             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2266                            "Useless use of %" SVf " in void context",
2267                            SVfARG(sv_2mortal(useless_sv)));
2268         }
2269         else if (useless) {
2270             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2271                            "Useless use of %s in void context",
2272                            useless);
2273         }
2274     } while ( (o = POP_DEFERRED_OP()) );
2275
2276     DEFER_OP_CLEANUP;
2277
2278     return arg;
2279 }
2280
2281 static OP *
2282 S_listkids(pTHX_ OP *o)
2283 {
2284     if (o && o->op_flags & OPf_KIDS) {
2285         OP *kid;
2286         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2287             list(kid);
2288     }
2289     return o;
2290 }
2291
2292 OP *
2293 Perl_list(pTHX_ OP *o)
2294 {
2295     OP *kid;
2296
2297     /* assumes no premature commitment */
2298     if (!o || (o->op_flags & OPf_WANT)
2299          || (PL_parser && PL_parser->error_count)
2300          || o->op_type == OP_RETURN)
2301     {
2302         return o;
2303     }
2304
2305     if ((o->op_private & OPpTARGET_MY)
2306         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2307     {
2308         return o;                               /* As if inside SASSIGN */
2309     }
2310
2311     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2312
2313     switch (o->op_type) {
2314     case OP_FLOP:
2315         list(cBINOPo->op_first);
2316         break;
2317     case OP_REPEAT:
2318         if (o->op_private & OPpREPEAT_DOLIST
2319          && !(o->op_flags & OPf_STACKED))
2320         {
2321             list(cBINOPo->op_first);
2322             kid = cBINOPo->op_last;
2323             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2324              && SvIVX(kSVOP_sv) == 1)
2325             {
2326                 op_null(o); /* repeat */
2327                 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2328                 /* const (rhs): */
2329                 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2330             }
2331         }
2332         break;
2333     case OP_OR:
2334     case OP_AND:
2335     case OP_COND_EXPR:
2336         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2337             list(kid);
2338         break;
2339     default:
2340     case OP_MATCH:
2341     case OP_QR:
2342     case OP_SUBST:
2343     case OP_NULL:
2344         if (!(o->op_flags & OPf_KIDS))
2345             break;
2346         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2347             list(cBINOPo->op_first);
2348             return gen_constant_list(o);
2349         }
2350         listkids(o);
2351         break;
2352     case OP_LIST:
2353         listkids(o);
2354         if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2355             op_null(cUNOPo->op_first); /* NULL the pushmark */
2356             op_null(o); /* NULL the list */
2357         }
2358         break;
2359     case OP_LEAVE:
2360     case OP_LEAVETRY:
2361         kid = cLISTOPo->op_first;
2362         list(kid);
2363         kid = OpSIBLING(kid);
2364     do_kids:
2365         while (kid) {
2366             OP *sib = OpSIBLING(kid);
2367             if (sib && kid->op_type != OP_LEAVEWHEN)
2368                 scalarvoid(kid);
2369             else
2370                 list(kid);
2371             kid = sib;
2372         }
2373         PL_curcop = &PL_compiling;
2374         break;
2375     case OP_SCOPE:
2376     case OP_LINESEQ:
2377         kid = cLISTOPo->op_first;
2378         goto do_kids;
2379     }
2380     return o;
2381 }
2382
2383 static OP *
2384 S_scalarseq(pTHX_ OP *o)
2385 {
2386     if (o) {
2387         const OPCODE type = o->op_type;
2388
2389         if (type == OP_LINESEQ || type == OP_SCOPE ||
2390             type == OP_LEAVE || type == OP_LEAVETRY)
2391         {
2392             OP *kid, *sib;
2393             for (kid = cLISTOPo->op_first; kid; kid = sib) {
2394                 if ((sib = OpSIBLING(kid))
2395                  && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2396                     || (  sib->op_targ != OP_NEXTSTATE
2397                        && sib->op_targ != OP_DBSTATE  )))
2398                 {
2399                     scalarvoid(kid);
2400                 }
2401             }
2402             PL_curcop = &PL_compiling;
2403         }
2404         o->op_flags &= ~OPf_PARENS;
2405         if (PL_hints & HINT_BLOCK_SCOPE)
2406             o->op_flags |= OPf_PARENS;
2407     }
2408     else
2409         o = newOP(OP_STUB, 0);
2410     return o;
2411 }
2412
2413 STATIC OP *
2414 S_modkids(pTHX_ OP *o, I32 type)
2415 {
2416     if (o && o->op_flags & OPf_KIDS) {
2417         OP *kid;
2418         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2419             op_lvalue(kid, type);
2420     }
2421     return o;
2422 }
2423
2424
2425 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2426  * const fields. Also, convert CONST keys to HEK-in-SVs.
2427  * rop is the op that retrieves the hash;
2428  * key_op is the first key
2429  */
2430
2431 STATIC void
2432 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op)
2433 {
2434     PADNAME *lexname;
2435     GV **fields;
2436     bool check_fields;
2437
2438     /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2439     if (rop) {
2440         if (rop->op_first->op_type == OP_PADSV)
2441             /* @$hash{qw(keys here)} */
2442             rop = (UNOP*)rop->op_first;
2443         else {
2444             /* @{$hash}{qw(keys here)} */
2445             if (rop->op_first->op_type == OP_SCOPE
2446                 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2447                 {
2448                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2449                 }
2450             else
2451                 rop = NULL;
2452         }
2453     }
2454
2455     lexname = NULL; /* just to silence compiler warnings */
2456     fields  = NULL; /* just to silence compiler warnings */
2457
2458     check_fields =
2459             rop
2460          && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2461              SvPAD_TYPED(lexname))
2462          && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2463          && isGV(*fields) && GvHV(*fields);
2464
2465     for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2466         SV **svp, *sv;
2467         if (key_op->op_type != OP_CONST)
2468             continue;
2469         svp = cSVOPx_svp(key_op);
2470
2471         /* make sure it's not a bareword under strict subs */
2472         if (key_op->op_private & OPpCONST_BARE &&
2473             key_op->op_private & OPpCONST_STRICT)
2474         {
2475             no_bareword_allowed((OP*)key_op);
2476         }
2477
2478         /* Make the CONST have a shared SV */
2479         if (   !SvIsCOW_shared_hash(sv = *svp)
2480             && SvTYPE(sv) < SVt_PVMG
2481             && SvOK(sv)
2482             && !SvROK(sv))
2483         {
2484             SSize_t keylen;
2485             const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2486             SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2487             SvREFCNT_dec_NN(sv);
2488             *svp = nsv;
2489         }
2490
2491         if (   check_fields
2492             && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2493         {
2494             Perl_croak(aTHX_ "No such class field \"%" SVf "\" "
2495                         "in variable %" PNf " of type %" HEKf,
2496                         SVfARG(*svp), PNfARG(lexname),
2497                         HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2498         }
2499     }
2500 }
2501
2502 /* info returned by S_sprintf_is_multiconcatable() */
2503
2504 struct sprintf_ismc_info {
2505     SSize_t nargs;    /* num of args to sprintf (not including the format) */
2506     char  *start;     /* start of raw format string */
2507     char  *end;       /* bytes after end of raw format string */
2508     STRLEN total_len; /* total length (in bytes) of format string, not
2509                          including '%s' and  half of '%%' */
2510     STRLEN variant;   /* number of bytes by which total_len_p would grow
2511                          if upgraded to utf8 */
2512     bool   utf8;      /* whether the format is utf8 */
2513 };
2514
2515
2516 /* is the OP_SPRINTF o suitable for converting into a multiconcat op?
2517  * i.e. its format argument is a const string with only '%s' and '%%'
2518  * formats, and the number of args is known, e.g.
2519  *    sprintf "a=%s f=%s", $a[0], scalar(f());
2520  * but not
2521  *    sprintf "i=%d a=%s f=%s", $i, @a, f();
2522  *
2523  * If successful, the sprintf_ismc_info struct pointed to by info will be
2524  * populated.
2525  */
2526
2527 STATIC bool
2528 S_sprintf_is_multiconcatable(pTHX_ OP *o,struct sprintf_ismc_info *info)
2529 {
2530     OP    *pm, *constop, *kid;
2531     SV    *sv;
2532     char  *s, *e, *p;
2533     SSize_t nargs, nformats;
2534     STRLEN cur, total_len, variant;
2535     bool   utf8;
2536
2537     /* if sprintf's behaviour changes, die here so that someone
2538      * can decide whether to enhance this function or skip optimising
2539      * under those new circumstances */
2540     assert(!(o->op_flags & OPf_STACKED));
2541     assert(!(PL_opargs[OP_SPRINTF] & OA_TARGLEX));
2542     assert(!(o->op_private & ~OPpARG4_MASK));
2543
2544     pm = cUNOPo->op_first;
2545     if (pm->op_type != OP_PUSHMARK) /* weird coreargs stuff */
2546         return FALSE;
2547     constop = OpSIBLING(pm);
2548     if (!constop || constop->op_type != OP_CONST)
2549         return FALSE;
2550     sv = cSVOPx_sv(constop);
2551     if (SvMAGICAL(sv) || !SvPOK(sv))
2552         return FALSE;
2553
2554     s = SvPV(sv, cur);
2555     e = s + cur;
2556
2557     /* Scan format for %% and %s and work out how many %s there are.
2558      * Abandon if other format types are found.
2559      */
2560
2561     nformats  = 0;
2562     total_len = 0;
2563     variant   = 0;
2564
2565     for (p = s; p < e; p++) {
2566         if (*p != '%') {
2567             total_len++;
2568             if (!UTF8_IS_INVARIANT(*p))
2569                 variant++;
2570             continue;
2571         }
2572         p++;
2573         if (p >= e)
2574             return FALSE; /* lone % at end gives "Invalid conversion" */
2575         if (*p == '%')
2576             total_len++;
2577         else if (*p == 's')
2578             nformats++;
2579         else
2580             return FALSE;
2581     }
2582
2583     if (!nformats || nformats > PERL_MULTICONCAT_MAXARG)
2584         return FALSE;
2585
2586     utf8 = cBOOL(SvUTF8(sv));
2587     if (utf8)
2588         variant = 0;
2589
2590     /* scan args; they must all be in scalar cxt */
2591
2592     nargs = 0;
2593     kid = OpSIBLING(constop);
2594
2595     while (kid) {
2596         if ((kid->op_flags & OPf_WANT) != OPf_WANT_SCALAR)
2597             return FALSE;
2598         nargs++;
2599         kid = OpSIBLING(kid);
2600     }
2601
2602     if (nargs != nformats)
2603         return FALSE; /* e.g. sprintf("%s%s", $a); */
2604
2605
2606     info->nargs      = nargs;
2607     info->start      = s;
2608     info->end        = e;
2609     info->total_len  = total_len;
2610     info->variant    = variant;
2611     info->utf8       = utf8;
2612
2613     return TRUE;
2614 }
2615
2616
2617
2618 /* S_maybe_multiconcat():
2619  *
2620  * given an OP_STRINGIFY, OP_SASSIGN, OP_CONCAT or OP_SPRINTF op, possibly
2621  * convert it (and its children) into an OP_MULTICONCAT. See the code
2622  * comments just before pp_multiconcat() for the full details of what
2623  * OP_MULTICONCAT supports.
2624  *
2625  * Basically we're looking for an optree with a chain of OP_CONCATS down
2626  * the LHS (or an OP_SPRINTF), with possibly an OP_SASSIGN, and/or
2627  * OP_STRINGIFY, and/or OP_CONCAT acting as '.=' at its head, e.g.
2628  *
2629  *      $x = "$a$b-$c"
2630  *
2631  *  looks like
2632  *
2633  *      SASSIGN
2634  *         |
2635  *      STRINGIFY   -- PADSV[$x]
2636  *         |
2637  *         |
2638  *      ex-PUSHMARK -- CONCAT/S
2639  *                        |
2640  *                     CONCAT/S  -- PADSV[$d]
2641  *                        |
2642  *                     CONCAT    -- CONST["-"]
2643  *                        |
2644  *                     PADSV[$a] -- PADSV[$b]
2645  *
2646  * Note that at this stage the OP_SASSIGN may have already been optimised
2647  * away with OPpTARGET_MY set on the OP_STRINGIFY or OP_CONCAT.
2648  */
2649
2650 STATIC void
2651 S_maybe_multiconcat(pTHX_ OP *o)
2652 {
2653     dVAR;
2654     OP *lastkidop;   /* the right-most of any kids unshifted onto o */
2655     OP *topop;       /* the top-most op in the concat tree (often equals o,
2656                         unless there are assign/stringify ops above it */
2657     OP *parentop;    /* the parent op of topop (or itself if no parent) */
2658     OP *targmyop;    /* the op (if any) with the OPpTARGET_MY flag */
2659     OP *targetop;    /* the op corresponding to target=... or target.=... */
2660     OP *stringop;    /* the OP_STRINGIFY op, if any */
2661     OP *nextop;      /* used for recreating the op_next chain without consts */
2662     OP *kid;         /* general-purpose op pointer */
2663     UNOP_AUX_item *aux;
2664     UNOP_AUX_item *lenp;
2665     char *const_str, *p;
2666     struct sprintf_ismc_info sprintf_info;
2667
2668                      /* store info about each arg in args[];
2669                       * toparg is the highest used slot; argp is a general
2670                       * pointer to args[] slots */
2671     struct {
2672         void *p;      /* initially points to const sv (or null for op);
2673                          later, set to SvPV(constsv), with ... */
2674         STRLEN len;   /* ... len set to SvPV(..., len) */
2675     } *argp, *toparg, args[PERL_MULTICONCAT_MAXARG*2 + 1];
2676
2677     SSize_t nargs  = 0;
2678     SSize_t nconst = 0;
2679     SSize_t nadjconst  = 0; /* adjacent consts - may be demoted to args */
2680     STRLEN variant;
2681     bool utf8 = FALSE;
2682     bool kid_is_last = FALSE; /* most args will be the RHS kid of a concat op;
2683                                  the last-processed arg will the LHS of one,
2684                                  as args are processed in reverse order */
2685     U8   stacked_last = 0;   /* whether the last seen concat op was STACKED */
2686     STRLEN total_len  = 0;   /* sum of the lengths of the const segments */
2687     U8 flags          = 0;   /* what will become the op_flags and ... */
2688     U8 private_flags  = 0;   /* ... op_private of the multiconcat op */
2689     bool is_sprintf = FALSE; /* we're optimising an sprintf */
2690     bool is_targable  = FALSE; /* targetop is an OPpTARGET_MY candidate */
2691     bool prev_was_const = FALSE; /* previous arg was a const */
2692
2693     /* -----------------------------------------------------------------
2694      * Phase 1:
2695      *
2696      * Examine the optree non-destructively to determine whether it's
2697      * suitable to be converted into an OP_MULTICONCAT. Accumulate
2698      * information about the optree in args[].
2699      */
2700
2701     argp     = args;
2702     targmyop = NULL;
2703     targetop = NULL;
2704     stringop = NULL;
2705     topop    = o;
2706     parentop = o;
2707
2708     assert(   o->op_type == OP_SASSIGN
2709            || o->op_type == OP_CONCAT
2710            || o->op_type == OP_SPRINTF
2711            || o->op_type == OP_STRINGIFY);
2712
2713     Zero(&sprintf_info, 1, struct sprintf_ismc_info);
2714
2715     /* first see if, at the top of the tree, there is an assign,
2716      * append and/or stringify */
2717
2718     if (topop->op_type == OP_SASSIGN) {
2719         /* expr = ..... */
2720         if (o->op_ppaddr != PL_ppaddr[OP_SASSIGN])
2721             return;
2722         if (o->op_private & (OPpASSIGN_BACKWARDS|OPpASSIGN_CV_TO_GV))
2723             return;
2724         assert(!(o->op_private & ~OPpARG2_MASK)); /* barf on unknown flags */
2725
2726         parentop = topop;
2727         topop = cBINOPo->op_first;
2728         targetop = OpSIBLING(topop);
2729         if (!targetop) /* probably some sort of syntax error */
2730             return;
2731     }
2732     else if (   topop->op_type == OP_CONCAT
2733              && (topop->op_flags & OPf_STACKED)
2734              && (!(topop->op_private & OPpCONCAT_NESTED))
2735             )
2736     {
2737         /* expr .= ..... */
2738
2739         /* OPpTARGET_MY shouldn't be able to be set here. If it is,
2740          * decide what to do about it */
2741         assert(!(o->op_private & OPpTARGET_MY));
2742
2743         /* barf on unknown flags */
2744         assert(!(o->op_private & ~(OPpARG2_MASK|OPpTARGET_MY)));
2745         private_flags |= OPpMULTICONCAT_APPEND;
2746         targetop = cBINOPo->op_first;
2747         parentop = topop;
2748         topop    = OpSIBLING(targetop);
2749
2750         /* $x .= <FOO> gets optimised to rcatline instead */
2751         if (topop->op_type == OP_READLINE)
2752             return;
2753     }
2754
2755     if (targetop) {
2756         /* Can targetop (the LHS) if it's a padsv, be be optimised
2757          * away and use OPpTARGET_MY instead?
2758          */
2759         if (    (targetop->op_type == OP_PADSV)
2760             && !(targetop->op_private & OPpDEREF)
2761             && !(targetop->op_private & OPpPAD_STATE)
2762                /* we don't support 'my $x .= ...' */
2763             && (   o->op_type == OP_SASSIGN
2764                 || !(targetop->op_private & OPpLVAL_INTRO))
2765         )
2766             is_targable = TRUE;
2767     }
2768
2769     if (topop->op_type == OP_STRINGIFY) {
2770         if (topop->op_ppaddr != PL_ppaddr[OP_STRINGIFY])
2771             return;
2772         stringop = topop;
2773
2774         /* barf on unknown flags */
2775         assert(!(o->op_private & ~(OPpARG4_MASK|OPpTARGET_MY)));
2776
2777         if ((topop->op_private & OPpTARGET_MY)) {
2778             if (o->op_type == OP_SASSIGN)
2779                 return; /* can't have two assigns */
2780             targmyop = topop;
2781         }
2782
2783         private_flags |= OPpMULTICONCAT_STRINGIFY;
2784         parentop = topop;
2785         topop = cBINOPx(topop)->op_first;
2786         assert(OP_TYPE_IS_OR_WAS_NN(topop, OP_PUSHMARK));
2787         topop = OpSIBLING(topop);
2788     }
2789
2790     if (topop->op_type == OP_SPRINTF) {
2791         if (topop->op_ppaddr != PL_ppaddr[OP_SPRINTF])
2792             return;
2793         if (S_sprintf_is_multiconcatable(aTHX_ topop, &sprintf_info)) {
2794             nargs     = sprintf_info.nargs;
2795             total_len = sprintf_info.total_len;
2796             variant   = sprintf_info.variant;
2797             utf8      = sprintf_info.utf8;
2798             is_sprintf = TRUE;
2799             private_flags |= OPpMULTICONCAT_FAKE;
2800             toparg = argp;
2801             /* we have an sprintf op rather than a concat optree.
2802              * Skip most of the code below which is associated with
2803              * processing that optree. We also skip phase 2, determining
2804              * whether its cost effective to optimise, since for sprintf,
2805              * multiconcat is *always* faster */
2806             goto create_aux;
2807         }
2808         /* note that even if the sprintf itself isn't multiconcatable,
2809          * the expression as a whole may be, e.g. in
2810          *    $x .= sprintf("%d",...)
2811          * the sprintf op will be left as-is, but the concat/S op may
2812          * be upgraded to multiconcat
2813          */
2814     }
2815     else if (topop->op_type == OP_CONCAT) {
2816         if (topop->op_ppaddr != PL_ppaddr[OP_CONCAT])
2817             return;
2818
2819         if ((topop->op_private & OPpTARGET_MY)) {
2820             if (o->op_type == OP_SASSIGN || targmyop)
2821                 return; /* can't have two assigns */
2822             targmyop = topop;
2823         }
2824     }
2825
2826     /* Is it safe to convert a sassign/stringify/concat op into
2827      * a multiconcat? */
2828     assert((PL_opargs[OP_SASSIGN]   & OA_CLASS_MASK) == OA_BINOP);
2829     assert((PL_opargs[OP_CONCAT]    & OA_CLASS_MASK) == OA_BINOP);
2830     assert((PL_opargs[OP_STRINGIFY] & OA_CLASS_MASK) == OA_LISTOP);
2831     assert((PL_opargs[OP_SPRINTF]   & OA_CLASS_MASK) == OA_LISTOP);
2832     STATIC_ASSERT_STMT(   STRUCT_OFFSET(BINOP,    op_last)
2833                        == STRUCT_OFFSET(UNOP_AUX, op_aux));
2834     STATIC_ASSERT_STMT(   STRUCT_OFFSET(LISTOP,   op_last)
2835                        == STRUCT_OFFSET(UNOP_AUX, op_aux));
2836
2837     /* Now scan the down the tree looking for a series of
2838      * CONCAT/OPf_STACKED ops on the LHS (with the last one not
2839      * stacked). For example this tree:
2840      *
2841      *     |
2842      *   CONCAT/STACKED
2843      *     |
2844      *   CONCAT/STACKED -- EXPR5
2845      *     |
2846      *   CONCAT/STACKED -- EXPR4
2847      *     |
2848      *   CONCAT -- EXPR3
2849      *     |
2850      *   EXPR1  -- EXPR2
2851      *
2852      * corresponds to an expression like
2853      *
2854      *   (EXPR1 . EXPR2 . EXPR3 . EXPR4 . EXPR5)
2855      *
2856      * Record info about each EXPR in args[]: in particular, whether it is
2857      * a stringifiable OP_CONST and if so what the const sv is.
2858      *
2859      * The reason why the last concat can't be STACKED is the difference
2860      * between
2861      *
2862      *    ((($a .= $a) .= $a) .= $a) .= $a
2863      *
2864      * and
2865      *    $a . $a . $a . $a . $a
2866      *
2867      * The main difference between the optrees for those two constructs
2868      * is the presence of the last STACKED. As well as modifying $a,
2869      * the former sees the changed $a between each concat, so if $s is
2870      * initially 'a', the first returns 'a' x 16, while the latter returns
2871      * 'a' x 5. And pp_multiconcat can't handle that kind of thing.
2872      */
2873
2874     kid = topop;
2875
2876     for (;;) {
2877         OP *argop;
2878         SV *sv;
2879         bool last = FALSE;
2880
2881         if (    kid->op_type == OP_CONCAT
2882             && !kid_is_last
2883         ) {
2884             OP *k1, *k2;
2885             k1 = cUNOPx(kid)->op_first;
2886             k2 = OpSIBLING(k1);
2887             /* shouldn't happen except maybe after compile err? */
2888             if (!k2)
2889                 return;
2890
2891             /* avoid turning (A . B . ($lex = C) ...)  into  (A . B . C ...) */
2892             if (kid->op_private & OPpTARGET_MY)
2893                 kid_is_last = TRUE;
2894
2895             stacked_last = (kid->op_flags & OPf_STACKED);
2896             if (!stacked_last)
2897                 kid_is_last = TRUE;
2898
2899             kid   = k1;
2900             argop = k2;
2901         }
2902         else {
2903             argop = kid;
2904             last = TRUE;
2905         }
2906
2907         if (   nargs + nadjconst  >  PERL_MULTICONCAT_MAXARG        - 2
2908             || (argp - args + 1)  > (PERL_MULTICONCAT_MAXARG*2 + 1) - 2)
2909         {
2910             /* At least two spare slots are needed to decompose both
2911              * concat args. If there are no slots left, continue to
2912              * examine the rest of the optree, but don't push new values
2913              * on args[]. If the optree as a whole is legal for conversion
2914              * (in particular that the last concat isn't STACKED), then
2915              * the first PERL_MULTICONCAT_MAXARG elements of the optree
2916              * can be converted into an OP_MULTICONCAT now, with the first
2917              * child of that op being the remainder of the optree -
2918              * which may itself later be converted to a multiconcat op
2919              * too.
2920              */
2921             if (last) {
2922                 /* the last arg is the rest of the optree */
2923                 argp++->p = NULL;
2924                 nargs++;
2925             }
2926         }
2927         else if (   argop->op_type == OP_CONST
2928             && ((sv = cSVOPx_sv(argop)))
2929             /* defer stringification until runtime of 'constant'
2930              * things that might stringify variantly, e.g. the radix
2931              * point of NVs, or overloaded RVs */
2932             && (SvPOK(sv) || SvIOK(sv))
2933             && (!SvGMAGICAL(sv))
2934         ) {
2935             argp++->p = sv;
2936             utf8   |= cBOOL(SvUTF8(sv));
2937             nconst++;
2938             if (prev_was_const)
2939                 /* this const may be demoted back to a plain arg later;
2940                  * make sure we have enough arg slots left */
2941                 nadjconst++;
2942             prev_was_const = !prev_was_const;
2943         }
2944         else {
2945             argp++->p = NULL;
2946             nargs++;
2947             prev_was_const = FALSE;
2948         }
2949
2950         if (last)
2951             break;
2952     }
2953
2954     toparg = argp - 1;
2955
2956     if (stacked_last)
2957         return; /* we don't support ((A.=B).=C)...) */
2958
2959     /* look for two adjacent consts and don't fold them together:
2960      *     $o . "a" . "b"
2961      * should do
2962      *     $o->concat("a")->concat("b")
2963      * rather than
2964      *     $o->concat("ab")
2965      * (but $o .=  "a" . "b" should still fold)
2966      */
2967     {
2968         bool seen_nonconst = FALSE;
2969         for (argp = toparg; argp >= args; argp--) {
2970             if (argp->p == NULL) {
2971                 seen_nonconst = TRUE;
2972                 continue;
2973             }
2974             if (!seen_nonconst)
2975                 continue;
2976             if (argp[1].p) {
2977                 /* both previous and current arg were constants;
2978                  * leave the current OP_CONST as-is */
2979                 argp->p = NULL;
2980                 nconst--;
2981                 nargs++;
2982             }
2983         }
2984     }
2985
2986     /* -----------------------------------------------------------------
2987      * Phase 2:
2988      *
2989      * At this point we have determined that the optree *can* be converted
2990      * into a multiconcat. Having gathered all the evidence, we now decide
2991      * whether it *should*.
2992      */
2993
2994
2995     /* we need at least one concat action, e.g.:
2996      *
2997      *  Y . Z
2998      *  X = Y . Z
2999      *  X .= Y
3000      *
3001      * otherwise we could be doing something like $x = "foo", which
3002      * if treated as as a concat, would fail to COW.
3003      */
3004     if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 2)
3005         return;
3006
3007     /* Benchmarking seems to indicate that we gain if:
3008      * * we optimise at least two actions into a single multiconcat
3009      *    (e.g concat+concat, sassign+concat);
3010      * * or if we can eliminate at least 1 OP_CONST;
3011      * * or if we can eliminate a padsv via OPpTARGET_MY
3012      */
3013
3014     if (
3015            /* eliminated at least one OP_CONST */
3016            nconst >= 1
3017            /* eliminated an OP_SASSIGN */
3018         || o->op_type == OP_SASSIGN
3019            /* eliminated an OP_PADSV */
3020         || (!targmyop && is_targable)
3021     )
3022         /* definitely a net gain to optimise */
3023         goto optimise;
3024
3025     /* ... if not, what else? */
3026
3027     /* special-case '$lex1 = expr . $lex1' (where expr isn't lex1):
3028      * multiconcat is faster (due to not creating a temporary copy of
3029      * $lex1), whereas for a general $lex1 = $lex2 . $lex3, concat is
3030      * faster.
3031      */
3032     if (   nconst == 0
3033          && nargs == 2
3034          && targmyop
3035          && topop->op_type == OP_CONCAT
3036     ) {
3037         PADOFFSET t = targmyop->op_targ;
3038         OP *k1 = cBINOPx(topop)->op_first;
3039         OP *k2 = cBINOPx(topop)->op_last;
3040         if (   k2->op_type == OP_PADSV
3041             && k2->op_targ == t
3042             && (   k1->op_type != OP_PADSV
3043                 || k1->op_targ != t)
3044         )
3045             goto optimise;
3046     }
3047
3048     /* need at least two concats */
3049     if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 3)
3050         return;
3051
3052
3053
3054     /* -----------------------------------------------------------------
3055      * Phase 3:
3056      *
3057      * At this point the optree has been verified as ok to be optimised
3058      * into an OP_MULTICONCAT. Now start changing things.
3059      */
3060
3061    optimise:
3062
3063     /* stringify all const args and determine utf8ness */
3064
3065     variant = 0;
3066     for (argp = args; argp <= toparg; argp++) {
3067         SV *sv = (SV*)argp->p;
3068         if (!sv)
3069             continue; /* not a const op */
3070         if (utf8 && !SvUTF8(sv))
3071             sv_utf8_upgrade_nomg(sv);
3072         argp->p = SvPV_nomg(sv, argp->len);
3073         total_len += argp->len;
3074
3075         /* see if any strings would grow if converted to utf8 */
3076         if (!utf8) {
3077             char *p    = (char*)argp->p;
3078             STRLEN len = argp->len;
3079             while (len--) {
3080                 U8 c = *p++;
3081                 if (!UTF8_IS_INVARIANT(c))
3082                     variant++;
3083             }
3084         }
3085     }
3086
3087     /* create and populate aux struct */
3088
3089   create_aux:
3090
3091     aux = (UNOP_AUX_item*)PerlMemShared_malloc(
3092                     sizeof(UNOP_AUX_item)
3093                     *  (
3094                            PERL_MULTICONCAT_HEADER_SIZE
3095                          + ((nargs + 1) * (variant ? 2 : 1))
3096                         )
3097                     );
3098     const_str = (char *)PerlMemShared_malloc(total_len ? total_len : 1);
3099
3100     /* Extract all the non-const expressions from the concat tree then
3101      * dispose of the old tree, e.g. convert the tree from this:
3102      *
3103      *  o => SASSIGN
3104      *         |
3105      *       STRINGIFY   -- TARGET
3106      *         |
3107      *       ex-PUSHMARK -- CONCAT
3108      *                        |
3109      *                      CONCAT -- EXPR5
3110      *                        |
3111      *                      CONCAT -- EXPR4
3112      *                        |
3113      *                      CONCAT -- EXPR3
3114      *                        |
3115      *                      EXPR1  -- EXPR2
3116      *
3117      *
3118      * to:
3119      *
3120      *  o => MULTICONCAT
3121      *         |
3122      *       ex-PUSHMARK -- EXPR1 -- EXPR2 -- EXPR3 -- EXPR4 -- EXPR5 -- TARGET
3123      *
3124      * except that if EXPRi is an OP_CONST, it's discarded.
3125      *
3126      * During the conversion process, EXPR ops are stripped from the tree
3127      * and unshifted onto o. Finally, any of o's remaining original
3128      * childen are discarded and o is converted into an OP_MULTICONCAT.
3129      *
3130      * In this middle of this, o may contain both: unshifted args on the
3131      * left, and some remaining original args on the right. lastkidop
3132      * is set to point to the right-most unshifted arg to delineate
3133      * between the two sets.
3134      */
3135
3136
3137     if (is_sprintf) {
3138         /* create a copy of the format with the %'s removed, and record
3139          * the sizes of the const string segments in the aux struct */
3140         char *q, *oldq;
3141         lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3142
3143         p    = sprintf_info.start;
3144         q    = const_str;
3145         oldq = q;
3146         for (; p < sprintf_info.end; p++) {
3147             if (*p == '%') {
3148                 p++;
3149                 if (*p != '%') {
3150                     (lenp++)->ssize = q - oldq;
3151                     oldq = q;
3152                     continue;
3153                 }
3154             }
3155             *q++ = *p;
3156         }
3157         lenp->ssize = q - oldq;
3158         assert((STRLEN)(q - const_str) == total_len);
3159
3160         /* Attach all the args (i.e. the kids of the sprintf) to o (which
3161          * may or may not be topop) The pushmark and const ops need to be
3162          * kept in case they're an op_next entry point.
3163          */
3164         lastkidop = cLISTOPx(topop)->op_last;
3165         kid = cUNOPx(topop)->op_first; /* pushmark */
3166         op_null(kid);
3167         op_null(OpSIBLING(kid));       /* const */
3168         if (o != topop) {
3169             kid = op_sibling_splice(topop, NULL, -1, NULL); /* cut all args */
3170             op_sibling_splice(o, NULL, 0, kid); /* and attach to o */
3171             lastkidop->op_next = o;
3172         }
3173     }
3174     else {
3175         p = const_str;
3176         lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3177
3178         lenp->ssize = -1;
3179
3180         /* Concatenate all const strings into const_str.
3181          * Note that args[] contains the RHS args in reverse order, so
3182          * we scan args[] from top to bottom to get constant strings
3183          * in L-R order
3184          */
3185         for (argp = toparg; argp >= args; argp--) {
3186             if (!argp->p)
3187                 /* not a const op */
3188                 (++lenp)->ssize = -1;
3189             else {
3190                 STRLEN l = argp->len;
3191                 Copy(argp->p, p, l, char);
3192                 p += l;
3193                 if (lenp->ssize == -1)
3194                     lenp->ssize = l;
3195                 else
3196                     lenp->ssize += l;
3197             }
3198         }
3199
3200         kid = topop;
3201         nextop = o;
3202         lastkidop = NULL;
3203
3204         for (argp = args; argp <= toparg; argp++) {
3205             /* only keep non-const args, except keep the first-in-next-chain
3206              * arg no matter what it is (but nulled if OP_CONST), because it
3207              * may be the entry point to this subtree from the previous
3208              * op_next.
3209              */
3210             bool last = (argp == toparg);
3211             OP *prev;
3212
3213             /* set prev to the sibling *before* the arg to be cut out,
3214              * e.g. when cutting EXPR:
3215              *
3216              *         |
3217              * kid=  CONCAT
3218              *         |
3219              * prev= CONCAT -- EXPR
3220              *         |
3221              */
3222             if (argp == args && kid->op_type != OP_CONCAT) {
3223                 /* in e.g. '$x .= f(1)' there's no RHS concat tree
3224                  * so the expression to be cut isn't kid->op_last but
3225                  * kid itself */
3226                 OP *o1, *o2;
3227                 /* find the op before kid */
3228                 o1 = NULL;
3229                 o2 = cUNOPx(parentop)->op_first;
3230                 while (o2 && o2 != kid) {
3231                     o1 = o2;
3232                     o2 = OpSIBLING(o2);
3233                 }
3234                 assert(o2 == kid);
3235                 prev = o1;
3236                 kid  = parentop;
3237             }
3238             else if (kid == o && lastkidop)
3239                 prev = last ? lastkidop : OpSIBLING(lastkidop);
3240             else
3241                 prev = last ? NULL : cUNOPx(kid)->op_first;
3242
3243             if (!argp->p || last) {
3244                 /* cut RH op */
3245                 OP *aop = op_sibling_splice(kid, prev, 1, NULL);
3246                 /* and unshift to front of o */
3247                 op_sibling_splice(o, NULL, 0, aop);
3248                 /* record the right-most op added to o: later we will
3249                  * free anything to the right of it */
3250                 if (!lastkidop)
3251                     lastkidop = aop;
3252                 aop->op_next = nextop;
3253                 if (last) {
3254                     if (argp->p)
3255                         /* null the const at start of op_next chain */
3256                         op_null(aop);
3257                 }
3258                 else if (prev)
3259                     nextop = prev->op_next;
3260             }
3261
3262             /* the last two arguments are both attached to the same concat op */
3263             if (argp < toparg - 1)
3264                 kid = prev;
3265         }
3266     }
3267
3268     /* Populate the aux struct */
3269
3270     aux[PERL_MULTICONCAT_IX_NARGS].ssize     = nargs;
3271     aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv    = utf8 ? NULL : const_str;
3272     aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize = utf8 ?    0 : total_len;
3273     aux[PERL_MULTICONCAT_IX_UTF8_PV].pv     = const_str;
3274     aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize  = total_len;
3275
3276     /* if variant > 0, calculate a variant const string and lengths where
3277      * the utf8 version of the string will take 'variant' more bytes than
3278      * the plain one. */
3279
3280     if (variant) {
3281         char              *p = const_str;
3282         STRLEN          ulen = total_len + variant;
3283         UNOP_AUX_item  *lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
3284         UNOP_AUX_item *ulens = lens + (nargs + 1);
3285         char             *up = (char*)PerlMemShared_malloc(ulen);
3286         SSize_t            n;
3287
3288         aux[PERL_MULTICONCAT_IX_UTF8_PV].pv    = up;
3289         aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = ulen;
3290
3291         for (n = 0; n < (nargs + 1); n++) {
3292             SSize_t i;
3293             char * orig_up = up;
3294             for (i = (lens++)->ssize; i > 0; i--) {
3295                 U8 c = *p++;
3296                 append_utf8_from_native_byte(c, (U8**)&up);
3297             }
3298             (ulens++)->ssize = (i < 0) ? i : up - orig_up;
3299         }
3300     }
3301
3302     if (stringop) {
3303         /* if there was a top(ish)-level OP_STRINGIFY, we need to keep
3304          * that op's first child - an ex-PUSHMARK - because the op_next of
3305          * the previous op may point to it (i.e. it's the entry point for
3306          * the o optree)
3307          */
3308         OP *pmop =
3309             (stringop == o)
3310                 ? op_sibling_splice(o, lastkidop, 1, NULL)
3311                 : op_sibling_splice(stringop, NULL, 1, NULL);
3312         assert(OP_TYPE_IS_OR_WAS_NN(pmop, OP_PUSHMARK));
3313         op_sibling_splice(o, NULL, 0, pmop);
3314         if (!lastkidop)
3315             lastkidop = pmop;
3316     }
3317
3318     /* Optimise
3319      *    target  = A.B.C...
3320      *    target .= A.B.C...
3321      */
3322
3323     if (targetop) {
3324         assert(!targmyop);
3325
3326         if (o->op_type == OP_SASSIGN) {
3327             /* Move the target subtree from being the last of o's children
3328              * to being the last of o's preserved children.
3329              * Note the difference between 'target = ...' and 'target .= ...':
3330              * for the former, target is executed last; for the latter,
3331              * first.
3332              */
3333             kid = OpSIBLING(lastkidop);
3334             op_sibling_splice(o, kid, 1, NULL); /* cut target op */
3335             op_sibling_splice(o, lastkidop, 0, targetop); /* and paste */
3336             lastkidop->op_next = kid->op_next;
3337             lastkidop = targetop;
3338         }
3339         else {
3340             /* Move the target subtree from being the first of o's
3341              * original children to being the first of *all* o's children.
3342              */
3343             if (lastkidop) {
3344                 op_sibling_splice(o, lastkidop, 1, NULL); /* cut target op */
3345                 op_sibling_splice(o, NULL, 0, targetop);  /* and paste*/
3346             }
3347             else {
3348                 /* if the RHS of .= doesn't contain a concat (e.g.
3349                  * $x .= "foo"), it gets missed by the "strip ops from the
3350                  * tree and add to o" loop earlier */
3351                 assert(topop->op_type != OP_CONCAT);
3352                 if (stringop) {
3353                     /* in e.g. $x .= "$y", move the $y expression
3354                      * from being a child of OP_STRINGIFY to being the
3355                      * second child of the OP_CONCAT
3356                      */
3357                     assert(cUNOPx(stringop)->op_first == topop);
3358                     op_sibling_splice(stringop, NULL, 1, NULL);
3359                     op_sibling_splice(o, cUNOPo->op_first, 0, topop);
3360                 }
3361                 assert(topop == OpSIBLING(cBINOPo->op_first));
3362                 if (toparg->p)
3363                     op_null(topop);
3364                 lastkidop = topop;
3365             }
3366         }
3367
3368         if (is_targable) {
3369             /* optimise
3370              *  my $lex  = A.B.C...
3371              *     $lex  = A.B.C...
3372              *     $lex .= A.B.C...
3373              * The original padsv op is kept but nulled in case it's the
3374              * entry point for the optree (which it will be for
3375              * '$lex .=  ... '
3376              */
3377             private_flags |= OPpTARGET_MY;
3378             private_flags |= (targetop->op_private & OPpLVAL_INTRO);
3379             o->op_targ = targetop->op_targ;
3380             targetop->op_targ = 0;
3381             op_null(targetop);
3382         }
3383         else
3384             flags |= OPf_STACKED;
3385     }
3386     else if (targmyop) {
3387         private_flags |= OPpTARGET_MY;
3388         if (o != targmyop) {
3389             o->op_targ = targmyop->op_targ;
3390             targmyop->op_targ = 0;
3391         }
3392     }
3393
3394     /* detach the emaciated husk of the sprintf/concat optree and free it */
3395     for (;;) {
3396         kid = op_sibling_splice(o, lastkidop, 1, NULL);
3397         if (!kid)
3398             break;
3399         op_free(kid);
3400     }
3401
3402     /* and convert o into a multiconcat */
3403
3404     o->op_flags        = (flags|OPf_KIDS|stacked_last
3405                          |(o->op_flags & (OPf_WANT|OPf_PARENS)));
3406     o->op_private      = private_flags;
3407     o->op_type         = OP_MULTICONCAT;
3408     o->op_ppaddr       = PL_ppaddr[OP_MULTICONCAT];
3409     cUNOP_AUXo->op_aux = aux;
3410 }
3411
3412
3413 /* do all the final processing on an optree (e.g. running the peephole
3414  * optimiser on it), then attach it to cv (if cv is non-null)
3415  */
3416
3417 static void
3418 S_process_optree(pTHX_ CV *cv, OP *optree, OP* start)
3419 {
3420     OP **startp;
3421
3422     /* XXX for some reason, evals, require and main optrees are
3423      * never attached to their CV; instead they just hang off
3424      * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start
3425      * and get manually freed when appropriate */
3426     if (cv)
3427         startp = &CvSTART(cv);
3428     else
3429         startp = PL_in_eval? &PL_eval_start : &PL_main_start;
3430
3431     *startp = start;
3432     optree->op_private |= OPpREFCOUNTED;
3433     OpREFCNT_set(optree, 1);
3434     optimize_optree(optree);
3435     CALL_PEEP(*startp);
3436     finalize_optree(optree);
3437     S_prune_chain_head(startp);
3438
3439     if (cv) {
3440         /* now that optimizer has done its work, adjust pad values */
3441         pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT
3442                  : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
3443     }
3444 }
3445
3446
3447 /*
3448 =for apidoc optimize_optree
3449
3450 This function applies some optimisations to the optree in top-down order.
3451 It is called before the peephole optimizer, which processes ops in
3452 execution order. Note that finalize_optree() also does a top-down scan,
3453 but is called *after* the peephole optimizer.
3454
3455 =cut
3456 */
3457
3458 void
3459 Perl_optimize_optree(pTHX_ OP* o)
3460 {
3461     PERL_ARGS_ASSERT_OPTIMIZE_OPTREE;
3462
3463     ENTER;
3464     SAVEVPTR(PL_curcop);
3465
3466     optimize_op(o);
3467
3468     LEAVE;
3469 }
3470
3471
3472 /* helper for optimize_optree() which optimises on op then recurses
3473  * to optimise any children.
3474  */
3475
3476 STATIC void
3477 S_optimize_op(pTHX_ OP* o)
3478 {
3479     dDEFER_OP;
3480
3481     PERL_ARGS_ASSERT_OPTIMIZE_OP;
3482     do {
3483         assert(o->op_type != OP_FREED);
3484
3485         switch (o->op_type) {
3486         case OP_NEXTSTATE:
3487         case OP_DBSTATE:
3488             PL_curcop = ((COP*)o);              /* for warnings */
3489             break;
3490
3491
3492         case OP_CONCAT:
3493         case OP_SASSIGN:
3494         case OP_STRINGIFY:
3495         case OP_SPRINTF:
3496             S_maybe_multiconcat(aTHX_ o);
3497             break;
3498
3499         case OP_SUBST:
3500             if (cPMOPo->op_pmreplrootu.op_pmreplroot)
3501                 DEFER_OP(cPMOPo->op_pmreplrootu.op_pmreplroot);
3502             break;
3503
3504         default:
3505             break;
3506         }
3507
3508         if (o->op_flags & OPf_KIDS) {
3509             OP *kid;
3510             IV child_count = 0;
3511             for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
3512                 DEFER_OP(kid);
3513                 ++child_count;
3514             }
3515             DEFER_REVERSE(child_count);
3516         }
3517     } while ( ( o = POP_DEFERRED_OP() ) );
3518
3519     DEFER_OP_CLEANUP;
3520 }
3521
3522
3523 /*
3524 =for apidoc finalize_optree
3525
3526 This function finalizes the optree.  Should be called directly after
3527 the complete optree is built.  It does some additional
3528 checking which can't be done in the normal C<ck_>xxx functions and makes
3529 the tree thread-safe.
3530
3531 =cut
3532 */
3533 void
3534 Perl_finalize_optree(pTHX_ OP* o)
3535 {
3536     PERL_ARGS_ASSERT_FINALIZE_OPTREE;
3537
3538     ENTER;
3539     SAVEVPTR(PL_curcop);
3540
3541     finalize_op(o);
3542
3543     LEAVE;
3544 }
3545
3546 #ifdef USE_ITHREADS
3547 /* Relocate sv to the pad for thread safety.
3548  * Despite being a "constant", the SV is written to,
3549  * for reference counts, sv_upgrade() etc. */
3550 PERL_STATIC_INLINE void
3551 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
3552 {
3553     PADOFFSET ix;
3554     PERL_ARGS_ASSERT_OP_RELOCATE_SV;
3555     if (!*svp) return;
3556     ix = pad_alloc(OP_CONST, SVf_READONLY);
3557     SvREFCNT_dec(PAD_SVl(ix));
3558     PAD_SETSV(ix, *svp);
3559     /* XXX I don't know how this isn't readonly already. */
3560     if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
3561     *svp = NULL;
3562     *targp = ix;
3563 }
3564 #endif
3565
3566 /*
3567 =for apidoc s|OP*|traverse_op_tree|OP* top|OP* o
3568
3569 Return the next op in a depth-first traversal of the op tree,
3570 returning NULL when the traversal is complete.
3571
3572 The initial call must supply the root of the tree as both top and o.
3573
3574 For now it's static, but it may be exposed to the API in the future.
3575
3576 =cut
3577 */
3578
3579 STATIC OP*
3580 S_traverse_op_tree(pTHX_ OP *top, OP *o) {
3581     OP *sib;
3582
3583     PERL_ARGS_ASSERT_TRAVERSE_OP_TREE;
3584
3585     if ((o->op_flags & OPf_KIDS) && cUNOPo->op_first) {
3586         return cUNOPo->op_first;
3587     }
3588     else if ((sib = OpSIBLING(o))) {
3589         return sib;
3590     }
3591     else {
3592         OP *parent = o->op_sibparent;
3593         assert(!(o->op_moresib));
3594         while (parent && parent != top) {
3595             OP *sib = OpSIBLING(parent);
3596             if (sib)
3597                 return sib;
3598             parent = parent->op_sibparent;
3599         }
3600
3601         return NULL;
3602     }
3603 }
3604
3605 STATIC void
3606 S_finalize_op(pTHX_ OP* o)
3607 {
3608     OP * const top = o;
3609     PERL_ARGS_ASSERT_FINALIZE_OP;
3610
3611     do {
3612         assert(o->op_type != OP_FREED);
3613
3614         switch (o->op_type) {
3615         case OP_NEXTSTATE:
3616         case OP_DBSTATE:
3617             PL_curcop = ((COP*)o);              /* for warnings */
3618             break;
3619         case OP_EXEC:
3620             if (OpHAS_SIBLING(o)) {
3621                 OP *sib = OpSIBLING(o);
3622                 if ((  sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
3623                     && ckWARN(WARN_EXEC)
3624                     && OpHAS_SIBLING(sib))
3625                 {
3626                     const OPCODE type = OpSIBLING(sib)->op_type;
3627                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
3628                         const line_t oldline = CopLINE(PL_curcop);
3629                         CopLINE_set(PL_curcop, CopLINE((COP*)sib));
3630                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
3631                             "Statement unlikely to be reached");
3632                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
3633                             "\t(Maybe you meant system() when you said exec()?)\n");
3634                         CopLINE_set(PL_curcop, oldline);
3635                     }
3636                 }
3637             }
3638             break;
3639
3640         case OP_GV:
3641             if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
3642                 GV * const gv = cGVOPo_gv;
3643                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
3644                     /* XXX could check prototype here instead of just carping */
3645                     SV * const sv = sv_newmortal();
3646                     gv_efullname3(sv, gv, NULL);
3647                     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3648                                 "%" SVf "() called too early to check prototype",
3649                                 SVfARG(sv));
3650                 }
3651             }
3652             break;
3653
3654         case OP_CONST:
3655             if (cSVOPo->op_private & OPpCONST_STRICT)
3656                 no_bareword_allowed(o);
3657 #ifdef USE_ITHREADS
3658             /* FALLTHROUGH */
3659         case OP_HINTSEVAL:
3660             op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
3661 #endif
3662             break;
3663
3664 #ifdef USE_ITHREADS
3665             /* Relocate all the METHOP's SVs to the pad for thread safety. */
3666         case OP_METHOD_NAMED:
3667         case OP_METHOD_SUPER:
3668         case OP_METHOD_REDIR:
3669         case OP_METHOD_REDIR_SUPER:
3670             op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
3671             break;
3672 #endif
3673
3674         case OP_HELEM: {
3675             UNOP *rop;
3676             SVOP *key_op;
3677             OP *kid;
3678
3679             if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
3680                 break;
3681
3682             rop = (UNOP*)((BINOP*)o)->op_first;
3683
3684             goto check_keys;
3685
3686             case OP_HSLICE:
3687                 S_scalar_slice_warning(aTHX_ o);
3688                 /* FALLTHROUGH */
3689
3690             case OP_KVHSLICE:
3691                 kid = OpSIBLING(cLISTOPo->op_first);
3692             if (/* I bet there's always a pushmark... */
3693                 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
3694                 && OP_TYPE_ISNT_NN(kid, OP_CONST))
3695             {
3696                 break;
3697             }
3698
3699             key_op = (SVOP*)(kid->op_type == OP_CONST
3700                              ? kid
3701                              : OpSIBLING(kLISTOP->op_first));
3702
3703             rop = (UNOP*)((LISTOP*)o)->op_last;
3704
3705         check_keys:
3706             if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
3707                 rop = NULL;
3708             S_check_hash_fields_and_hekify(aTHX_ rop, key_op);
3709             break;
3710         }
3711         case OP_NULL:
3712             if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE)
3713                 break;
3714             /* FALLTHROUGH */
3715         case OP_ASLICE:
3716             S_scalar_slice_warning(aTHX_ o);
3717             break;
3718
3719         case OP_SUBST: {
3720             if (cPMOPo->op_pmreplrootu.op_pmreplroot)
3721                 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3722             break;
3723         }
3724         default:
3725             break;
3726         }
3727
3728 #ifdef DEBUGGING
3729         if (o->op_flags & OPf_KIDS) {
3730             OP *kid;
3731
3732             /* check that op_last points to the last sibling, and that
3733              * the last op_sibling/op_sibparent field points back to the
3734              * parent, and that the only ops with KIDS are those which are
3735              * entitled to them */
3736             U32 type = o->op_type;
3737             U32 family;
3738             bool has_last;
3739
3740             if (type == OP_NULL) {
3741                 type = o->op_targ;
3742                 /* ck_glob creates a null UNOP with ex-type GLOB
3743                  * (which is a list op. So pretend it wasn't a listop */
3744                 if (type == OP_GLOB)
3745                     type = OP_NULL;
3746             }
3747             family = PL_opargs[type] & OA_CLASS_MASK;
3748
3749             has_last = (   family == OA_BINOP
3750                         || family == OA_LISTOP
3751                         || family == OA_PMOP
3752                         || family == OA_LOOP
3753                        );
3754             assert(  has_last /* has op_first and op_last, or ...
3755                   ... has (or may have) op_first: */
3756                   || family == OA_UNOP
3757                   || family == OA_UNOP_AUX
3758                   || family == OA_LOGOP
3759                   || family == OA_BASEOP_OR_UNOP
3760                   || family == OA_FILESTATOP
3761                   || family == OA_LOOPEXOP
3762                   || family == OA_METHOP
3763                   || type == OP_CUSTOM
3764                   || type == OP_NULL /* new_logop does this */
3765                   );
3766
3767             for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
3768                 if (!OpHAS_SIBLING(kid)) {
3769                     if (has_last)
3770                         assert(kid == cLISTOPo->op_last);
3771                     assert(kid->op_sibparent == o);
3772                 }
3773             }
3774         }
3775 #endif
3776     } while (( o = traverse_op_tree(top, o)) != NULL);
3777 }
3778
3779 /*
3780 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
3781
3782 Propagate lvalue ("modifiable") context to an op and its children.
3783 C<type> represents the context type, roughly based on the type of op that
3784 would do the modifying, although C<local()> is represented by C<OP_NULL>,
3785 because it has no op type of its own (it is signalled by a flag on
3786 the lvalue op).
3787
3788 This function detects things that can't be modified, such as C<$x+1>, and
3789 generates errors for them.  For example, C<$x+1 = 2> would cause it to be
3790 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
3791
3792 It also flags things that need to behave specially in an lvalue context,
3793 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
3794
3795 =cut
3796 */
3797
3798 static void
3799 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
3800 {
3801     CV *cv = PL_compcv;
3802     PadnameLVALUE_on(pn);
3803     while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
3804         cv = CvOUTSIDE(cv);
3805         /* RT #127786: cv can be NULL due to an eval within the DB package
3806          * called from an anon sub - anon subs don't have CvOUTSIDE() set
3807          * unless they contain an eval, but calling eval within DB
3808          * pretends the eval was done in the caller's scope.
3809          */
3810         if (!cv)
3811             break;
3812         assert(CvPADLIST(cv));
3813         pn =
3814            PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
3815         assert(PadnameLEN(pn));
3816         PadnameLVALUE_on(pn);
3817     }
3818 }
3819
3820 static bool
3821 S_vivifies(const OPCODE type)
3822 {
3823     switch(type) {
3824     case OP_RV2AV:     case   OP_ASLICE:
3825     case OP_RV2HV:     case OP_KVASLICE:
3826     case OP_RV2SV:     case   OP_HSLICE:
3827     case OP_AELEMFAST: case OP_KVHSLICE:
3828     case OP_HELEM:
3829     case OP_AELEM:
3830         return 1;
3831     }
3832     return 0;
3833 }
3834
3835 static void
3836 S_lvref(pTHX_ OP *o, I32 type)
3837 {
3838     dVAR;
3839     OP *kid;
3840     switch (o->op_type) {
3841     case OP_COND_EXPR:
3842         for (kid = OpSIBLING(cUNOPo->op_first); kid;
3843              kid = OpSIBLING(kid))
3844             S_lvref(aTHX_ kid, type);
3845         /* FALLTHROUGH */
3846     case OP_PUSHMARK:
3847         return;
3848     case OP_RV2AV:
3849         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
3850         o->op_flags |= OPf_STACKED;
3851         if (o->op_flags & OPf_PARENS) {
3852             if (o->op_private & OPpLVAL_INTRO) {
3853                  yyerror(Perl_form(aTHX_ "Can't modify reference to "
3854                       "localized parenthesized array in list assignment"));
3855                 return;
3856             }
3857           slurpy:
3858             OpTYPE_set(o, OP_LVAVREF);
3859             o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
3860             o->op_flags |= OPf_MOD|OPf_REF;
3861             return;
3862         }
3863         o->op_private |= OPpLVREF_AV;
3864         goto checkgv;
3865     case OP_RV2CV:
3866         kid = cUNOPo->op_first;
3867         if (kid->op_type == OP_NULL)
3868             kid = cUNOPx(OpSIBLING(kUNOP->op_first))
3869                 ->op_first;
3870         o->op_private = OPpLVREF_CV;
3871         if (kid->op_type == OP_GV)
3872             o->op_flags |= OPf_STACKED;
3873         else if (kid->op_type == OP_PADCV) {
3874             o->op_targ = kid->op_targ;
3875             kid->op_targ = 0;
3876             op_free(cUNOPo->op_first);
3877             cUNOPo->op_first = NULL;
3878             o->op_flags &=~ OPf_KIDS;
3879         }
3880         else goto badref;
3881         break;
3882     case OP_RV2HV:
3883         if (o->op_flags & OPf_PARENS) {
3884           parenhash:
3885             yyerror(Perl_form(aTHX_ "Can't modify reference to "
3886                                  "parenthesized hash in list assignment"));
3887                 return;
3888         }
3889         o->op_private |= OPpLVREF_HV;
3890         /* FALLTHROUGH */
3891     case OP_RV2SV:
3892       checkgv:
3893         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
3894         o->op_flags |= OPf_STACKED;
3895         break;
3896     case OP_PADHV:
3897         if (o->op_flags & OPf_PARENS) goto parenhash;
3898         o->op_private |= OPpLVREF_HV;
3899         /* FALLTHROUGH */
3900     case OP_PADSV:
3901         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
3902         break;
3903     case OP_PADAV:
3904         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
3905         if (o->op_flags & OPf_PARENS) goto slurpy;
3906         o->op_private |= OPpLVREF_AV;
3907         break;
3908     case OP_AELEM:
3909     case OP_HELEM:
3910         o->op_private |= OPpLVREF_ELEM;
3911         o->op_flags   |= OPf_STACKED;
3912         break;
3913     case OP_ASLICE:
3914     case OP_HSLICE:
3915         OpTYPE_set(o, OP_LVREFSLICE);
3916         o->op_private &= OPpLVAL_INTRO;
3917         return;
3918     case OP_NULL:
3919         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
3920             goto badref;
3921         else if (!(o->op_flags & OPf_KIDS))
3922             return;
3923         if (o->op_targ != OP_LIST) {
3924             S_lvref(aTHX_ cBINOPo->op_first, type);
3925             return;
3926         }
3927         /* FALLTHROUGH */
3928     case OP_LIST:
3929         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
3930             assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
3931             S_lvref(aTHX_ kid, type);
3932         }
3933         return;
3934     case OP_STUB:
3935         if (o->op_flags & OPf_PARENS)
3936             return;
3937         /* FALLTHROUGH */
3938     default:
3939       badref:
3940         /* diag_listed_as: Can't modify reference to %s in %s assignment */
3941         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
3942                      o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
3943                       ? "do block"
3944                       : OP_DESC(o),
3945                      PL_op_desc[type]));
3946         return;
3947     }
3948     OpTYPE_set(o, OP_LVREF);
3949     o->op_private &=
3950         OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
3951     if (type == OP_ENTERLOOP)
3952         o->op_private |= OPpLVREF_ITER;
3953 }
3954
3955 PERL_STATIC_INLINE bool
3956 S_potential_mod_type(I32 type)
3957 {
3958     /* Types that only potentially result in modification.  */
3959     return type == OP_GREPSTART || type == OP_ENTERSUB
3960         || type == OP_REFGEN    || type == OP_LEAVESUBLV;
3961 }
3962
3963 OP *
3964 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
3965 {
3966     dVAR;
3967     OP *kid;
3968     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
3969     int localize = -1;
3970
3971     if (!o || (PL_parser && PL_parser->error_count))
3972         return o;
3973
3974     if ((o->op_private & OPpTARGET_MY)
3975         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
3976     {
3977         return o;
3978     }
3979
3980     assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
3981
3982     if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
3983
3984     switch (o->op_type) {
3985     case OP_UNDEF:
3986         PL_modcount++;
3987         return o;
3988     case OP_STUB:
3989         if ((o->op_flags & OPf_PARENS))
3990             break;
3991         goto nomod;
3992     case OP_ENTERSUB:
3993         if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
3994             !(o->op_flags & OPf_STACKED)) {
3995             OpTYPE_set(o, OP_RV2CV);            /* entersub => rv2cv */
3996             assert(cUNOPo->op_first->op_type == OP_NULL);
3997             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
3998             break;
3999         }
4000         else {                          /* lvalue subroutine call */
4001             o->op_private |= OPpLVAL_INTRO;
4002             PL_modcount = RETURN_UNLIMITED_NUMBER;
4003             if (S_potential_mod_type(type)) {
4004                 o->op_private |= OPpENTERSUB_INARGS;
4005                 break;
4006             }
4007             else {                      /* Compile-time error message: */
4008                 OP *kid = cUNOPo->op_first;
4009                 CV *cv;
4010                 GV *gv;
4011                 SV *namesv;
4012
4013                 if (kid->op_type != OP_PUSHMARK) {
4014                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
4015                         Perl_croak(aTHX_
4016                                 "panic: unexpected lvalue entersub "
4017                                 "args: type/targ %ld:%" UVuf,
4018                                 (long)kid->op_type, (UV)kid->op_targ);
4019                     kid = kLISTOP->op_first;
4020                 }
4021                 while (OpHAS_SIBLING(kid))
4022                     kid = OpSIBLING(kid);
4023                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
4024                     break;      /* Postpone until runtime */
4025                 }
4026
4027                 kid = kUNOP->op_first;
4028                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
4029                     kid = kUNOP->op_first;
4030                 if (kid->op_type == OP_NULL)
4031                     Perl_croak(aTHX_
4032                                "Unexpected constant lvalue entersub "
4033                                "entry via type/targ %ld:%" UVuf,
4034                                (long)kid->op_type, (UV)kid->op_targ);
4035                 if (kid->op_type != OP_GV) {
4036                     break;
4037                 }
4038
4039                 gv = kGVOP_gv;
4040                 cv = isGV(gv)
4041                     ? GvCV(gv)
4042                     : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
4043                         ? MUTABLE_CV(SvRV(gv))
4044                         : NULL;
4045                 if (!cv)
4046                     break;
4047                 if (CvLVALUE(cv))
4048                     break;
4049                 if (flags & OP_LVALUE_NO_CROAK)
4050                     return NULL;
4051
4052                 namesv = cv_name(cv, NULL, 0);
4053                 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
4054                                      "subroutine call of &%" SVf " in %s",
4055                                      SVfARG(namesv), PL_op_desc[type]),
4056                            SvUTF8(namesv));
4057                 return o;
4058             }
4059         }
4060         /* FALLTHROUGH */
4061     default:
4062       nomod:
4063         if (flags & OP_LVALUE_NO_CROAK) return NULL;
4064         /* grep, foreach, subcalls, refgen */
4065         if (S_potential_mod_type(type))
4066             break;
4067         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
4068                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
4069                       ? "do block"
4070                       : OP_DESC(o)),
4071                      type ? PL_op_desc[type] : "local"));
4072         return o;
4073
4074     case OP_PREINC:
4075     case OP_PREDEC:
4076     case OP_POW:
4077     case OP_MULTIPLY:
4078     case OP_DIVIDE:
4079     case OP_MODULO:
4080     case OP_ADD:
4081     case OP_SUBTRACT:
4082     case OP_CONCAT:
4083     case OP_LEFT_SHIFT:
4084     case OP_RIGHT_SHIFT:
4085     case OP_BIT_AND:
4086     case OP_BIT_XOR:
4087     case OP_BIT_OR:
4088     case OP_I_MULTIPLY:
4089     case OP_I_DIVIDE:
4090     case OP_I_MODULO:
4091     case OP_I_ADD:
4092     case OP_I_SUBTRACT:
4093         if (!(o->op_flags & OPf_STACKED))
4094             goto nomod;
4095         PL_modcount++;
4096         break;
4097
4098     case OP_REPEAT:
4099         if (o->op_flags & OPf_STACKED) {
4100             PL_modcount++;
4101             break;
4102         }
4103         if (!(o->op_private & OPpREPEAT_DOLIST))
4104             goto nomod;
4105         else {
4106             const I32 mods = PL_modcount;
4107             modkids(cBINOPo->op_first, type);
4108             if (type != OP_AASSIGN)
4109                 goto nomod;
4110             kid = cBINOPo->op_last;
4111             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
4112                 const IV iv = SvIV(kSVOP_sv);
4113                 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
4114                     PL_modcount =
4115                         mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
4116             }
4117             else
4118                 PL_modcount = RETURN_UNLIMITED_NUMBER;
4119         }
4120         break;
4121
4122     case OP_COND_EXPR:
4123         localize = 1;
4124         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
4125             op_lvalue(kid, type);
4126         break;
4127
4128     case OP_RV2AV:
4129     case OP_RV2HV:
4130         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
4131            PL_modcount = RETURN_UNLIMITED_NUMBER;
4132            /* Treat \(@foo) like ordinary list, but still mark it as modi-
4133               fiable since some contexts need to know.  */
4134            o->op_flags |= OPf_MOD;
4135            return o;
4136         }
4137         /* FALLTHROUGH */
4138     case OP_RV2GV:
4139         if (scalar_mod_type(o, type))
4140             goto nomod;
4141         ref(cUNOPo->op_first, o->op_type);
4142         /* FALLTHROUGH */
4143     case OP_ASLICE:
4144     case OP_HSLICE:
4145         localize = 1;
4146         /* FALLTHROUGH */
4147     case OP_AASSIGN:
4148         /* Do not apply the lvsub flag for rv2[ah]v in scalar context.  */
4149         if (type == OP_LEAVESUBLV && (
4150                 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
4151              || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4152            ))
4153             o->op_private |= OPpMAYBE_LVSUB;
4154         /* FALLTHROUGH */
4155     case OP_NEXTSTATE:
4156     case OP_DBSTATE:
4157        PL_modcount = RETURN_UNLIMITED_NUMBER;
4158         break;
4159     case OP_KVHSLICE:
4160     case OP_KVASLICE:
4161     case OP_AKEYS:
4162         if (type == OP_LEAVESUBLV)
4163             o->op_private |= OPpMAYBE_LVSUB;
4164         goto nomod;
4165     case OP_AVHVSWITCH:
4166         if (type == OP_LEAVESUBLV
4167          && (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS)
4168             o->op_private |= OPpMAYBE_LVSUB;
4169         goto nomod;
4170     case OP_AV2ARYLEN:
4171         PL_hints |= HINT_BLOCK_SCOPE;
4172         if (type == OP_LEAVESUBLV)
4173             o->op_private |= OPpMAYBE_LVSUB;
4174         PL_modcount++;
4175         break;
4176     case OP_RV2SV:
4177         ref(cUNOPo->op_first, o->op_type);
4178         localize = 1;
4179         /* FALLTHROUGH */
4180     case OP_GV:
4181         PL_hints |= HINT_BLOCK_SCOPE;
4182         /* FALLTHROUGH */
4183     case OP_SASSIGN:
4184     case OP_ANDASSIGN:
4185     case OP_ORASSIGN:
4186     case OP_DORASSIGN:
4187         PL_modcount++;
4188         break;
4189
4190     case OP_AELEMFAST:
4191     case OP_AELEMFAST_LEX:
4192         localize = -1;
4193         PL_modcount++;
4194         break;
4195
4196     case OP_PADAV:
4197     case OP_PADHV:
4198        PL_modcount = RETURN_UNLIMITED_NUMBER;
4199         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
4200         {
4201            /* Treat \(@foo) like ordinary list, but still mark it as modi-
4202               fiable since some contexts need to know.  */
4203             o->op_flags |= OPf_MOD;
4204             return o;
4205         }
4206         if (scalar_mod_type(o, type))
4207             goto nomod;
4208         if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4209           && type == OP_LEAVESUBLV)
4210             o->op_private |= OPpMAYBE_LVSUB;
4211         /* FALLTHROUGH */
4212     case OP_PADSV:
4213         PL_modcount++;
4214         if (!type) /* local() */
4215             Perl_croak(aTHX_ "Can't localize lexical variable %" PNf,
4216                               PNfARG(PAD_COMPNAME(o->op_targ)));
4217         if (!(o->op_private & OPpLVAL_INTRO)
4218          || (  type != OP_SASSIGN && type != OP_AASSIGN
4219             && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ))  ))
4220             S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
4221         break;
4222
4223     case OP_PUSHMARK:
4224         localize = 0;
4225         break;
4226
4227     case OP_KEYS:
4228         if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
4229             goto nomod;
4230         goto lvalue_func;
4231     case OP_SUBSTR:
4232         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
4233             goto nomod;
4234         /* FALLTHROUGH */
4235     case OP_POS:
4236     case OP_VEC:
4237       lvalue_func:
4238         if (type == OP_LEAVESUBLV)
4239             o->op_private |= OPpMAYBE_LVSUB;
4240         if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
4241             /* substr and vec */
4242             /* If this op is in merely potential (non-fatal) modifiable
4243                context, then apply OP_ENTERSUB context to
4244                the kid op (to avoid croaking).  Other-
4245                wise pass this op’s own type so the correct op is mentioned
4246                in error messages.  */
4247             op_lvalue(OpSIBLING(cBINOPo->op_first),
4248                       S_potential_mod_type(type)
4249                         ? (I32)OP_ENTERSUB
4250                         : o->op_type);
4251         }
4252         break;
4253
4254     case OP_AELEM:
4255     case OP_HELEM:
4256         ref(cBINOPo->op_first, o->op_type);
4257         if (type == OP_ENTERSUB &&
4258              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
4259             o->op_private |= OPpLVAL_DEFER;
4260         if (type == OP_LEAVESUBLV)
4261             o->op_private |= OPpMAYBE_LVSUB;
4262         localize = 1;
4263         PL_modcount++;
4264         break;
4265
4266     case OP_LEAVE:
4267     case OP_LEAVELOOP:
4268         o->op_private |= OPpLVALUE;
4269         /* FALLTHROUGH */
4270     case OP_SCOPE:
4271     case OP_ENTER:
4272     case OP_LINESEQ:
4273         localize = 0;
4274         if (o->op_flags & OPf_KIDS)
4275             op_lvalue(cLISTOPo->op_last, type);
4276         break;
4277
4278     case OP_NULL:
4279         localize = 0;
4280         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
4281             goto nomod;
4282         else if (!(o->op_flags & OPf_KIDS))
4283             break;
4284
4285         if (o->op_targ != OP_LIST) {
4286             OP *sib = OpSIBLING(cLISTOPo->op_first);
4287             /* OP_TRANS and OP_TRANSR with argument have a weird optree
4288              * that looks like
4289              *
4290              *   null
4291              *      arg
4292              *      trans
4293              *
4294              * compared with things like OP_MATCH which have the argument
4295              * as a child:
4296              *
4297              *   match
4298              *      arg
4299              *
4300              * so handle specially to correctly get "Can't modify" croaks etc
4301              */
4302
4303             if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR))
4304             {
4305                 /* this should trigger a "Can't modify transliteration" err */
4306                 op_lvalue(sib, type);
4307             }
4308             op_lvalue(cBINOPo->op_first, type);
4309             break;
4310         }
4311         /* FALLTHROUGH */
4312     case OP_LIST:
4313         localize = 0;
4314         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4315             /* elements might be in void context because the list is
4316                in scalar context or because they are attribute sub calls */
4317             if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
4318                 op_lvalue(kid, type);
4319         break;
4320
4321     case OP_COREARGS:
4322         return o;
4323
4324     case OP_AND:
4325     case OP_OR:
4326         if (type == OP_LEAVESUBLV
4327          || !S_vivifies(cLOGOPo->op_first->op_type))
4328             op_lvalue(cLOGOPo->op_first, type);
4329         if (type == OP_LEAVESUBLV
4330          || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
4331             op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
4332         goto nomod;
4333
4334     case OP_SREFGEN:
4335         if (type == OP_NULL) { /* local */
4336           local_refgen:
4337             if (!FEATURE_MYREF_IS_ENABLED)
4338                 Perl_croak(aTHX_ "The experimental declared_refs "
4339                                  "feature is not enabled");
4340             Perl_ck_warner_d(aTHX_
4341                      packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4342                     "Declaring references is experimental");
4343             op_lvalue(cUNOPo->op_first, OP_NULL);
4344             return o;
4345         }
4346         if (type != OP_AASSIGN && type != OP_SASSIGN
4347          && type != OP_ENTERLOOP)
4348             goto nomod;
4349         /* Don’t bother applying lvalue context to the ex-list.  */
4350         kid = cUNOPx(cUNOPo->op_first)->op_first;
4351         assert (!OpHAS_SIBLING(kid));
4352         goto kid_2lvref;
4353     case OP_REFGEN:
4354         if (type == OP_NULL) /* local */
4355             goto local_refgen;
4356         if (type != OP_AASSIGN) goto nomod;
4357         kid = cUNOPo->op_first;
4358       kid_2lvref:
4359         {
4360             const U8 ec = PL_parser ? PL_parser->error_count : 0;
4361             S_lvref(aTHX_ kid, type);
4362             if (!PL_parser || PL_parser->error_count == ec) {
4363                 if (!FEATURE_REFALIASING_IS_ENABLED)
4364                     Perl_croak(aTHX_
4365                        "Experimental aliasing via reference not enabled");
4366                 Perl_ck_warner_d(aTHX_
4367                                  packWARN(WARN_EXPERIMENTAL__REFALIASING),
4368                                 "Aliasing via reference is experimental");
4369             }
4370         }
4371         if (o->op_type == OP_REFGEN)
4372             op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
4373         op_null(o);
4374         return o;
4375
4376     case OP_SPLIT:
4377         if ((o->op_private & OPpSPLIT_ASSIGN)) {
4378             /* This is actually @array = split.  */
4379             PL_modcount = RETURN_UNLIMITED_NUMBER;
4380             break;
4381         }
4382         goto nomod;
4383
4384     case OP_SCALAR:
4385         op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
4386         goto nomod;
4387     }
4388
4389     /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
4390        their argument is a filehandle; thus \stat(".") should not set
4391        it. AMS 20011102 */
4392     if (type == OP_REFGEN &&
4393         PL_check[o->op_type] == Perl_ck_ftst)
4394         return o;
4395
4396     if (type != OP_LEAVESUBLV)
4397         o->op_flags |= OPf_MOD;
4398
4399     if (type == OP_AASSIGN || type == OP_SASSIGN)
4400         o->op_flags |= OPf_SPECIAL
4401                       |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF);
4402     else if (!type) { /* local() */
4403         switch (localize) {
4404         case 1:
4405             o->op_private |= OPpLVAL_INTRO;
4406             o->op_flags &= ~OPf_SPECIAL;
4407             PL_hints |= HINT_BLOCK_SCOPE;
4408             break;
4409         case 0:
4410             break;
4411         case -1:
4412             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
4413                            "Useless localization of %s", OP_DESC(o));
4414         }
4415     }
4416     else if (type != OP_GREPSTART && type != OP_ENTERSUB
4417              && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
4418         o->op_flags |= OPf_REF;
4419     return o;
4420 }
4421
4422 STATIC bool
4423 S_scalar_mod_type(const OP *o, I32 type)
4424 {
4425     switch (type) {
4426     case OP_POS:
4427     case OP_SASSIGN:
4428         if (o && o->op_type == OP_RV2GV)
4429             return FALSE;
4430         /* FALLTHROUGH */
4431     case OP_PREINC:
4432     case OP_PREDEC:
4433     case OP_POSTINC:
4434     case OP_POSTDEC:
4435     case OP_I_PREINC:
4436     case OP_I_PREDEC:
4437     case OP_I_POSTINC:
4438     case OP_I_POSTDEC:
4439     case OP_POW:
4440     case OP_MULTIPLY:
4441     case OP_DIVIDE:
4442     case OP_MODULO:
4443     case OP_REPEAT:
4444     case OP_ADD:
4445     case OP_SUBTRACT:
4446     case OP_I_MULTIPLY:
4447     case OP_I_DIVIDE:
4448     case OP_I_MODULO:
4449     case OP_I_ADD:
4450     case OP_I_SUBTRACT:
4451     case OP_LEFT_SHIFT:
4452     case OP_RIGHT_SHIFT:
4453     case OP_BIT_AND:
4454     case OP_BIT_XOR:
4455     case OP_BIT_OR:
4456     case OP_NBIT_AND:
4457     case OP_NBIT_XOR:
4458     case OP_NBIT_OR:
4459     case OP_SBIT_AND:
4460     case OP_SBIT_XOR:
4461     case OP_SBIT_OR:
4462     case OP_CONCAT:
4463     case OP_SUBST:
4464     case OP_TRANS:
4465     case OP_TRANSR:
4466     case OP_READ:
4467     case OP_SYSREAD:
4468     case OP_RECV:
4469     case OP_ANDASSIGN:
4470     case OP_ORASSIGN:
4471     case OP_DORASSIGN:
4472     case OP_VEC:
4473     case OP_SUBSTR:
4474         return TRUE;
4475     default:
4476         return FALSE;
4477     }
4478 }
4479
4480 STATIC bool
4481 S_is_handle_constructor(const OP *o, I32 numargs)
4482 {
4483     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
4484
4485     switch (o->op_type) {
4486     case OP_PIPE_OP:
4487     case OP_SOCKPAIR:
4488         if (numargs == 2)
4489             return TRUE;
4490         /* FALLTHROUGH */
4491     case OP_SYSOPEN:
4492     case OP_OPEN:
4493     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
4494     case OP_SOCKET:
4495     case OP_OPEN_DIR:
4496     case OP_ACCEPT:
4497         if (numargs == 1)
4498             return TRUE;
4499         /* FALLTHROUGH */
4500     default:
4501         return FALSE;
4502     }
4503 }
4504
4505 static OP *
4506 S_refkids(pTHX_ OP *o, I32 type)
4507 {
4508     if (o && o->op_flags & OPf_KIDS) {
4509         OP *kid;
4510         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4511             ref(kid, type);
4512     }
4513     return o;
4514 }
4515
4516 OP *
4517 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
4518 {
4519     dVAR;
4520     OP *kid;
4521
4522     PERL_ARGS_ASSERT_DOREF;
4523
4524     if (PL_parser && PL_parser->error_count)
4525         return o;
4526
4527     switch (o->op_type) {
4528     case OP_ENTERSUB:
4529         if ((type == OP_EXISTS || type == OP_DEFINED) &&
4530             !(o->op_flags & OPf_STACKED)) {
4531             OpTYPE_set(o, OP_RV2CV);             /* entersub => rv2cv */
4532             assert(cUNOPo->op_first->op_type == OP_NULL);
4533             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
4534             o->op_flags |= OPf_SPECIAL;
4535         }
4536         else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
4537             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4538                               : type == OP_RV2HV ? OPpDEREF_HV
4539                               : OPpDEREF_SV);
4540             o->op_flags |= OPf_MOD;
4541         }
4542
4543         break;
4544
4545     case OP_COND_EXPR:
4546         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
4547             doref(kid, type, set_op_ref);
4548         break;
4549     case OP_RV2SV:
4550         if (type == OP_DEFINED)
4551             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
4552         doref(cUNOPo->op_first, o->op_type, set_op_ref);
4553         /* FALLTHROUGH */
4554     case OP_PADSV:
4555         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4556             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4557                               : type == OP_RV2HV ? OPpDEREF_HV
4558                               : OPpDEREF_SV);
4559             o->op_flags |= OPf_MOD;
4560         }
4561         break;
4562
4563     case OP_RV2AV:
4564     case OP_RV2HV:
4565         if (set_op_ref)
4566             o->op_flags |= OPf_REF;
4567         /* FALLTHROUGH */
4568     case OP_RV2GV:
4569         if (type == OP_DEFINED)
4570             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
4571         doref(cUNOPo->op_first, o->op_type, set_op_ref);
4572         break;
4573
4574     case OP_PADAV:
4575     case OP_PADHV:
4576         if (set_op_ref)
4577             o->op_flags |= OPf_REF;
4578         break;
4579
4580     case OP_SCALAR:
4581     case OP_NULL:
4582         if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
4583             break;
4584         doref(cBINOPo->op_first, type, set_op_ref);
4585         break;
4586     case OP_AELEM:
4587     case OP_HELEM:
4588         doref(cBINOPo->op_first, o->op_type, set_op_ref);
4589         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4590             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4591                               : type == OP_RV2HV ? OPpDEREF_HV
4592                               : OPpDEREF_SV);
4593             o->op_flags |= OPf_MOD;
4594         }
4595         break;
4596
4597     case OP_SCOPE:
4598     case OP_LEAVE:
4599         set_op_ref = FALSE;
4600         /* FALLTHROUGH */
4601     case OP_ENTER:
4602     case OP_LIST:
4603         if (!(o->op_flags & OPf_KIDS))
4604             break;
4605         doref(cLISTOPo->op_last, type, set_op_ref);
4606         break;
4607     default:
4608         break;
4609     }
4610     return scalar(o);
4611
4612 }
4613
4614 STATIC OP *
4615 S_dup_attrlist(pTHX_ OP *o)
4616 {
4617     OP *rop;
4618
4619     PERL_ARGS_ASSERT_DUP_ATTRLIST;
4620
4621     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
4622      * where the first kid is OP_PUSHMARK and the remaining ones
4623      * are OP_CONST.  We need to push the OP_CONST values.
4624      */
4625     if (o->op_type == OP_CONST)
4626         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
4627     else {
4628         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
4629         rop = NULL;
4630         for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
4631             if (o->op_type == OP_CONST)
4632                 rop = op_append_elem(OP_LIST, rop,
4633                                   newSVOP(OP_CONST, o->op_flags,
4634                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
4635         }
4636     }
4637     return rop;
4638 }
4639
4640 STATIC void
4641 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
4642 {
4643     PERL_ARGS_ASSERT_APPLY_ATTRS;
4644     {
4645         SV * const stashsv = newSVhek(HvNAME_HEK(stash));
4646
4647         /* fake up C<use attributes $pkg,$rv,@attrs> */
4648
4649 #define ATTRSMODULE "attributes"
4650 #define ATTRSMODULE_PM "attributes.pm"
4651
4652         Perl_load_module(
4653           aTHX_ PERL_LOADMOD_IMPORT_OPS,
4654           newSVpvs(ATTRSMODULE),
4655           NULL,
4656           op_prepend_elem(OP_LIST,
4657                           newSVOP(OP_CONST, 0, stashsv),
4658                           op_prepend_elem(OP_LIST,
4659                                           newSVOP(OP_CONST, 0,
4660                                                   newRV(target)),
4661                                           dup_attrlist(attrs))));
4662     }
4663 }
4664
4665 STATIC void
4666 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
4667 {
4668     OP *pack, *imop, *arg;
4669     SV *meth, *stashsv, **svp;
4670
4671     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
4672
4673     if (!attrs)
4674         return;
4675
4676     assert(target->op_type == OP_PADSV ||
4677            target->op_type == OP_PADHV ||
4678            target->op_type == OP_PADAV);
4679
4680     /* Ensure that attributes.pm is loaded. */
4681     /* Don't force the C<use> if we don't need it. */
4682     svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
4683     if (svp && *svp != &PL_sv_undef)
4684         NOOP;   /* already in %INC */
4685     else
4686         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
4687                                newSVpvs(ATTRSMODULE), NULL);
4688
4689     /* Need package name for method call. */
4690     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
4691
4692     /* Build up the real arg-list. */
4693     stashsv = newSVhek(HvNAME_HEK(stash));
4694
4695     arg = newOP(OP_PADSV, 0);
4696     arg->op_targ = target->op_targ;
4697     arg = op_prepend_elem(OP_LIST,
4698                        newSVOP(OP_CONST, 0, stashsv),
4699                        op_prepend_elem(OP_LIST,
4700                                     newUNOP(OP_REFGEN, 0,
4701                                             arg),
4702                                     dup_attrlist(attrs)));
4703
4704     /* Fake up a method call to import */
4705     meth = newSVpvs_share("import");
4706     imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
4707                    op_append_elem(OP_LIST,
4708                                op_prepend_elem(OP_LIST, pack, arg),
4709                                newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
4710
4711     /* Combine the ops. */
4712     *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
4713 }
4714
4715 /*
4716 =notfor apidoc apply_attrs_string
4717
4718 Attempts to apply a list of attributes specified by the C<attrstr> and
4719 C<len> arguments to the subroutine identified by the C<cv> argument which
4720 is expected to be associated with the package identified by the C<stashpv>
4721 argument (see L<attributes>).  It gets this wrong, though, in that it
4722 does not correctly identify the boundaries of the individual attribute
4723 specifications within C<attrstr>.  This is not really intended for the
4724 public API, but has to be listed here for systems such as AIX which
4725 need an explicit export list for symbols.  (It's called from XS code
4726 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
4727 to respect attribute syntax properly would be welcome.
4728
4729 =cut
4730 */
4731
4732 void
4733 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
4734                         const char *attrstr, STRLEN len)
4735 {
4736     OP *attrs = NULL;
4737
4738     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
4739
4740     if (!len) {
4741         len = strlen(attrstr);
4742     }
4743
4744     while (len) {
4745         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
4746         if (len) {
4747             const char * const sstr = attrstr;
4748             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
4749             attrs = op_append_elem(OP_LIST, attrs,
4750                                 newSVOP(OP_CONST, 0,
4751                                         newSVpvn(sstr, attrstr-sstr)));
4752         }
4753     }
4754
4755     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
4756                      newSVpvs(ATTRSMODULE),
4757                      NULL, op_prepend_elem(OP_LIST,
4758                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
4759                                   op_prepend_elem(OP_LIST,
4760                                                newSVOP(OP_CONST, 0,
4761                                                        newRV(MUTABLE_SV(cv))),
4762                                                attrs)));
4763 }
4764
4765 STATIC void
4766 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name,
4767                         bool curstash)
4768 {
4769     OP *new_proto = NULL;
4770     STRLEN pvlen;
4771     char *pv;
4772     OP *o;
4773
4774     PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
4775
4776     if (!*attrs)
4777         return;
4778
4779     o = *attrs;
4780     if (o->op_type == OP_CONST) {
4781         pv = SvPV(cSVOPo_sv, pvlen);
4782         if (memBEGINs(pv, pvlen, "prototype(")) {
4783             SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
4784             SV ** const tmpo = cSVOPx_svp(o);
4785             SvREFCNT_dec(cSVOPo_sv);
4786             *tmpo = tmpsv;
4787             new_proto = o;
4788             *attrs = NULL;
4789         }
4790     } else if (o->op_type == OP_LIST) {
4791         OP * lasto;
4792         assert(o->op_flags & OPf_KIDS);
4793         lasto = cLISTOPo->op_first;
4794         assert(lasto->op_type == OP_PUSHMARK);
4795         for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
4796             if (o->op_type == OP_CONST) {
4797                 pv = SvPV(cSVOPo_sv, pvlen);
4798                 if (memBEGINs(pv, pvlen, "prototype(")) {
4799                     SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
4800                     SV ** const tmpo = cSVOPx_svp(o);
4801                     SvREFCNT_dec(cSVOPo_sv);
4802                     *tmpo = tmpsv;
4803                     if (new_proto && ckWARN(WARN_MISC)) {
4804                         STRLEN new_len;
4805                         const char * newp = SvPV(cSVOPo_sv, new_len);
4806                         Perl_warner(aTHX_ packWARN(WARN_MISC),
4807                             "Attribute prototype(%" UTF8f ") discards earlier prototype attribute in same sub",
4808                             UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
4809                         op_free(new_proto);
4810                     }
4811                     else if (new_proto)
4812                         op_free(new_proto);
4813                     new_proto = o;
4814                     /* excise new_proto from the list */
4815                     op_sibling_splice(*attrs, lasto, 1, NULL);
4816                     o = lasto;
4817                     continue;
4818                 }
4819             }
4820             lasto = o;
4821         }
4822         /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
4823            would get pulled in with no real need */
4824         if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
4825             op_free(*attrs);
4826             *attrs = NULL;
4827         }
4828     }
4829
4830     if (new_proto) {
4831         SV *svname;
4832         if (isGV(name)) {
4833             svname = sv_newmortal();
4834             gv_efullname3(svname, name, NULL);
4835         }
4836         else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
4837             svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
4838         else
4839             svname = (SV *)name;
4840         if (ckWARN(WARN_ILLEGALPROTO))
4841             (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE,
4842                                  curstash);
4843         if (*proto && ckWARN(WARN_PROTOTYPE)) {
4844             STRLEN old_len, new_len;
4845             const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
4846             const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
4847
4848             if (curstash && svname == (SV *)name
4849              && !memchr(SvPVX(svname), ':', SvCUR(svname))) {
4850                 svname = sv_2mortal(newSVsv(PL_curstname));
4851                 sv_catpvs(svname, "::");
4852                 sv_catsv(svname, (SV *)name);
4853             }
4854
4855             Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
4856                 "Prototype '%" UTF8f "' overridden by attribute 'prototype(%" UTF8f ")'"
4857                 " in %" SVf,
4858                 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
4859                 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
4860                 SVfARG(svname));
4861         }
4862         if (*proto)
4863             op_free(*proto);
4864         *proto = new_proto;
4865     }
4866 }
4867
4868 static void
4869 S_cant_declare(pTHX_ OP *o)
4870 {
4871     if (o->op_type == OP_NULL
4872      && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
4873         o = cUNOPo->op_first;
4874     yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
4875                              o->op_type == OP_NULL
4876                                && o->op_flags & OPf_SPECIAL
4877                                  ? "do block"
4878                                  : OP_DESC(o),
4879                              PL_parser->in_my == KEY_our   ? "our"   :
4880                              PL_parser->in_my == KEY_state ? "state" :
4881                                                              "my"));
4882 }
4883
4884 STATIC OP *
4885 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
4886 {
4887     I32 type;
4888     const bool stately = PL_parser && PL_parser->in_my == KEY_state;
4889
4890     PERL_ARGS_ASSERT_MY_KID;
4891
4892     if (!o || (PL_parser && PL_parser->error_count))
4893         return o;
4894
4895     type = o->op_type;
4896
4897     if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
4898         OP *kid;
4899         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4900             my_kid(kid, attrs, imopsp);
4901         return o;
4902     } else if (type == OP_UNDEF || type == OP_STUB) {
4903         return o;
4904     } else if (type == OP_RV2SV ||      /* "our" declaration */
4905                type == OP_RV2AV ||
4906                type == OP_RV2HV) {
4907         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
4908             S_cant_declare(aTHX_ o);
4909         } else if (attrs) {
4910             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
4911             assert(PL_parser);
4912             PL_parser->in_my = FALSE;
4913             PL_parser->in_my_stash = NULL;
4914             apply_attrs(GvSTASH(gv),
4915                         (type == OP_RV2SV ? GvSVn(gv) :
4916                          type == OP_RV2AV ? MUTABLE_SV(GvAVn(gv)) :
4917                          type == OP_RV2HV ? MUTABLE_SV(GvHVn(gv)) : MUTABLE_SV(gv)),
4918                         attrs);
4919         }
4920         o->op_private |= OPpOUR_INTRO;
4921         return o;
4922     }
4923     else if (type == OP_REFGEN || type == OP_SREFGEN) {
4924         if (!FEATURE_MYREF_IS_ENABLED)
4925             Perl_croak(aTHX_ "The experimental declared_refs "
4926                              "feature is not enabled");
4927         Perl_ck_warner_d(aTHX_
4928              packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4929             "Declaring references is experimental");
4930         /* Kid is a nulled OP_LIST, handled above.  */
4931         my_kid(cUNOPo->op_first, attrs, imopsp);
4932         return o;
4933     }
4934     else if (type != OP_PADSV &&
4935              type != OP_PADAV &&
4936              type != OP_PADHV &&
4937              type != OP_PUSHMARK)
4938     {
4939         S_cant_declare(aTHX_ o);
4940         return o;
4941     }
4942     else if (attrs && type != OP_PUSHMARK) {
4943         HV *stash;
4944
4945         assert(PL_parser);
4946         PL_parser->in_my = FALSE;
4947         PL_parser->in_my_stash = NULL;
4948
4949         /* check for C<my Dog $spot> when deciding package */
4950         stash = PAD_COMPNAME_TYPE(o->op_targ);
4951         if (!stash)
4952             stash = PL_curstash;
4953         apply_attrs_my(stash, o, attrs, imopsp);
4954     }
4955     o->op_flags |= OPf_MOD;
4956     o->op_private |= OPpLVAL_INTRO;
4957     if (stately)
4958         o->op_private |= OPpPAD_STATE;
4959     return o;
4960 }
4961
4962 OP *
4963 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
4964 {
4965     OP *rops;
4966     int maybe_scalar = 0;
4967
4968     PERL_ARGS_ASSERT_MY_ATTRS;
4969
4970 /* [perl #17376]: this appears to be premature, and results in code such as
4971    C< our(%x); > executing in list mode rather than void mode */
4972 #if 0
4973     if (o->op_flags & OPf_PARENS)
4974         list(o);
4975     else
4976         maybe_scalar = 1;
4977 #else
4978     maybe_scalar = 1;
4979 #endif
4980     if (attrs)
4981         SAVEFREEOP(attrs);
4982     rops = NULL;
4983     o = my_kid(o, attrs, &rops);
4984     if (rops) {
4985         if (maybe_scalar && o->op_type == OP_PADSV) {
4986             o = scalar(op_append_list(OP_LIST, rops, o));
4987             o->op_private |= OPpLVAL_INTRO;
4988         }
4989         else {
4990             /* The listop in rops might have a pushmark at the beginning,
4991                which will mess up list assignment. */
4992             LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
4993             if (rops->op_type == OP_LIST &&
4994                 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
4995             {
4996                 OP * const pushmark = lrops->op_first;
4997                 /* excise pushmark */
4998                 op_sibling_splice(rops, NULL, 1, NULL);
4999                 op_free(pushmark);
5000             }
5001             o = op_append_list(OP_LIST, o, rops);
5002         }
5003     }
5004     PL_parser->in_my = FALSE;
5005     PL_parser->in_my_stash = NULL;
5006     return o;
5007 }
5008
5009 OP *
5010 Perl_sawparens(pTHX_ OP *o)
5011 {
5012     PERL_UNUSED_CONTEXT;
5013     if (o)
5014         o->op_flags |= OPf_PARENS;
5015     return o;
5016 }
5017
5018 OP *
5019 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
5020 {
5021     OP *o;
5022     bool ismatchop = 0;
5023     const OPCODE ltype = left->op_type;
5024     const OPCODE rtype = right->op_type;
5025
5026     PERL_ARGS_ASSERT_BIND_MATCH;
5027
5028     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
5029           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
5030     {
5031       const char * const desc
5032           = PL_op_desc[(
5033                           rtype == OP_SUBST || rtype == OP_TRANS
5034                        || rtype == OP_TRANSR
5035                        )
5036                        ? (int)rtype : OP_MATCH];
5037       const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
5038       SV * const name =
5039         S_op_varname(aTHX_ left);
5040       if (name)
5041         Perl_warner(aTHX_ packWARN(WARN_MISC),
5042              "Applying %s to %" SVf " will act on scalar(%" SVf ")",
5043              desc, SVfARG(name), SVfARG(name));
5044       else {
5045         const char * const sample = (isary
5046              ? "@array" : "%hash");
5047         Perl_warner(aTHX_ packWARN(WARN_MISC),
5048              "Applying %s to %s will act on scalar(%s)",
5049              desc, sample, sample);
5050       }
5051     }
5052
5053     if (rtype == OP_CONST &&
5054         cSVOPx(right)->op_private & OPpCONST_BARE &&
5055         cSVOPx(right)->op_private & OPpCONST_STRICT)
5056     {
5057         no_bareword_allowed(right);
5058     }
5059
5060     /* !~ doesn't make sense with /r, so error on it for now */
5061     if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
5062         type == OP_NOT)
5063         /* diag_listed_as: Using !~ with %s doesn't make sense */
5064         yyerror("Using !~ with s///r doesn't make sense");
5065     if (rtype == OP_TRANSR && type == OP_NOT)
5066         /* diag_listed_as: Using !~ with %s doesn't make sense */
5067         yyerror("Using !~ with tr///r doesn't make sense");
5068
5069     ismatchop = (rtype == OP_MATCH ||
5070                  rtype == OP_SUBST ||
5071                  rtype == OP_TRANS || rtype == OP_TRANSR)
5072              && !(right->op_flags & OPf_SPECIAL);
5073     if (ismatchop && right->op_private & OPpTARGET_MY) {
5074         right->op_targ = 0;
5075         right->op_private &= ~OPpTARGET_MY;
5076     }
5077     if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
5078         if (left->op_type == OP_PADSV
5079          && !(left->op_private & OPpLVAL_INTRO))
5080         {
5081             right->op_targ = left->op_targ;
5082             op_free(left);
5083             o = right;
5084         }
5085         else {
5086             right->op_flags |= OPf_STACKED;
5087             if (rtype != OP_MATCH && rtype != OP_TRANSR &&
5088             ! (rtype == OP_TRANS &&
5089                right->op_private & OPpTRANS_IDENTICAL) &&
5090             ! (rtype == OP_SUBST &&
5091                (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
5092                 left = op_lvalue(left, rtype);
5093             if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
5094                 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
5095             else
5096                 o = op_prepend_elem(rtype, scalar(left), right);
5097         }
5098         if (type == OP_NOT)
5099             return newUNOP(OP_NOT, 0, scalar(o));
5100         return o;
5101     }
5102     else
5103         return bind_match(type, left,
5104                 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
5105 }
5106
5107 OP *
5108 Perl_invert(pTHX_ OP *o)
5109 {
5110     if (!o)
5111         return NULL;
5112     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
5113 }
5114
5115 /*
5116 =for apidoc Amx|OP *|op_scope|OP *o
5117
5118 Wraps up an op tree with some additional ops so that at runtime a dynamic
5119 scope will be created.  The original ops run in the new dynamic scope,
5120 and then, provided that they exit normally, the scope will be unwound.
5121 The additional ops used to create and unwind the dynamic scope will
5122 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
5123 instead if the ops are simple enough to not need the full dynamic scope
5124 structure.
5125
5126 =cut
5127 */
5128
5129 OP *
5130 Perl_op_scope(pTHX_ OP *o)
5131 {
5132     dVAR;
5133     if (o) {
5134         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
5135             o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
5136             OpTYPE_set(o, OP_LEAVE);
5137         }
5138         else if (o->op_type == OP_LINESEQ) {
5139             OP *kid;
5140             OpTYPE_set(o, OP_SCOPE);
5141             kid = ((LISTOP*)o)->op_first;
5142             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
5143                 op_null(kid);
5144
5145                 /* The following deals with things like 'do {1 for 1}' */
5146                 kid = OpSIBLING(kid);
5147                 if (kid &&
5148                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
5149                     op_null(kid);
5150             }
5151         }
5152         else
5153             o = newLISTOP(OP_SCOPE, 0, o, NULL);
5154     }
5155     return o;
5156 }
5157
5158 OP *
5159 Perl_op_unscope(pTHX_ OP *o)
5160 {
5161     if (o && o->op_type == OP_LINESEQ) {
5162         OP *kid = cLISTOPo->op_first;
5163         for(; kid; kid = OpSIBLING(kid))
5164             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
5165                 op_null(kid);
5166     }
5167     return o;
5168 }
5169
5170 /*
5171 =for apidoc Am|int|block_start|int full
5172
5173 Handles compile-time scope entry.
5174 Arranges for hints to be restored on block
5175 exit and also handles pad sequence numbers to make lexical variables scope
5176 right.  Returns a savestack index for use with C<block_end>.
5177
5178 =cut
5179 */
5180
5181 int
5182 Perl_block_start(pTHX_ int full)
5183 {
5184     const int retval = PL_savestack_ix;
5185
5186     PL_compiling.cop_seq = PL_cop_seqmax;
5187     COP_SEQMAX_INC;
5188     pad_block_start(full);
5189     SAVEHINTS();
5190     PL_hints &= ~HINT_BLOCK_SCOPE;
5191     SAVECOMPILEWARNINGS();
5192     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
5193     SAVEI32(PL_compiling.cop_seq);
5194     PL_compiling.cop_seq = 0;
5195
5196     CALL_BLOCK_HOOKS(bhk_start, full);
5197
5198     return retval;
5199 }
5200
5201 /*
5202 =for apidoc Am|OP *|block_end|I32 floor|OP *seq
5203
5204 Handles compile-time scope exit.  C<floor>
5205 is the savestack index returned by
5206 C<block_start>, and C<seq> is the body of the block.  Returns the block,
5207 possibly modified.
5208
5209 =cut
5210 */
5211
5212 OP*
5213 Perl_block_end(pTHX_ I32 floor, OP *seq)
5214 {
5215     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
5216     OP* retval = scalarseq(seq);
5217     OP *o;
5218
5219     /* XXX Is the null PL_parser check necessary here? */
5220     assert(PL_parser); /* Let’s find out under debugging builds.  */
5221     if (PL_parser && PL_parser->parsed_sub) {
5222         o = newSTATEOP(0, NULL, NULL);
5223         op_null(o);
5224         retval = op_append_elem(OP_LINESEQ, retval, o);
5225     }
5226
5227     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
5228
5229     LEAVE_SCOPE(floor);
5230     if (needblockscope)
5231         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
5232     o = pad_leavemy();
5233
5234     if (o) {
5235         /* pad_leavemy has created a sequence of introcv ops for all my
5236            subs declared in the block.  We have to replicate that list with
5237            clonecv ops, to deal with this situation:
5238
5239                sub {
5240                    my sub s1;
5241                    my sub s2;
5242                    sub s1 { state sub foo { \&s2 } }
5243                }->()
5244
5245            Originally, I was going to have introcv clone the CV and turn
5246            off the stale flag.  Since &s1 is declared before &s2, the
5247            introcv op for &s1 is executed (on sub entry) before the one for
5248            &s2.  But the &foo sub inside &s1 (which is cloned when &s1 is
5249            cloned, since it is a state sub) closes over &s2 and expects
5250            to see it in its outer CV’s pad.  If the introcv op clones &s1,
5251            then &s2 is still marked stale.  Since &s1 is not active, and
5252            &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
5253            ble will not stay shared’ warning.  Because it is the same stub
5254            that will be used when the introcv op for &s2 is executed, clos-
5255            ing over it is safe.  Hence, we have to turn off the stale flag
5256            on all lexical subs in the block before we clone any of them.
5257            Hence, having introcv clone the sub cannot work.  So we create a
5258            list of ops like this:
5259
5260                lineseq
5261                   |
5262                   +-- introcv
5263                   |
5264                   +-- introcv
5265                   |
5266                   +-- introcv
5267                   |
5268                   .
5269                   .
5270                   .
5271                   |
5272                   +-- clonecv
5273                   |
5274                   +-- clonecv
5275                   |
5276                   +-- clonecv
5277                   |
5278                   .
5279                   .
5280                   .
5281          */
5282         OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
5283         OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
5284         for (;; kid = OpSIBLING(kid)) {
5285             OP *newkid = newOP(OP_CLONECV, 0);
5286             newkid->op_targ = kid->op_targ;
5287             o = op_append_elem(OP_LINESEQ, o, newkid);
5288             if (kid == last) break;
5289         }
5290         retval = op_prepend_elem(OP_LINESEQ, o, retval);
5291     }
5292
5293     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
5294
5295     return retval;
5296 }
5297
5298 /*
5299 =head1 Compile-time scope hooks
5300
5301 =for apidoc Aox||blockhook_register
5302
5303 Register a set of hooks to be called when the Perl lexical scope changes
5304 at compile time.  See L<perlguts/"Compile-time scope hooks">.
5305
5306 =cut
5307 */
5308
5309 void
5310 Perl_blockhook_register(pTHX_ BHK *hk)
5311 {
5312     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
5313
5314     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
5315 }
5316
5317 void
5318 Perl_newPROG(pTHX_ OP *o)
5319 {
5320     OP *start;
5321
5322     PERL_ARGS_ASSERT_NEWPROG;
5323
5324     if (PL_in_eval) {
5325         PERL_CONTEXT *cx;
5326         I32 i;
5327         if (PL_eval_root)
5328                 return;
5329         PL_eval_root = newUNOP(OP_LEAVEEVAL,
5330                                ((PL_in_eval & EVAL_KEEPERR)
5331                                 ? OPf_SPECIAL : 0), o);
5332
5333         cx = CX_CUR();
5334         assert(CxTYPE(cx) == CXt_EVAL);
5335
5336         if ((cx->blk_gimme & G_WANT) == G_VOID)
5337             scalarvoid(PL_eval_root);
5338         else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
5339             list(PL_eval_root);
5340         else
5341             scalar(PL_eval_root);
5342
5343         start = op_linklist(PL_eval_root);
5344         PL_eval_root->op_next = 0;
5345         i = PL_savestack_ix;
5346         SAVEFREEOP(o);
5347         ENTER;
5348         S_process_optree(aTHX_ NULL, PL_eval_root, start);
5349         LEAVE;
5350         PL_savestack_ix = i;
5351     }
5352     else {
5353         if (o->op_type == OP_STUB) {
5354             /* This block is entered if nothing is compiled for the main
5355                program. This will be the case for an genuinely empty main
5356                program, or one which only has BEGIN blocks etc, so already
5357                run and freed.
5358
5359                Historically (5.000) the guard above was !o. However, commit
5360                f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
5361                c71fccf11fde0068, changed perly.y so that newPROG() is now
5362                called with the output of block_end(), which returns a new
5363                OP_STUB for the case of an empty optree. ByteLoader (and
5364                maybe other things) also take this path, because they set up
5365                PL_main_start and PL_main_root directly, without generating an
5366                optree.
5367
5368                If the parsing the main program aborts (due to parse errors,
5369                or due to BEGIN or similar calling exit), then newPROG()
5370                isn't even called, and hence this code path and its cleanups
5371                are skipped. This shouldn't make a make a difference:
5372                * a non-zero return from perl_parse is a failure, and
5373                  perl_destruct() should be called immediately.
5374                * however, if exit(0) is called during the parse, then
5375                  perl_parse() returns 0, and perl_run() is called. As
5376                  PL_main_start will be NULL, perl_run() will return
5377                  promptly, and the exit code will remain 0.
5378             */
5379
5380             PL_comppad_name = 0;
5381             PL_compcv = 0;
5382             S_op_destroy(aTHX_ o);
5383             return;
5384         }
5385         PL_main_root = op_scope(sawparens(scalarvoid(o)));
5386         PL_curcop = &PL_compiling;
5387         start = LINKLIST(PL_main_root);
5388         PL_main_root->op_next = 0;
5389         S_process_optree(aTHX_ NULL, PL_main_root, start);
5390         cv_forget_slab(PL_compcv);
5391         PL_compcv = 0;
5392
5393         /* Register with debugger */
5394         if (PERLDB_INTER) {
5395             CV * const cv = get_cvs("DB::postponed", 0);
5396             if (cv) {
5397                 dSP;
5398                 PUSHMARK(SP);
5399                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
5400                 PUTBACK;
5401                 call_sv(MUTABLE_SV(cv), G_DISCARD);
5402             }
5403         }
5404     }
5405 }
5406
5407 OP *
5408 Perl_localize(pTHX_ OP *o, I32 lex)
5409 {
5410     PERL_ARGS_ASSERT_LOCALIZE;
5411
5412     if (o->op_flags & OPf_PARENS)
5413 /* [perl #17376]: this appears to be premature, and results in code such as
5414    C< our(%x); > executing in list mode rather than void mode */
5415 #if 0
5416         list(o);
5417 #else
5418         NOOP;
5419 #endif
5420     else {
5421         if ( PL_parser->bufptr > PL_parser->oldbufptr
5422             && PL_parser->bufptr[-1] == ','
5423             && ckWARN(WARN_PARENTHESIS))
5424         {
5425             char *s = PL_parser->bufptr;
5426             bool sigil = FALSE;
5427
5428             /* some heuristics to detect a potential error */
5429             while (*s && (strchr(", \t\n", *s)))
5430                 s++;
5431
5432             while (1) {
5433                 if (*s && (strchr("@$%", *s) || (!lex && *s == '*'))
5434                        && *++s
5435                        && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
5436                     s++;
5437                     sigil = TRUE;
5438                     while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
5439                         s++;
5440                     while (*s && (strchr(", \t\n", *s)))
5441                         s++;
5442                 }
5443                 else
5444                     break;
5445             }
5446             if (sigil && (*s == ';' || *s == '=')) {
5447                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
5448                                 "Parentheses missing around \"%s\" list",
5449                                 lex
5450                                     ? (PL_parser->in_my == KEY_our
5451                                         ? "our"
5452                                         : PL_parser->in_my == KEY_state
5453                                             ? "state"
5454                                             : "my")
5455                                     : "local");
5456             }
5457         }
5458     }
5459     if (lex)
5460         o = my(o);
5461     else
5462         o = op_lvalue(o, OP_NULL);              /* a bit kludgey */
5463     PL_parser->in_my = FALSE;
5464     PL_parser->in_my_stash = NULL;
5465     return o;
5466 }
5467
5468 OP *
5469 Perl_jmaybe(pTHX_ OP *o)
5470 {
5471     PERL_ARGS_ASSERT_JMAYBE;
5472
5473     if (o->op_type == OP_LIST) {
5474         OP * const o2
5475             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
5476         o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
5477     }
5478     return o;
5479 }
5480
5481 PERL_STATIC_INLINE OP *
5482 S_op_std_init(pTHX_ OP *o)
5483 {
5484     I32 type = o->op_type;
5485
5486     PERL_ARGS_ASSERT_OP_STD_INIT;
5487
5488     if (PL_opargs[type] & OA_RETSCALAR)
5489         scalar(o);
5490     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
5491         o->op_targ = pad_alloc(type, SVs_PADTMP);
5492
5493     return o;
5494 }
5495
5496 PERL_STATIC_INLINE OP *
5497 S_op_integerize(pTHX_ OP *o)
5498 {
5499     I32 type = o->op_type;
5500
5501     PERL_ARGS_ASSERT_OP_INTEGERIZE;
5502
5503     /* integerize op. */
5504     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
5505     {
5506         dVAR;
5507         o->op_ppaddr = PL_ppaddr[++(o->op_type)];
5508     }
5509
5510     if (type == OP_NEGATE)
5511         /* XXX might want a ck_negate() for this */
5512         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
5513
5514     return o;
5515 }
5516
5517 /* This function exists solely to provide a scope to limit
5518    setjmp/longjmp() messing with auto variables.
5519  */
5520 PERL_STATIC_INLINE int
5521 S_fold_constants_eval(pTHX) {
5522     int ret = 0;
5523     dJMPENV;
5524
5525     JMPENV_PUSH(ret);
5526
5527     if (ret == 0) {
5528         CALLRUNOPS(aTHX);
5529     }
5530
5531     JMPENV_POP;
5532
5533     return ret;
5534 }
5535
5536 static OP *
5537 S_fold_constants(pTHX_ OP *const o)
5538 {
5539     dVAR;
5540     OP *curop;
5541     OP *newop;
5542     I32 type = o->op_type;
5543     bool is_stringify;
5544     SV *sv = NULL;
5545     int ret = 0;
5546     OP *old_next;
5547     SV * const oldwarnhook = PL_warnhook;
5548     SV * const olddiehook  = PL_diehook;
5549     COP not_compiling;
5550     U8 oldwarn = PL_dowarn;
5551     I32 old_cxix;
5552
5553     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
5554
5555     if (!(PL_opargs[type] & OA_FOLDCONST))
5556         goto nope;
5557
5558     switch (type) {
5559     case OP_UCFIRST:
5560     case OP_LCFIRST:
5561     case OP_UC:
5562     case OP_LC:
5563     case OP_FC:
5564 #ifdef USE_LOCALE_CTYPE
5565         if (IN_LC_COMPILETIME(LC_CTYPE))
5566             goto nope;
5567 #endif
5568         break;
5569     case OP_SLT:
5570     case OP_SGT:
5571     case OP_SLE:
5572     case OP_SGE:
5573     case OP_SCMP:
5574 #ifdef USE_LOCALE_COLLATE
5575         if (IN_LC_COMPILETIME(LC_COLLATE))
5576             goto nope;
5577 #endif
5578         break;
5579     case OP_SPRINTF:
5580         /* XXX what about the numeric ops? */
5581 #ifdef USE_LOCALE_NUMERIC
5582         if (IN_LC_COMPILETIME(LC_NUMERIC))
5583             goto nope;
5584 #endif
5585         break;
5586     case OP_PACK:
5587         if (!OpHAS_SIBLING(cLISTOPo->op_first)
5588           || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
5589             goto nope;
5590         {
5591             SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
5592             if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
5593             {
5594                 const char *s = SvPVX_const(sv);
5595                 while (s < SvEND(sv)) {
5596                     if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
5597                     s++;
5598                 }
5599             }
5600         }
5601         break;
5602     case OP_REPEAT:
5603         if (o->op_private & OPpREPEAT_DOLIST) goto nope;
5604         break;
5605     case OP_SREFGEN:
5606         if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
5607          || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
5608             goto nope;
5609     }
5610
5611     if (PL_parser && PL_parser->error_count)
5612         goto nope;              /* Don't try to run w/ errors */
5613
5614     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
5615         switch (curop->op_type) {
5616         case OP_CONST:
5617             if (   (curop->op_private & OPpCONST_BARE)
5618                 && (curop->op_private & OPpCONST_STRICT)) {
5619                 no_bareword_allowed(curop);
5620                 goto nope;
5621             }
5622             /* FALLTHROUGH */
5623         case OP_LIST:
5624         case OP_SCALAR:
5625         case OP_NULL:
5626         case OP_PUSHMARK:
5627             /* Foldable; move to next op in list */
5628             break;
5629
5630         default:
5631             /* No other op types are considered foldable */
5632             goto nope;
5633         }
5634     }
5635
5636     curop = LINKLIST(o);
5637     old_next = o->op_next;
5638     o->op_next = 0;
5639     PL_op = curop;
5640
5641     old_cxix = cxstack_ix;
5642     create_eval_scope(NULL, G_FAKINGEVAL);
5643
5644     /* Verify that we don't need to save it:  */
5645     assert(PL_curcop == &PL_compiling);
5646     StructCopy(&PL_compiling, &not_compiling, COP);
5647     PL_curcop = &not_compiling;
5648     /* The above ensures that we run with all the correct hints of the
5649        currently compiling COP, but that IN_PERL_RUNTIME is true. */
5650     assert(IN_PERL_RUNTIME);
5651     PL_warnhook = PERL_WARNHOOK_FATAL;
5652     PL_diehook  = NULL;
5653
5654     /* Effective $^W=1.  */
5655     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
5656         PL_dowarn |= G_WARN_ON;
5657
5658     ret = S_fold_constants_eval(aTHX);
5659
5660     switch (ret) {
5661     case 0:
5662         sv = *(PL_stack_sp--);
5663         if (o->op_targ && sv == PAD_SV(o->op_targ)) {   /* grab pad temp? */
5664             pad_swipe(o->op_targ,  FALSE);
5665         }
5666         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
5667             SvREFCNT_inc_simple_void(sv);
5668             SvTEMP_off(sv);
5669         }
5670         else { assert(SvIMMORTAL(sv)); }
5671         break;
5672     case 3:
5673         /* Something tried to die.  Abandon constant folding.  */
5674         /* Pretend the error never happened.  */
5675         CLEAR_ERRSV();
5676         o->op_next = old_next;
5677         break;
5678     default:
5679         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
5680         PL_warnhook = oldwarnhook;
5681         PL_diehook  = olddiehook;
5682         /* XXX note that this croak may fail as we've already blown away
5683          * the stack - eg any nested evals */
5684         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
5685     }
5686     PL_dowarn   = oldwarn;
5687     PL_warnhook = oldwarnhook;
5688     PL_diehook  = olddiehook;
5689     PL_curcop = &PL_compiling;
5690
5691     /* if we croaked, depending on how we croaked the eval scope
5692      * may or may not have already been popped */
5693     if (cxstack_ix > old_cxix) {
5694         assert(cxstack_ix == old_cxix + 1);
5695         assert(CxTYPE(CX_CUR()) == CXt_EVAL);
5696         delete_eval_scope();
5697     }
5698     if (ret)
5699         goto nope;
5700
5701     /* OP_STRINGIFY and constant folding are used to implement qq.
5702        Here the constant folding is an implementation detail that we
5703        want to hide.  If the stringify op is itself already marked
5704        folded, however, then it is actually a folded join.  */
5705     is_stringify = type == OP_STRINGIFY && !o->op_folded;
5706     op_free(o);
5707     assert(sv);
5708     if (is_stringify)
5709         SvPADTMP_off(sv);
5710     else if (!SvIMMORTAL(sv)) {
5711         SvPADTMP_on(sv);
5712         SvREADONLY_on(sv);
5713     }
5714     newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
5715     if (!is_stringify) newop->op_folded = 1;
5716     return newop;
5717
5718  nope:
5719     return o;
5720 }
5721
5722 static OP *
5723 S_gen_constant_list(pTHX_ OP *o)
5724 {
5725     dVAR;
5726     OP *curop, *old_next;
5727     SV * const oldwarnhook = PL_warnhook;
5728     SV * const olddiehook  = PL_diehook;
5729     COP *old_curcop;
5730     U8 oldwarn = PL_dowarn;
5731     SV **svp;
5732     AV *av;
5733     I32 old_cxix;
5734     COP not_compiling;
5735     int ret = 0;
5736     dJMPENV;
5737     bool op_was_null;
5738
5739     list(o);
5740     if (PL_parser && PL_parser->error_count)
5741         return o;               /* Don't attempt to run with errors */
5742
5743     curop = LINKLIST(o);
5744     old_next = o->op_next;
5745     o->op_next = 0;
5746     op_was_null = o->op_type == OP_NULL;
5747     if (op_was_null) /* b3698342565fb462291fba4b432cfcd05b6eb4e1 */
5748         o->op_type = OP_CUSTOM;
5749     CALL_PEEP(curop);
5750     if (op_was_null)
5751         o->op_type = OP_NULL;
5752     S_prune_chain_head(&curop);
5753     PL_op = curop;
5754
5755     old_cxix = cxstack_ix;
5756     create_eval_scope(NULL, G_FAKINGEVAL);
5757
5758     old_curcop = PL_curcop;
5759     StructCopy(old_curcop, &not_compiling, COP);
5760     PL_curcop = &not_compiling;
5761     /* The above ensures that we run with all the correct hints of the
5762        current COP, but that IN_PERL_RUNTIME is true. */
5763     assert(IN_PERL_RUNTIME);
5764     PL_warnhook = PERL_WARNHOOK_FATAL;
5765     PL_diehook  = NULL;
5766     JMPENV_PUSH(ret);
5767
5768     /* Effective $^W=1.  */
5769     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
5770         PL_dowarn |= G_WARN_ON;
5771
5772     switch (ret) {
5773     case 0:
5774 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
5775         PL_curstackinfo->si_stack_hwm = 0; /* stop valgrind complaining */
5776 #endif
5777         Perl_pp_pushmark(aTHX);
5778         CALLRUNOPS(aTHX);
5779         PL_op = curop;
5780         assert (!(curop->op_flags & OPf_SPECIAL));
5781         assert(curop->op_type == OP_RANGE);
5782         Perl_pp_anonlist(aTHX);
5783         break;
5784     case 3:
5785         CLEAR_ERRSV();
5786         o->op_next = old_next;
5787         break;
5788     default:
5789         JMPENV_POP;
5790         PL_warnhook = oldwarnhook;
5791         PL_diehook = olddiehook;
5792         Perl_croak(aTHX_ "panic: gen_constant_list JMPENV_PUSH returned %d",
5793             ret);
5794     }
5795
5796     JMPENV_POP;
5797     PL_dowarn = oldwarn;
5798     PL_warnhook = oldwarnhook;
5799     PL_diehook = olddiehook;
5800     PL_curcop = old_curcop;
5801
5802     if (cxstack_ix > old_cxix) {
5803         assert(cxstack_ix == old_cxix + 1);
5804         assert(CxTYPE(CX_CUR()) == CXt_EVAL);
5805         delete_eval_scope();
5806     }
5807     if (ret)
5808         return o;
5809
5810     OpTYPE_set(o, OP_RV2AV);
5811     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
5812     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
5813     o->op_opt = 0;              /* needs to be revisited in rpeep() */
5814     av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
5815
5816     /* replace subtree with an OP_CONST */
5817     curop = ((UNOP*)o)->op_first;
5818     op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
5819     op_free(curop);
5820
5821     if (AvFILLp(av) != -1)
5822         for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
5823         {
5824             SvPADTMP_on(*svp);
5825             SvREADONLY_on(*svp);
5826         }
5827     LINKLIST(o);
5828     return list(o);
5829 }
5830
5831 /*
5832 =head1 Optree Manipulation Functions
5833 */
5834
5835 /* List constructors */
5836
5837 /*
5838 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
5839
5840 Append an item to the list of ops contained directly within a list-type
5841 op, returning the lengthened list.  C<first> is the list-type op,
5842 and C<last> is the op to append to the list.  C<optype> specifies the
5843 intended opcode for the list.  If C<first> is not already a list of the
5844 right type, it will be upgraded into one.  If either C<first> or C<last>
5845 is null, the other is returned unchanged.
5846
5847 =cut
5848 */
5849
5850 OP *
5851 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
5852 {
5853     if (!first)
5854         return last;
5855
5856     if (!last)
5857         return first;
5858
5859     if (first->op_type != (unsigned)type
5860         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
5861     {
5862         return newLISTOP(type, 0, first, last);
5863     }
5864
5865     op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
5866     first->op_flags |= OPf_KIDS;
5867     return first;
5868 }
5869
5870 /*
5871 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
5872
5873 Concatenate the lists of ops contained directly within two list-type ops,
5874 returning the combined list.  C<first> and C<last> are the list-type ops
5875 to concatenate.  C<optype> specifies the intended opcode for the list.
5876 If either C<first> or C<last> is not already a list of the right type,
5877 it will be upgraded into one.  If either C<first> or C<last> is null,
5878 the other is returned unchanged.
5879
5880 =cut
5881 */
5882
5883 OP *
5884 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
5885 {
5886     if (!first)
5887         return last;
5888
5889     if (!last)
5890         return first;
5891
5892     if (first->op_type != (unsigned)type)
5893         return op_prepend_elem(type, first, last);
5894
5895     if (last->op_type != (unsigned)type)
5896         return op_append_elem(type, first, last);
5897
5898     OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
5899     ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
5900     OpLASTSIB_set(((LISTOP*)first)->op_last, first);
5901     first->op_flags |= (last->op_flags & OPf_KIDS);
5902
5903     S_op_destroy(aTHX_ last);
5904
5905     return first;
5906 }
5907
5908 /*
5909 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
5910
5911 Prepend an item to the list of ops contained directly within a list-type
5912 op, returning the lengthened list.  C<first> is the op to prepend to the
5913 list, and C<last> is the list-type op.  C<optype> specifies the intended
5914 opcode for the list.  If C<last> is not already a list of the right type,
5915 it will be upgraded into one.  If either C<first> or C<last> is null,
5916 the other is returned unchanged.
5917
5918 =cut
5919 */
5920
5921 OP *
5922 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
5923 {
5924     if (!first)
5925         return last;
5926
5927     if (!last)
5928         return first;
5929
5930     if (last->op_type == (unsigned)type) {
5931         if (type == OP_LIST) {  /* already a PUSHMARK there */
5932             /* insert 'first' after pushmark */
5933             op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
5934             if (!(first->op_flags & OPf_PARENS))
5935                 last->op_flags &= ~OPf_PARENS;
5936         }
5937         else
5938             op_sibling_splice(last, NULL, 0, first);
5939         last->op_flags |= OPf_KIDS;
5940         return last;
5941     }
5942
5943     return newLISTOP(type, 0, first, last);
5944 }
5945
5946 /*
5947 =for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
5948
5949 Converts C<o> into a list op if it is not one already, and then converts it
5950 into the specified C<type>, calling its check function, allocating a target if
5951 it needs one, and folding constants.
5952
5953 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
5954 C<op_prepend_elem> and C<op_append_elem>.  Then finally it is passed to
5955 C<op_convert_list> to make it the right type.
5956
5957 =cut
5958 */
5959
5960 OP *
5961 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
5962 {
5963     dVAR;
5964     if (type < 0) type = -type, flags |= OPf_SPECIAL;
5965     if (!o || o->op_type != OP_LIST)
5966         o = force_list(o, 0);
5967     else
5968     {
5969         o->op_flags &= ~OPf_WANT;
5970         o->op_private &= ~OPpLVAL_INTRO;
5971     }
5972
5973     if (!(PL_opargs[type] & OA_MARK))
5974         op_null(cLISTOPo->op_first);
5975     else {
5976         OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
5977         if (kid2 && kid2->op_type == OP_COREARGS) {
5978             op_null(cLISTOPo->op_first);
5979             kid2->op_private |= OPpCOREARGS_PUSHMARK;
5980         }
5981     }
5982
5983     if (type != OP_SPLIT)
5984         /* At this point o is a LISTOP, but OP_SPLIT is a PMOP; let
5985          * ck_split() create a real PMOP and leave the op's type as listop
5986          * for now. Otherwise op_free() etc will crash.
5987          */
5988         OpTYPE_set(o, type);
5989
5990     o->op_flags |= flags;
5991     if (flags & OPf_FOLDED)
5992         o->op_folded = 1;
5993
5994     o = CHECKOP(type, o);
5995     if (o->op_type != (unsigned)type)
5996         return o;
5997
5998     return fold_constants(op_integerize(op_std_init(o)));
5999 }
6000
6001 /* Constructors */
6002
6003
6004 /*
6005 =head1 Optree construction
6006
6007 =for apidoc Am|OP *|newNULLLIST
6008
6009 Constructs, checks, and returns a new C<stub> op, which represents an
6010 empty list expression.
6011
6012 =cut
6013 */
6014
6015 OP *
6016 Perl_newNULLLIST(pTHX)
6017 {
6018     return newOP(OP_STUB, 0);
6019 }
6020
6021 /* promote o and any siblings to be a list if its not already; i.e.
6022  *
6023  *  o - A - B
6024  *
6025  * becomes
6026  *
6027  *  list
6028  *    |
6029  *  pushmark - o - A - B
6030  *
6031  * If nullit it true, the list op is nulled.
6032  */
6033
6034 static OP *
6035 S_force_list(pTHX_ OP *o, bool nullit)
6036 {
6037     if (!o || o->op_type != OP_LIST) {
6038         OP *rest = NULL;
6039         if (o) {
6040             /* manually detach any siblings then add them back later */
6041             rest = OpSIBLING(o);
6042             OpLASTSIB_set(o, NULL);
6043         }
6044         o = newLISTOP(OP_LIST, 0, o, NULL);
6045         if (rest)
6046             op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
6047     }
6048     if (nullit)
6049         op_null(o);
6050     return o;
6051 }
6052
6053 /*
6054 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
6055
6056 Constructs, checks, and returns an op of any list type.  C<type> is
6057 the opcode.  C<flags> gives the eight bits of C<op_flags>, except that
6058 C<OPf_KIDS> will be set automatically if required.  C<first> and C<last>
6059 supply up to two ops to be direct children of the list op; they are
6060 consumed by this function and become part of the constructed op tree.
6061
6062 For most list operators, the check function expects all the kid ops to be
6063 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
6064 appropriate.  What you want to do in that case is create an op of type
6065 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
6066 See L</op_convert_list> for more information.
6067
6068
6069 =cut
6070 */
6071
6072 OP *
6073 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6074 {
6075     dVAR;
6076     LISTOP *listop;
6077
6078     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
6079         || type == OP_CUSTOM);
6080
6081     NewOp(1101, listop, 1, LISTOP);
6082
6083     OpTYPE_set(listop, type);
6084     if (first || last)
6085         flags |= OPf_KIDS;
6086     listop->op_flags = (U8)flags;
6087
6088     if (!last && first)
6089         last = first;
6090     else if (!first && last)
6091         first = last;
6092     else if (first)
6093         OpMORESIB_set(first, last);
6094     listop->op_first = first;
6095     listop->op_last = last;
6096     if (type == OP_LIST) {
6097         OP* const pushop = newOP(OP_PUSHMARK, 0);
6098         OpMORESIB_set(pushop, first);
6099         listop->op_first = pushop;
6100         listop->op_flags |= OPf_KIDS;
6101         if (!last)
6102             listop->op_last = pushop;
6103     }
6104     if (listop->op_last)
6105         OpLASTSIB_set(listop->op_last, (OP*)listop);
6106
6107     return CHECKOP(type, listop);
6108 }
6109
6110 /*
6111 =for apidoc Am|OP *|newOP|I32 type|I32 flags
6112
6113 Constructs, checks, and returns an op of any base type (any type that
6114 has no extra fields).  C<type> is the opcode.  C<flags> gives the
6115 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
6116 of C<op_private>.
6117
6118 =cut
6119 */
6120
6121 OP *
6122 Perl_newOP(pTHX_ I32 type, I32 flags)
6123 {
6124     dVAR;
6125     OP *o;
6126
6127     if (type == -OP_ENTEREVAL) {
6128         type = OP_ENTEREVAL;
6129         flags |= OPpEVAL_BYTES<<8;
6130     }
6131
6132     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
6133         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6134         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6135         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6136
6137     NewOp(1101, o, 1, OP);
6138     OpTYPE_set(o, type);
6139     o->op_flags = (U8)flags;
6140
6141     o->op_next = o;
6142     o->op_private = (U8)(0 | (flags >> 8));
6143     if (PL_opargs[type] & OA_RETSCALAR)
6144         scalar(o);
6145     if (PL_opargs[type] & OA_TARGET)
6146         o->op_targ = pad_alloc(type, SVs_PADTMP);
6147     return CHECKOP(type, o);
6148 }
6149
6150 /*
6151 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
6152
6153 Constructs, checks, and returns an op of any unary type.  C<type> is
6154 the opcode.  C<flags> gives the eight bits of C<op_flags>, except that
6155 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
6156 bits, the eight bits of C<op_private>, except that the bit with value 1
6157 is automatically set.  C<first> supplies an optional op to be the direct
6158 child of the unary op; it is consumed by this function and become part
6159 of the constructed op tree.
6160
6161 =cut
6162 */
6163
6164 OP *
6165 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
6166 {
6167     dVAR;
6168     UNOP *unop;
6169
6170     if (type == -OP_ENTEREVAL) {
6171         type = OP_ENTEREVAL;
6172         flags |= OPpEVAL_BYTES<<8;
6173     }
6174
6175     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
6176         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6177         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6178         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
6179         || type == OP_SASSIGN
6180         || type == OP_ENTERTRY
6181         || type == OP_CUSTOM
6182         || type == OP_NULL );
6183
6184     if (!first)
6185         first = newOP(OP_STUB, 0);
6186     if (PL_opargs[type] & OA_MARK)
6187         first = force_list(first, 1);
6188
6189     NewOp(1101, unop, 1, UNOP);
6190     OpTYPE_set(unop, type);
6191     unop->op_first = first;
6192     unop->op_flags = (U8)(flags | OPf_KIDS);
6193     unop->op_private = (U8)(1 | (flags >> 8));
6194
6195     if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
6196         OpLASTSIB_set(first, (OP*)unop);
6197
6198     unop = (UNOP*) CHECKOP(type, unop);
6199     if (unop->op_next)
6200         return (OP*)unop;
6201
6202     return fold_constants(op_integerize(op_std_init((OP *) unop)));
6203 }
6204
6205 /*
6206 =for apidoc newUNOP_AUX
6207
6208 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
6209 initialised to C<aux>
6210
6211 =cut
6212 */
6213
6214 OP *
6215 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
6216 {
6217     dVAR;
6218     UNOP_AUX *unop;
6219
6220     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
6221         || type == OP_CUSTOM);
6222
6223     NewOp(1101, unop, 1, UNOP_AUX);
6224     unop->op_type = (OPCODE)type;
6225     unop->op_ppaddr = PL_ppaddr[type];
6226     unop->op_first = first;
6227     unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
6228     unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
6229     unop->op_aux = aux;
6230
6231     if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
6232         OpLASTSIB_set(first, (OP*)unop);
6233
6234     unop = (UNOP_AUX*) CHECKOP(type, unop);
6235
6236     return op_std_init((OP *) unop);
6237 }
6238
6239 /*
6240 =for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
6241
6242 Constructs, checks, and returns an op of method type with a method name
6243 evaluated at runtime.  C<type> is the opcode.  C<flags> gives the eight
6244 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
6245 and, shifted up eight bits, the eight bits of C<op_private>, except that
6246 the bit with value 1 is automatically set.  C<dynamic_meth> supplies an
6247 op which evaluates method name; it is consumed by this function and
6248 become part of the constructed op tree.
6249 Supported optypes: C<OP_METHOD>.
6250
6251 =cut
6252 */
6253
6254 static OP*
6255 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
6256     dVAR;
6257     METHOP *methop;
6258
6259     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
6260         || type == OP_CUSTOM);
6261
6262     NewOp(1101, methop, 1, METHOP);
6263     if (dynamic_meth) {
6264         if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
6265         methop->op_flags = (U8)(flags | OPf_KIDS);
6266         methop->op_u.op_first = dynamic_meth;
6267         methop->op_private = (U8)(1 | (flags >> 8));
6268
6269         if (!OpHAS_SIBLING(dynamic_meth))
6270             OpLASTSIB_set(dynamic_meth, (OP*)methop);
6271     }
6272     else {
6273         assert(const_meth);
6274         methop->op_flags = (U8)(flags & ~OPf_KIDS);
6275         methop->op_u.op_meth_sv = const_meth;
6276         methop->op_private = (U8)(0 | (flags >> 8));
6277         methop->op_next = (OP*)methop;
6278     }
6279
6280 #ifdef USE_ITHREADS
6281     methop->op_rclass_targ = 0;
6282 #else
6283     methop->op_rclass_sv = NULL;
6284 #endif
6285
6286     OpTYPE_set(methop, type);
6287     return CHECKOP(type, methop);
6288 }
6289
6290 OP *
6291 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
6292     PERL_ARGS_ASSERT_NEWMETHOP;
6293     return newMETHOP_internal(type, flags, dynamic_meth, NULL);
6294 }
6295
6296 /*
6297 =for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
6298
6299 Constructs, checks, and returns an op of method type with a constant
6300 method name.  C<type> is the opcode.  C<flags> gives the eight bits of
6301 C<op_flags>, and, shifted up eight bits, the eight bits of
6302 C<op_private>.  C<const_meth> supplies a constant method name;
6303 it must be a shared COW string.
6304 Supported optypes: C<OP_METHOD_NAMED>.
6305
6306 =cut
6307 */
6308
6309 OP *
6310 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
6311     PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
6312     return newMETHOP_internal(type, flags, NULL, const_meth);
6313 }
6314
6315 /*
6316 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
6317
6318 Constructs, checks, and returns an op of any binary type.  C<type>
6319 is the opcode.  C<flags> gives the eight bits of C<op_flags>, except
6320 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6321 the eight bits of C<op_private>, except that the bit with value 1 or
6322 2 is automatically set as required.  C<first> and C<last> supply up to
6323 two ops to be the direct children of the binary op; they are consumed
6324 by this function and become part of the constructed op tree.
6325
6326 =cut
6327 */
6328
6329 OP *
6330 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6331 {
6332     dVAR;
6333     BINOP *binop;
6334
6335     ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
6336         || type == OP_NULL || type == OP_CUSTOM);
6337
6338     NewOp(1101, binop, 1, BINOP);
6339
6340     if (!first)
6341         first = newOP(OP_NULL, 0);
6342
6343     OpTYPE_set(binop, type);
6344     binop->op_first = first;
6345     binop->op_flags = (U8)(flags | OPf_KIDS);
6346     if (!last) {
6347         last = first;
6348         binop->op_private = (U8)(1 | (flags >> 8));
6349     }
6350     else {
6351         binop->op_private = (U8)(2 | (flags >> 8));
6352         OpMORESIB_set(first, last);
6353     }
6354
6355     if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
6356         OpLASTSIB_set(last, (OP*)binop);
6357
6358     binop->op_last = OpSIBLING(binop->op_first);
6359     if (binop->op_last)
6360         OpLASTSIB_set(binop->op_last, (OP*)binop);
6361
6362     binop = (BINOP*)CHECKOP(type, binop);
6363     if (binop->op_next || binop->op_type != (OPCODE)type)
6364         return (OP*)binop;
6365
6366     return fold_constants(op_integerize(op_std_init((OP *)binop)));
6367 }
6368
6369 /* Helper function for S_pmtrans(): comparison function to sort an array
6370  * of codepoint range pairs. Sorts by start point, or if equal, by end
6371  * point */
6372
6373 static int uvcompare(const void *a, const void *b)
6374     __attribute__nonnull__(1)
6375     __attribute__nonnull__(2)
6376     __attribute__pure__;
6377 static int uvcompare(const void *a, const void *b)
6378 {
6379     if (*((const UV *)a) < (*(const UV *)b))
6380         return -1;
6381     if (*((const UV *)a) > (*(const UV *)b))
6382         return 1;
6383     if (*((const UV *)a+1) < (*(const UV *)b+1))
6384         return -1;
6385     if (*((const UV *)a+1) > (*(const UV *)b+1))
6386         return 1;
6387     return 0;
6388 }
6389
6390 /* Given an OP_TRANS / OP_TRANSR op o, plus OP_CONST ops expr and repl
6391  * containing the search and replacement strings, assemble into
6392  * a translation table attached as o->op_pv.
6393  * Free expr and repl.
6394  * It expects the toker to have already set the
6395  *   OPpTRANS_COMPLEMENT
6396  *   OPpTRANS_SQUASH
6397  *   OPpTRANS_DELETE
6398  * flags as appropriate; this function may add
6399  *   OPpTRANS_FROM_UTF
6400  *   OPpTRANS_TO_UTF
6401  *   OPpTRANS_IDENTICAL
6402  *   OPpTRANS_GROWS
6403  * flags
6404  */
6405
6406 static OP *
6407 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
6408 {
6409     SV * const tstr = ((SVOP*)expr)->op_sv;
6410     SV * const rstr = ((SVOP*)repl)->op_sv;
6411     STRLEN tlen;
6412     STRLEN rlen;
6413     const U8 *t = (U8*)SvPV_const(tstr, tlen);
6414     const U8 *r = (U8*)SvPV_const(rstr, rlen);
6415     Size_t i, j;
6416     bool grows = FALSE;
6417     OPtrans_map *tbl;
6418     SSize_t struct_size; /* malloced size of table struct */
6419
6420     const bool complement = cBOOL(o->op_private & OPpTRANS_COMPLEMENT);
6421     const bool squash     = cBOOL(o->op_private & OPpTRANS_SQUASH);
6422     const bool del        = cBOOL(o->op_private & OPpTRANS_DELETE);
6423     SV* swash;
6424
6425     PERL_ARGS_ASSERT_PMTRANS;
6426
6427     PL_hints |= HINT_BLOCK_SCOPE;
6428
6429     if (SvUTF8(tstr))
6430         o->op_private |= OPpTRANS_FROM_UTF;
6431
6432     if (SvUTF8(rstr))
6433         o->op_private |= OPpTRANS_TO_UTF;
6434
6435     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
6436
6437         /* for utf8 translations, op_sv will be set to point to a swash
6438          * containing codepoint ranges. This is done by first assembling
6439          * a textual representation of the ranges in listsv then compiling
6440          * it using swash_init(). For more details of the textual format,
6441          * see L<perlunicode.pod/"User-Defined Character Properties"> .
6442          */
6443
6444         SV* const listsv = newSVpvs("# comment\n");
6445         SV* transv = NULL;
6446         const U8* tend = t + tlen;
6447         const U8* rend = r + rlen;
6448         STRLEN ulen;
6449         UV tfirst = 1;
6450         UV tlast = 0;
6451         IV tdiff;
6452         STRLEN tcount = 0;
6453         UV rfirst = 1;
6454         UV rlast = 0;
6455         IV rdiff;
6456         STRLEN rcount = 0;
6457         IV diff;
6458         I32 none = 0;
6459         U32 max = 0;
6460         I32 bits;
6461         I32 havefinal = 0;
6462         U32 final = 0;
6463         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
6464         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
6465         U8* tsave = NULL;
6466         U8* rsave = NULL;
6467         const U32 flags = UTF8_ALLOW_DEFAULT;
6468
6469         if (!from_utf) {
6470             STRLEN len = tlen;
6471             t = tsave = bytes_to_utf8(t, &len);
6472             tend = t + len;
6473         }
6474         if (!to_utf && rlen) {
6475             STRLEN len = rlen;
6476             r = rsave = bytes_to_utf8(r, &len);
6477             rend = r + len;
6478         }
6479
6480 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
6481  * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
6482  * odd.  */
6483
6484         if (complement) {
6485             /* utf8 and /c:
6486              * replace t/tlen/tend with a version that has the ranges
6487              * complemented
6488              */
6489             U8 tmpbuf[UTF8_MAXBYTES+1];
6490             UV *cp;
6491             UV nextmin = 0;
6492             Newx(cp, 2*tlen, UV);
6493             i = 0;
6494             transv = newSVpvs("");
6495
6496             /* convert search string into array of (start,end) range
6497              * codepoint pairs stored in cp[]. Most "ranges" will start
6498              * and end at the same char */
6499             while (t < tend) {
6500                 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
6501                 t += ulen;
6502                 /* the toker converts X-Y into (X, ILLEGAL_UTF8_BYTE, Y) */
6503                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
6504                     t++;
6505                     cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
6506                     t += ulen;
6507                 }
6508                 else {
6509                  cp[2*i+1] = cp[2*i];
6510                 }
6511                 i++;
6512             }
6513
6514             /* sort the ranges */
6515             qsort(cp, i, 2*sizeof(UV), uvcompare);
6516
6517             /* Create a utf8 string containing the complement of the
6518              * codepoint ranges. For example if cp[] contains [A,B], [C,D],
6519              * then transv will contain the equivalent of:
6520              * join '', map chr, 0,     ILLEGAL_UTF8_BYTE, A - 1,
6521              *                   B + 1, ILLEGAL_UTF8_BYTE, C - 1,
6522              *                   D + 1, ILLEGAL_UTF8_BYTE, 0x7fffffff;
6523              * A range of a single char skips the ILLEGAL_UTF8_BYTE and
6524              * end cp.
6525              */
6526             for (j = 0; j < i; j++) {
6527                 UV  val = cp[2*j];
6528                 diff = val - nextmin;
6529                 if (diff > 0) {
6530                     t = uvchr_to_utf8(tmpbuf,nextmin);
6531                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6532                     if (diff > 1) {
6533                         U8  range_mark = ILLEGAL_UTF8_BYTE;
6534                         t = uvchr_to_utf8(tmpbuf, val - 1);
6535                         sv_catpvn(transv, (char *)&range_mark, 1);
6536                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6537                     }
6538                 }
6539                 val = cp[2*j+1];
6540                 if (val >= nextmin)
6541                     nextmin = val + 1;
6542             }
6543
6544             t = uvchr_to_utf8(tmpbuf,nextmin);
6545             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6546             {
6547                 U8 range_mark = ILLEGAL_UTF8_BYTE;
6548                 sv_catpvn(transv, (char *)&range_mark, 1);
6549             }
6550             t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
6551             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6552             t = (const U8*)SvPVX_const(transv);
6553             tlen = SvCUR(transv);
6554             tend = t + tlen;
6555             Safefree(cp);
6556         }
6557         else if (!rlen && !del) {
6558             r = t; rlen = tlen; rend = tend;
6559         }
6560
6561         if (!squash) {
6562                 if ((!rlen && !del) || t == r ||
6563                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
6564                 {
6565                     o->op_private |= OPpTRANS_IDENTICAL;
6566                 }
6567         }
6568
6569         /* extract char ranges from t and r and append them to listsv */
6570
6571         while (t < tend || tfirst <= tlast) {
6572             /* see if we need more "t" chars */
6573             if (tfirst > tlast) {
6574                 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
6575                 t += ulen;
6576                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {      /* illegal utf8 val indicates range */
6577                     t++;
6578                     tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
6579                     t += ulen;
6580                 }
6581                 else
6582                     tlast = tfirst;
6583             }
6584
6585             /* now see if we need more "r" chars */
6586             if (rfirst > rlast) {
6587                 if (r < rend) {
6588                     rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
6589                     r += ulen;
6590                     if (r < rend && *r == ILLEGAL_UTF8_BYTE) {  /* illegal utf8 val indicates range */
6591                         r++;
6592                         rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
6593                         r += ulen;
6594                     }
6595                     else
6596                         rlast = rfirst;
6597                 }
6598                 else {
6599                     if (!havefinal++)
6600                         final = rlast;
6601                     rfirst = rlast = 0xffffffff;
6602                 }
6603             }
6604
6605             /* now see which range will peter out first, if either. */
6606             tdiff = tlast - tfirst;
6607             rdiff = rlast - rfirst;
6608             tcount += tdiff + 1;
6609             rcount += rdiff + 1;
6610
6611             if (tdiff <= rdiff)
6612                 diff = tdiff;
6613             else
6614                 diff = rdiff;
6615
6616             if (rfirst == 0xffffffff) {
6617                 diff = tdiff;   /* oops, pretend rdiff is infinite */
6618                 if (diff > 0)
6619                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
6620                                    (long)tfirst, (long)tlast);
6621                 else
6622                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
6623             }
6624             else {
6625                 if (diff > 0)
6626                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
6627                                    (long)tfirst, (long)(tfirst + diff),
6628                                    (long)rfirst);
6629                 else
6630                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
6631                                    (long)tfirst, (long)rfirst);
6632
6633                 if (rfirst + diff > max)
6634                     max = rfirst + diff;
6635                 if (!grows)
6636                     grows = (tfirst < rfirst &&
6637                              UVCHR_SKIP(tfirst) < UVCHR_SKIP(rfirst + diff));
6638                 rfirst += diff + 1;
6639             }
6640             tfirst += diff + 1;
6641         }
6642
6643         /* compile listsv into a swash and attach to o */
6644
6645         none = ++max;
6646         if (del)
6647             ++max;
6648
6649         if (max > 0xffff)
6650             bits = 32;
6651         else if (max > 0xff)
6652             bits = 16;
6653         else
6654             bits = 8;
6655
6656         swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
6657 #ifdef USE_ITHREADS
6658         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
6659         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
6660         PAD_SETSV(cPADOPo->op_padix, swash);
6661         SvPADTMP_on(swash);
6662         SvREADONLY_on(swash);
6663 #else
6664         cSVOPo->op_sv = swash;
6665 #endif
6666         SvREFCNT_dec(listsv);
6667         SvREFCNT_dec(transv);
6668
6669         if (!del && havefinal && rlen)
6670             (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
6671                            newSVuv((UV)final), 0);
6672
6673         Safefree(tsave);
6674         Safefree(rsave);
6675
6676         tlen = tcount;
6677         rlen = rcount;
6678         if (r < rend)
6679             rlen++;
6680         else if (rlast == 0xffffffff)
6681             rlen = 0;
6682
6683         goto warnins;
6684     }
6685
6686     /* Non-utf8 case: set o->op_pv to point to a simple 256+ entry lookup
6687      * table. Entries with the value -1 indicate chars not to be
6688      * translated, while -2 indicates a search char without a
6689      * corresponding replacement char under /d.
6690      *
6691      * Normally, the table has 256 slots. However, in the presence of
6692      * /c, the search charlist has an implicit \x{100}-\x{7fffffff}
6693      * added, and if there are enough replacement chars to start pairing
6694      * with the \x{100},... search chars, then a larger (> 256) table
6695      * is allocated.
6696      *
6697      * In addition, regardless of whether under /c, an extra slot at the
6698      * end is used to store the final repeating char, or -3 under an empty
6699      * replacement list, or -2 under /d; which makes the runtime code
6700      * easier.
6701      *
6702      * The toker will have already expanded char ranges in t and r.
6703      */
6704
6705     /* Initially allocate 257-slot table: 256 for basic (non /c) usage,
6706      * plus final slot for repeat/-2/-3. Later we realloc if excess > * 0.
6707      * The OPtrans_map struct already contains one slot; hence the -1.
6708      */
6709     struct_size = sizeof(OPtrans_map) + (256 - 1 + 1)*sizeof(short);
6710     tbl = (OPtrans_map*)PerlMemShared_calloc(struct_size, 1);
6711     tbl->size = 256;
6712     cPVOPo->op_pv = (char*)tbl;
6713
6714     if (complement) {
6715         Size_t excess;
6716
6717         /* in this branch, j is a count of 'consumed' (i.e. paired off
6718          * with a search char) replacement chars (so j <= rlen always)
6719          */
6720         for (i = 0; i < tlen; i++)
6721             tbl->map[t[i]] = -1;
6722
6723         for (i = 0, j = 0; i < 256; i++) {
6724             if (!tbl->map[i]) {
6725                 if (j == rlen) {
6726                     if (del)
6727                         tbl->map[i] = -2;
6728                     else if (rlen)
6729                         tbl->map[i] = r[j-1];
6730                     else
6731                         tbl->map[i] = (short)i;
6732                 }
6733                 else {
6734                     tbl->map[i] = r[j++];
6735                 }
6736                 if (   tbl->map[i] >= 0
6737                     &&  UVCHR_IS_INVARIANT((UV)i)
6738                     && !UVCHR_IS_INVARIANT((UV)(tbl->map[i]))
6739                 )
6740                     grows = TRUE;
6741             }
6742         }
6743
6744         ASSUME(j <= rlen);
6745         excess = rlen - j;
6746
6747         if (excess) {
6748             /* More replacement chars than search chars:
6749              * store excess replacement chars at end of main table.
6750              */
6751
6752             struct_size += excess;
6753             tbl = (OPtrans_map*)PerlMemShared_realloc(tbl,
6754                         struct_size + excess * sizeof(short));
6755             tbl->size += excess;
6756             cPVOPo->op_pv = (char*)tbl;
6757
6758             for (i = 0; i < excess; i++)
6759                 tbl->map[i + 256] = r[j+i];
6760         }
6761         else {
6762             /* no more replacement chars than search chars */
6763             if (!rlen && !del && !squash)
6764                 o->op_private |= OPpTRANS_IDENTICAL;
6765         }
6766
6767         tbl->map[tbl->size] = del ? -2 : rlen ? r[rlen - 1] : -3;
6768     }
6769     else {
6770         if (!rlen && !del) {
6771             r = t; rlen = tlen;
6772             if (!squash)
6773                 o->op_private |= OPpTRANS_IDENTICAL;
6774         }
6775         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
6776             o->op_private |= OPpTRANS_IDENTICAL;
6777         }
6778
6779         for (i = 0; i < 256; i++)
6780             tbl->map[i] = -1;
6781         for (i = 0, j = 0; i < tlen; i++,j++) {
6782             if (j >= rlen) {
6783                 if (del) {
6784                     if (tbl->map[t[i]] == -1)
6785                         tbl->map[t[i]] = -2;
6786                     continue;
6787                 }
6788                 --j;
6789             }
6790             if (tbl->map[t[i]] == -1) {
6791                 if (     UVCHR_IS_INVARIANT(t[i])
6792                     && ! UVCHR_IS_INVARIANT(r[j]))
6793                     grows = TRUE;
6794                 tbl->map[t[i]] = r[j];
6795             }
6796         }
6797         tbl->map[tbl->size] = del ? -1 : rlen ? -1 : -3;
6798     }
6799
6800     /* both non-utf8 and utf8 code paths end up here */
6801
6802   warnins:
6803     if(del && rlen == tlen) {
6804         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
6805     } else if(rlen > tlen && !complement) {
6806         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
6807     }
6808
6809     if (grows)
6810         o->op_private |= OPpTRANS_GROWS;
6811     op_free(expr);
6812     op_free(repl);
6813
6814     return o;
6815 }
6816
6817
6818 /*
6819 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
6820
6821 Constructs, checks, and returns an op of any pattern matching type.
6822 C<type> is the opcode.  C<flags> gives the eight bits of C<op_flags>
6823 and, shifted up eight bits, the eight bits of C<op_private>.
6824
6825 =cut
6826 */
6827
6828 OP *
6829 Perl_newPMOP(pTHX_ I32 type, I32 flags)
6830 {
6831     dVAR;
6832     PMOP *pmop;
6833
6834     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
6835         || type == OP_CUSTOM);
6836
6837     NewOp(1101, pmop, 1, PMOP);
6838     OpTYPE_set(pmop, type);
6839     pmop->op_flags = (U8)flags;
6840     pmop->op_private = (U8)(0 | (flags >> 8));
6841     if (PL_opargs[type] & OA_RETSCALAR)
6842         scalar((OP *)pmop);
6843
6844     if (PL_hints & HINT_RE_TAINT)
6845         pmop->op_pmflags |= PMf_RETAINT;
6846 #ifdef USE_LOCALE_CTYPE
6847     if (IN_LC_COMPILETIME(LC_CTYPE)) {
6848         set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
6849     }
6850     else
6851 #endif
6852          if (IN_UNI_8_BIT) {
6853         set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
6854     }
6855     if (PL_hints & HINT_RE_FLAGS) {
6856         SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
6857          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
6858         );
6859         if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
6860         reflags = Perl_refcounted_he_fetch_pvn(aTHX_
6861          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
6862         );
6863         if (reflags && SvOK(reflags)) {
6864             set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
6865         }
6866     }
6867
6868
6869 #ifdef USE_ITHREADS
6870     assert(SvPOK(PL_regex_pad[0]));
6871     if (SvCUR(PL_regex_pad[0])) {
6872         /* Pop off the "packed" IV from the end.  */
6873         SV *const repointer_list = PL_regex_pad[0];
6874         const char *p = SvEND(repointer_list) - sizeof(IV);
6875         const IV offset = *((IV*)p);
6876
6877         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
6878
6879         SvEND_set(repointer_list, p);
6880
6881         pmop->op_pmoffset = offset;
6882         /* This slot should be free, so assert this:  */
6883         assert(PL_regex_pad[offset] == &PL_sv_undef);
6884     } else {
6885         SV * const repointer = &PL_sv_undef;
6886         av_push(PL_regex_padav, repointer);
6887         pmop->op_pmoffset = av_tindex(PL_regex_padav);
6888         PL_regex_pad = AvARRAY(PL_regex_padav);
6889     }
6890 #endif
6891
6892     return CHECKOP(type, pmop);
6893 }
6894
6895 static void
6896 S_set_haseval(pTHX)
6897 {
6898     PADOFFSET i = 1;
6899     PL_cv_has_eval = 1;
6900     /* Any pad names in scope are potentially lvalues.  */
6901     for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
6902         PADNAME *pn = PAD_COMPNAME_SV(i);
6903         if (!pn || !PadnameLEN(pn))
6904             continue;
6905         if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
6906             S_mark_padname_lvalue(aTHX_ pn);
6907     }
6908 }
6909
6910 /* Given some sort of match op o, and an expression expr containing a
6911  * pattern, either compile expr into a regex and attach it to o (if it's
6912  * constant), or convert expr into a runtime regcomp op sequence (if it's
6913  * not)
6914  *
6915  * Flags currently has 2 bits of meaning:
6916  * 1: isreg indicates that the pattern is part of a regex construct, eg
6917  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
6918  * split "pattern", which aren't. In the former case, expr will be a list
6919  * if the pattern contains more than one term (eg /a$b/).
6920  * 2: The pattern is for a split.
6921  *
6922  * When the pattern has been compiled within a new anon CV (for
6923  * qr/(?{...})/ ), then floor indicates the savestack level just before
6924  * the new sub was created
6925  */
6926
6927 OP *
6928 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor)
6929 {
6930     PMOP *pm;
6931     LOGOP *rcop;
6932     I32 repl_has_vars = 0;
6933     bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
6934     bool is_compiletime;
6935     bool has_code;
6936     bool isreg    = cBOOL(flags & 1);
6937     bool is_split = cBOOL(flags & 2);
6938
6939     PERL_ARGS_ASSERT_PMRUNTIME;
6940
6941     if (is_trans) {
6942         return pmtrans(o, expr, repl);
6943     }
6944
6945     /* find whether we have any runtime or code elements;
6946      * at the same time, temporarily set the op_next of each DO block;
6947      * then when we LINKLIST, this will cause the DO blocks to be excluded
6948      * from the op_next chain (and from having LINKLIST recursively
6949      * applied to them). We fix up the DOs specially later */
6950
6951     is_compiletime = 1;
6952     has_code = 0;
6953     if (expr->op_type == OP_LIST) {
6954         OP *o;
6955         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
6956             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
6957                 has_code = 1;
6958                 assert(!o->op_next);
6959                 if (UNLIKELY(!OpHAS_SIBLING(o))) {
6960                     assert(PL_parser && PL_parser->error_count);
6961                     /* This can happen with qr/ (?{(^{})/.  Just fake up
6962                        the op we were expecting to see, to avoid crashing
6963                        elsewhere.  */
6964                     op_sibling_splice(expr, o, 0,
6965                                       newSVOP(OP_CONST, 0, &PL_sv_no));
6966                 }
6967                 o->op_next = OpSIBLING(o);
6968             }
6969             else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
6970                 is_compiletime = 0;
6971         }
6972     }
6973     else if (expr->op_type != OP_CONST)
6974         is_compiletime = 0;
6975
6976     LINKLIST(expr);
6977
6978     /* fix up DO blocks; treat each one as a separate little sub;
6979      * also, mark any arrays as LIST/REF */
6980
6981     if (expr->op_type == OP_LIST) {
6982         OP *o;
6983         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
6984
6985             if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
6986                 assert( !(o->op_flags  & OPf_WANT));
6987                 /* push the array rather than its contents. The regex
6988                  * engine will retrieve and join the elements later */
6989                 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
6990                 continue;
6991             }
6992
6993             if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
6994                 continue;
6995             o->op_next = NULL; /* undo temporary hack from above */
6996             scalar(o);
6997             LINKLIST(o);
6998             if (cLISTOPo->op_first->op_type == OP_LEAVE) {
6999                 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
7000                 /* skip ENTER */
7001                 assert(leaveop->op_first->op_type == OP_ENTER);
7002                 assert(OpHAS_SIBLING(leaveop->op_first));
7003                 o->op_next = OpSIBLING(leaveop->op_first);
7004                 /* skip leave */
7005                 assert(leaveop->op_flags & OPf_KIDS);
7006                 assert(leaveop->op_last->op_next == (OP*)leaveop);
7007                 leaveop->op_next = NULL; /* stop on last op */
7008                 op_null((OP*)leaveop);
7009             }
7010             else {
7011                 /* skip SCOPE */
7012                 OP *scope = cLISTOPo->op_first;
7013                 assert(scope->op_type == OP_SCOPE);
7014                 assert(scope->op_flags & OPf_KIDS);
7015                 scope->op_next = NULL; /* stop on last op */
7016                 op_null(scope);
7017             }
7018
7019             /* XXX optimize_optree() must be called on o before
7020              * CALL_PEEP(), as currently S_maybe_multiconcat() can't
7021              * currently cope with a peephole-optimised optree.
7022              * Calling optimize_optree() here ensures that condition
7023              * is met, but may mean optimize_optree() is applied
7024              * to the same optree later (where hopefully it won't do any
7025              * harm as it can't convert an op to multiconcat if it's
7026              * already been converted */
7027             optimize_optree(o);
7028
7029             /* have to peep the DOs individually as we've removed it from
7030              * the op_next chain */
7031             CALL_PEEP(o);
7032             S_prune_chain_head(&(o->op_next));
7033             if (is_compiletime)
7034                 /* runtime finalizes as part of finalizing whole tree */
7035                 finalize_optree(o);
7036         }
7037     }
7038     else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
7039         assert( !(expr->op_flags  & OPf_WANT));
7040         /* push the array rather than its contents. The regex
7041          * engine will retrieve and join the elements later */
7042         expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
7043     }
7044
7045     PL_hints |= HINT_BLOCK_SCOPE;
7046     pm = (PMOP*)o;
7047     assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
7048
7049     if (is_compiletime) {
7050         U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
7051         regexp_engine const *eng = current_re_engine();
7052
7053         if (is_split) {
7054             /* make engine handle split ' ' specially */
7055             pm->op_pmflags |= PMf_SPLIT;
7056             rx_flags |= RXf_SPLIT;
7057         }
7058
7059         /* Skip compiling if parser found an error for this pattern */
7060         if (pm->op_pmflags & PMf_HAS_ERROR) {
7061             return o;
7062         }
7063
7064         if (!has_code || !eng->op_comp) {
7065             /* compile-time simple constant pattern */
7066
7067             if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
7068                 /* whoops! we guessed that a qr// had a code block, but we
7069                  * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
7070                  * that isn't required now. Note that we have to be pretty
7071                  * confident that nothing used that CV's pad while the
7072                  * regex was parsed, except maybe op targets for \Q etc.
7073                  * If there were any op targets, though, they should have
7074                  * been stolen by constant folding.
7075                  */
7076 #ifdef DEBUGGING
7077                 SSize_t i = 0;
7078                 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
7079                 while (++i <= AvFILLp(PL_comppad)) {
7080 #  ifdef USE_PAD_RESET
7081                     /* under USE_PAD_RESET, pad swipe replaces a swiped
7082                      * folded constant with a fresh padtmp */
7083                     assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i]));
7084 #  else
7085                     assert(!PL_curpad[i]);
7086 #  endif
7087                 }
7088 #endif
7089                 /* But we know that one op is using this CV's slab. */
7090                 cv_forget_slab(PL_compcv);
7091                 LEAVE_SCOPE(floor);
7092                 pm->op_pmflags &= ~PMf_HAS_CV;
7093             }
7094
7095             PM_SETRE(pm,
7096                 eng->op_comp
7097                     ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7098                                         rx_flags, pm->op_pmflags)
7099                     : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7100                                         rx_flags, pm->op_pmflags)
7101             );
7102             op_free(expr);
7103         }
7104         else {
7105             /* compile-time pattern that includes literal code blocks */
7106             REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7107                         rx_flags,
7108                         (pm->op_pmflags |
7109                             ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
7110                     );
7111             PM_SETRE(pm, re);
7112             if (pm->op_pmflags & PMf_HAS_CV) {
7113                 CV *cv;
7114                 /* this QR op (and the anon sub we embed it in) is never
7115                  * actually executed. It's just a placeholder where we can
7116                  * squirrel away expr in op_code_list without the peephole
7117                  * optimiser etc processing it for a second time */
7118                 OP *qr = newPMOP(OP_QR, 0);
7119                 ((PMOP*)qr)->op_code_list = expr;
7120
7121                 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
7122                 SvREFCNT_inc_simple_void(PL_compcv);
7123                 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
7124                 ReANY(re)->qr_anoncv = cv;
7125
7126                 /* attach the anon CV to the pad so that
7127                  * pad_fixup_inner_anons() can find it */
7128                 (void)pad_add_anon(cv, o->op_type);
7129                 SvREFCNT_inc_simple_void(cv);
7130             }
7131             else {
7132                 pm->op_code_list = expr;
7133             }
7134         }
7135     }
7136     else {
7137         /* runtime pattern: build chain of regcomp etc ops */
7138         bool reglist;
7139         PADOFFSET cv_targ = 0;
7140
7141         reglist = isreg && expr->op_type == OP_LIST;
7142         if (reglist)
7143             op_null(expr);
7144
7145         if (has_code) {
7146             pm->op_code_list = expr;
7147             /* don't free op_code_list; its ops are embedded elsewhere too */
7148             pm->op_pmflags |= PMf_CODELIST_PRIVATE;
7149         }
7150
7151         if (is_split)
7152             /* make engine handle split ' ' specially */
7153             pm->op_pmflags |= PMf_SPLIT;
7154
7155         /* the OP_REGCMAYBE is a placeholder in the non-threaded case
7156          * to allow its op_next to be pointed past the regcomp and
7157          * preceding stacking ops;
7158          * OP_REGCRESET is there to reset taint before executing the
7159          * stacking ops */
7160         if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
7161             expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
7162
7163         if (pm->op_pmflags & PMf_HAS_CV) {
7164             /* we have a runtime qr with literal code. This means
7165              * that the qr// has been wrapped in a new CV, which
7166              * means that runtime consts, vars etc will have been compiled
7167              * against a new pad. So... we need to execute those ops
7168              * within the environment of the new CV. So wrap them in a call
7169              * to a new anon sub. i.e. for
7170              *
7171              *     qr/a$b(?{...})/,
7172              *
7173              * we build an anon sub that looks like
7174              *
7175              *     sub { "a", $b, '(?{...})' }
7176              *
7177              * and call it, passing the returned list to regcomp.
7178              * Or to put it another way, the list of ops that get executed
7179              * are:
7180              *
7181              *     normal              PMf_HAS_CV
7182              *     ------              -------------------
7183              *                         pushmark (for regcomp)
7184              *                         pushmark (for entersub)
7185              *                         anoncode
7186              *                         srefgen
7187              *                         entersub
7188              *     regcreset                  regcreset
7189              *     pushmark                   pushmark
7190              *     const("a")                 const("a")
7191              *     gvsv(b)                    gvsv(b)
7192              *     const("(?{...})")          const("(?{...})")
7193              *                                leavesub
7194              *     regcomp             regcomp
7195              */
7196
7197             SvREFCNT_inc_simple_void(PL_compcv);
7198             CvLVALUE_on(PL_compcv);
7199             /* these lines are just an unrolled newANONATTRSUB */
7200             expr = newSVOP(OP_ANONCODE, 0,
7201                     MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
7202             cv_targ = expr->op_targ;
7203             expr = newUNOP(OP_REFGEN, 0, expr);
7204
7205             expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
7206         }
7207
7208         rcop = alloc_LOGOP(OP_REGCOMP, scalar(expr), o);
7209         rcop->op_flags |=  ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
7210                            | (reglist ? OPf_STACKED : 0);
7211         rcop->op_targ = cv_targ;
7212
7213         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
7214         if (PL_hints & HINT_RE_EVAL)
7215             S_set_haseval(aTHX);
7216
7217         /* establish postfix order */
7218         if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
7219             LINKLIST(expr);
7220             rcop->op_next = expr;
7221             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
7222         }
7223         else {
7224             rcop->op_next = LINKLIST(expr);
7225             expr->op_next = (OP*)rcop;
7226         }
7227
7228         op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
7229     }
7230
7231     if (repl) {
7232         OP *curop = repl;
7233         bool konst;
7234         /* If we are looking at s//.../e with a single statement, get past
7235            the implicit do{}. */
7236         if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
7237              && cUNOPx(curop)->op_first->op_type == OP_SCOPE
7238              && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
7239          {
7240             OP *sib;
7241             OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
7242             if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
7243              && !OpHAS_SIBLING(sib))
7244                 curop = sib;
7245         }
7246         if (curop->op_type == OP_CONST)
7247             konst = TRUE;
7248         else if (( (curop->op_type == OP_RV2SV ||
7249                     curop->op_type == OP_RV2AV ||
7250                     curop->op_type == OP_RV2HV ||
7251                     curop->op_type == OP_RV2GV)
7252                    && cUNOPx(curop)->op_first
7253                    && cUNOPx(curop)->op_first->op_type == OP_GV )
7254                 || curop->op_type == OP_PADSV
7255                 || curop->op_type == OP_PADAV
7256                 || curop->op_type == OP_PADHV
7257                 || curop->op_type == OP_PADANY) {
7258             repl_has_vars = 1;
7259             konst = TRUE;
7260         }
7261         else konst = FALSE;
7262         if (konst
7263             && !(repl_has_vars
7264                  && (!PM_GETRE(pm)
7265                      || !RX_PRELEN(PM_GETRE(pm))
7266                      || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
7267         {
7268             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
7269             op_prepend_elem(o->op_type, scalar(repl), o);
7270         }
7271         else {
7272             rcop = alloc_LOGOP(OP_SUBSTCONT, scalar(repl), o);
7273             rcop->op_private = 1;
7274
7275             /* establish postfix order */
7276             rcop->op_next = LINKLIST(repl);
7277             repl->op_next = (OP*)rcop;
7278
7279             pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
7280             assert(!(pm->op_pmflags & PMf_ONCE));
7281             pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
7282             rcop->op_next = 0;
7283         }
7284     }
7285
7286     return (OP*)pm;
7287 }
7288
7289 /*
7290 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
7291
7292 Constructs, checks, and returns an op of any type that involves an
7293 embedded SV.  C<type> is the opcode.  C<flags> gives the eight bits
7294 of C<op_flags>.  C<sv> gives the SV to embed in the op; this function
7295 takes ownership of one reference to it.
7296
7297 =cut
7298 */
7299
7300 OP *
7301 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
7302 {
7303     dVAR;
7304     SVOP *svop;
7305
7306     PERL_ARGS_ASSERT_NEWSVOP;
7307
7308     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
7309         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7310         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
7311         || type == OP_CUSTOM);
7312
7313     NewOp(1101, svop, 1, SVOP);
7314     OpTYPE_set(svop, type);
7315     svop->op_sv = sv;
7316     svop->op_next = (OP*)svop;
7317     svop->op_flags = (U8)flags;
7318     svop->op_private = (U8)(0 | (flags >> 8));
7319     if (PL_opargs[type] & OA_RETSCALAR)
7320         scalar((OP*)svop);
7321     if (PL_opargs[type] & OA_TARGET)
7322         svop->op_targ = pad_alloc(type, SVs_PADTMP);
7323     return CHECKOP(type, svop);
7324 }
7325
7326 /*
7327 =for apidoc Am|OP *|newDEFSVOP|
7328
7329 Constructs and returns an op to access C<$_>.
7330
7331 =cut
7332 */
7333
7334 OP *
7335 Perl_newDEFSVOP(pTHX)
7336 {
7337         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
7338 }
7339
7340 #ifdef USE_ITHREADS
7341
7342 /*
7343 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
7344
7345 Constructs, checks, and returns an op of any type that involves a
7346 reference to a pad element.  C<type> is the opcode.  C<flags> gives the
7347 eight bits of C<op_flags>.  A pad slot is automatically allocated, and
7348 is populated with C<sv>; this function takes ownership of one reference
7349 to it.
7350
7351 This function only exists if Perl has been compiled to use ithreads.
7352
7353 =cut
7354 */
7355
7356 OP *
7357 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
7358 {
7359     dVAR;
7360     PADOP *padop;
7361
7362     PERL_ARGS_ASSERT_NEWPADOP;
7363
7364     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
7365         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7366         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
7367         || type == OP_CUSTOM);
7368
7369     NewOp(1101, padop, 1, PADOP);
7370     OpTYPE_set(padop, type);
7371     padop->op_padix =
7372         pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
7373     SvREFCNT_dec(PAD_SVl(padop->op_padix));
7374     PAD_SETSV(padop->op_padix, sv);
7375     assert(sv);
7376     padop->op_next = (OP*)padop;
7377     padop->op_flags = (U8)flags;
7378     if (PL_opargs[type] & OA_RETSCALAR)
7379         scalar((OP*)padop);
7380     if (PL_opargs[type] & OA_TARGET)
7381         padop->op_targ = pad_alloc(type, SVs_PADTMP);
7382     return CHECKOP(type, padop);
7383 }
7384
7385 #endif /* USE_ITHREADS */
7386
7387 /*
7388 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
7389
7390 Constructs, checks, and returns an op of any type that involves an
7391 embedded reference to a GV.  C<type> is the opcode.  C<flags> gives the
7392 eight bits of C<op_flags>.  C<gv> identifies the GV that the op should
7393 reference; calling this function does not transfer ownership of any
7394 reference to it.
7395
7396 =cut
7397 */
7398
7399 OP *
7400 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
7401 {
7402     PERL_ARGS_ASSERT_NEWGVOP;
7403
7404 #ifdef USE_ITHREADS
7405     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
7406 #else
7407     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
7408 #endif
7409 }
7410
7411 /*
7412 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
7413
7414 Constructs, checks, and returns an op of any type that involves an
7415 embedded C-level pointer (PV).  C<type> is the opcode.  C<flags> gives
7416 the eight bits of C<op_flags>.  C<pv> supplies the C-level pointer.
7417 Depending on the op type, the memory referenced by C<pv> may be freed
7418 when the op is destroyed.  If the op is of a freeing type, C<pv> must
7419 have been allocated using C<PerlMemShared_malloc>.
7420
7421 =cut
7422 */
7423
7424 OP *
7425 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
7426 {
7427     dVAR;
7428     const bool utf8 = cBOOL(flags & SVf_UTF8);
7429     PVOP *pvop;
7430
7431     flags &= ~SVf_UTF8;
7432
7433     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7434         || type == OP_RUNCV || type == OP_CUSTOM
7435         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
7436
7437     NewOp(1101, pvop, 1, PVOP);
7438     OpTYPE_set(pvop, type);
7439     pvop->op_pv = pv;
7440     pvop->op_next = (OP*)pvop;
7441     pvop->op_flags = (U8)flags;
7442     pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
7443     if (PL_opargs[type] & OA_RETSCALAR)
7444         scalar((OP*)pvop);
7445     if (PL_opargs[type] & OA_TARGET)
7446         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
7447     return CHECKOP(type, pvop);
7448 }
7449
7450 void
7451 Perl_package(pTHX_ OP *o)
7452 {
7453     SV *const sv = cSVOPo->op_sv;
7454
7455     PERL_ARGS_ASSERT_PACKAGE;
7456
7457     SAVEGENERICSV(PL_curstash);
7458     save_item(PL_curstname);
7459
7460     PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
7461
7462     sv_setsv(PL_curstname, sv);
7463
7464     PL_hints |= HINT_BLOCK_SCOPE;
7465     PL_parser->copline = NOLINE;
7466
7467     op_free(o);
7468 }
7469
7470 void
7471 Perl_package_version( pTHX_ OP *v )
7472 {
7473     U32 savehints = PL_hints;
7474     PERL_ARGS_ASSERT_PACKAGE_VERSION;
7475     PL_hints &= ~HINT_STRICT_VARS;
7476     sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
7477     PL_hints = savehints;
7478     op_free(v);
7479 }
7480
7481 void
7482 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
7483 {
7484     OP *pack;
7485     OP *imop;
7486     OP *veop;
7487     SV *use_version = NULL;
7488
7489     PERL_ARGS_ASSERT_UTILIZE;
7490
7491     if (idop->op_type != OP_CONST)
7492         Perl_croak(aTHX_ "Module name must be constant");
7493
7494     veop = NULL;
7495
7496     if (version) {
7497         SV * const vesv = ((SVOP*)version)->op_sv;
7498
7499         if (!arg && !SvNIOKp(vesv)) {
7500             arg = version;
7501         }
7502         else {
7503             OP *pack;
7504             SV *meth;
7505
7506             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
7507                 Perl_croak(aTHX_ "Version number must be a constant number");
7508
7509             /* Make copy of idop so we don't free it twice */
7510             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
7511
7512             /* Fake up a method call to VERSION */
7513             meth = newSVpvs_share("VERSION");
7514             veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
7515                             op_append_elem(OP_LIST,
7516                                         op_prepend_elem(OP_LIST, pack, version),
7517                                         newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
7518         }
7519     }
7520
7521     /* Fake up an import/unimport */
7522     if (arg && arg->op_type == OP_STUB) {
7523         imop = arg;             /* no import on explicit () */
7524     }
7525     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
7526         imop = NULL;            /* use 5.0; */
7527         if (aver)
7528             use_version = ((SVOP*)idop)->op_sv;
7529         else
7530             idop->op_private |= OPpCONST_NOVER;
7531     }
7532     else {
7533         SV *meth;
7534
7535         /* Make copy of idop so we don't free it twice */
7536         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
7537
7538         /* Fake up a method call to import/unimport */
7539         meth = aver
7540             ? newSVpvs_share("import") : newSVpvs_share("unimport");
7541         imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
7542                        op_append_elem(OP_LIST,
7543                                    op_prepend_elem(OP_LIST, pack, arg),
7544                                    newMETHOP_named(OP_METHOD_NAMED, 0, meth)
7545                        ));
7546     }
7547
7548     /* Fake up the BEGIN {}, which does its thing immediately. */
7549     newATTRSUB(floor,
7550         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
7551         NULL,
7552         NULL,
7553         op_append_elem(OP_LINESEQ,
7554             op_append_elem(OP_LINESEQ,
7555                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
7556                 newSTATEOP(0, NULL, veop)),
7557             newSTATEOP(0, NULL, imop) ));
7558
7559     if (use_version) {
7560         /* Enable the
7561          * feature bundle that corresponds to the required version. */
7562         use_version = sv_2mortal(new_version(use_version));
7563         S_enable_feature_bundle(aTHX_ use_version);
7564
7565         /* If a version >= 5.11.0 is requested, strictures are on by default! */
7566         if (vcmp(use_version,
7567                  sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
7568             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
7569                 PL_hints |= HINT_STRICT_REFS;
7570             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
7571                 PL_hints |= HINT_STRICT_SUBS;
7572             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
7573                 PL_hints |= HINT_STRICT_VARS;
7574         }
7575         /* otherwise they are off */
7576         else {
7577             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
7578                 PL_hints &= ~HINT_STRICT_REFS;
7579             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
7580                 PL_hints &= ~HINT_STRICT_SUBS;
7581             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
7582                 PL_hints &= ~HINT_STRICT_VARS;
7583         }
7584     }
7585
7586     /* The "did you use incorrect case?" warning used to be here.
7587      * The problem is that on case-insensitive filesystems one
7588      * might get false positives for "use" (and "require"):
7589      * "use Strict" or "require CARP" will work.  This causes
7590      * portability problems for the script: in case-strict
7591      * filesystems the script will stop working.
7592      *
7593      * The "incorrect case" warning checked whether "use Foo"
7594      * imported "Foo" to your namespace, but that is wrong, too:
7595      * there is no requirement nor promise in the language that
7596      * a Foo.pm should or would contain anything in package "Foo".
7597      *
7598      * There is very little Configure-wise that can be done, either:
7599      * the case-sensitivity of the build filesystem of Perl does not
7600      * help in guessing the case-sensitivity of the runtime environment.
7601      */
7602
7603     PL_hints |= HINT_BLOCK_SCOPE;
7604     PL_parser->copline = NOLINE;
7605     COP_SEQMAX_INC; /* Purely for B::*'s benefit */
7606 }
7607
7608 /*
7609 =head1 Embedding Functions
7610
7611 =for apidoc load_module
7612
7613 Loads the module whose name is pointed to by the string part of C<name>.
7614 Note that the actual module name, not its filename, should be given.
7615 Eg, "Foo::Bar" instead of "Foo/Bar.pm". ver, if specified and not NULL,
7616 provides version semantics similar to C<use Foo::Bar VERSION>. The optional
7617 trailing arguments can be used to specify arguments to the module's C<import()>
7618 method, similar to C<use Foo::Bar VERSION LIST>; their precise handling depends
7619 on the flags. The flags argument is a bitwise-ORed collection of any of
7620 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
7621 (or 0 for no flags).
7622
7623 If C<PERL_LOADMOD_NOIMPORT> is set, the module is loaded as if with an empty
7624 import list, as in C<use Foo::Bar ()>; this is the only circumstance in which
7625 the trailing optional arguments may be omitted entirely. Otherwise, if
7626 C<PERL_LOADMOD_IMPORT_OPS> is set, the trailing arguments must consist of
7627 exactly one C<OP*>, containing the op tree that produces the relevant import
7628 arguments. Otherwise, the trailing arguments must all be C<SV*> values that
7629 will be used as import arguments; and the list must be terminated with C<(SV*)
7630 NULL>. If neither C<PERL_LOADMOD_NOIMPORT> nor C<PERL_LOADMOD_IMPORT_OPS> is
7631 set, the trailing C<NULL> pointer is needed even if no import arguments are
7632 desired. The reference count for each specified C<SV*> argument is
7633 decremented. In addition, the C<name> argument is modified.
7634
7635 If C<PERL_LOADMOD_DENY> is set, the module is loaded as if with C<no> rather
7636 than C<use>.
7637
7638 =cut */
7639
7640 void
7641 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
7642 {
7643     va_list args;
7644
7645     PERL_ARGS_ASSERT_LOAD_MODULE;
7646
7647     va_start(args, ver);
7648     vload_module(flags, name, ver, &args);
7649     va_end(args);
7650 }
7651
7652 #ifdef PERL_IMPLICIT_CONTEXT
7653 void
7654 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
7655 {
7656     dTHX;
7657     va_list args;
7658     PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
7659     va_start(args, ver);
7660     vload_module(flags, name, ver, &args);
7661     va_end(args);
7662 }
7663 #endif
7664
7665 void
7666 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
7667 {
7668     OP *veop, *imop;
7669     OP * const modname = newSVOP(OP_CONST, 0, name);
7670
7671     PERL_ARGS_ASSERT_VLOAD_MODULE;
7672
7673     modname->op_private |= OPpCONST_BARE;
7674     if (ver) {
7675         veop = newSVOP(OP_CONST, 0, ver);
7676     }
7677     else
7678         veop = NULL;
7679     if (flags & PERL_LOADMOD_NOIMPORT) {
7680         imop = sawparens(newNULLLIST());
7681     }
7682     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
7683         imop = va_arg(*args, OP*);
7684     }
7685     else {
7686         SV *sv;
7687         imop = NULL;
7688         sv = va_arg(*args, SV*);
7689         while (sv) {
7690             imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
7691             sv = va_arg(*args, SV*);
7692         }
7693     }
7694
7695     /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
7696      * that it has a PL_parser to play with while doing that, and also
7697      * that it doesn't mess with any existing parser, by creating a tmp
7698      * new parser with lex_start(). This won't actually be used for much,
7699      * since pp_require() will create another parser for the real work.
7700      * The ENTER/LEAVE pair protect callers from any side effects of use.  */
7701
7702     ENTER;
7703     SAVEVPTR(PL_curcop);
7704     lex_start(NULL, NULL, LEX_START_SAME_FILTER);
7705     utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
7706             veop, modname, imop);
7707     LEAVE;
7708 }
7709
7710 PERL_STATIC_INLINE OP *
7711 S_new_entersubop(pTHX_ GV *gv, OP *arg)
7712 {
7713     return newUNOP(OP_ENTERSUB, OPf_STACKED,
7714                    newLISTOP(OP_LIST, 0, arg,
7715                              newUNOP(OP_RV2CV, 0,
7716                                      newGVOP(OP_GV, 0, gv))));
7717 }
7718
7719 OP *
7720 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
7721 {
7722     OP *doop;
7723     GV *gv;
7724
7725     PERL_ARGS_ASSERT_DOFILE;
7726
7727     if (!force_builtin && (gv = gv_override("do", 2))) {
7728         doop = S_new_entersubop(aTHX_ gv, term);
7729     }
7730     else {
7731         doop = newUNOP(OP_DOFILE, 0, scalar(term));
7732     }
7733     return doop;
7734 }
7735
7736 /*
7737 =head1 Optree construction
7738
7739 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
7740
7741 Constructs, checks, and returns an C<lslice> (list slice) op.  C<flags>
7742 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
7743 be set automatically, and, shifted up eight bits, the eight bits of
7744 C<op_private>, except that the bit with value 1 or 2 is automatically
7745 set as required.  C<listval> and C<subscript> supply the parameters of
7746 the slice; they are consumed by this function and become part of the
7747 constructed op tree.
7748
7749 =cut
7750 */
7751
7752 OP *
7753 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
7754 {
7755     return newBINOP(OP_LSLICE, flags,
7756             list(force_list(subscript, 1)),
7757             list(force_list(listval,   1)) );
7758 }
7759
7760 #define ASSIGN_LIST   1
7761 #define ASSIGN_REF    2
7762
7763 STATIC I32
7764 S_assignment_type(pTHX_ const OP *o)
7765 {
7766     unsigned type;
7767     U8 flags;
7768     U8 ret;
7769
7770     if (!o)
7771         return TRUE;
7772
7773     if (o->op_type == OP_SREFGEN)
7774     {
7775         OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
7776         type = kid->op_type;
7777         flags = o->op_flags | kid->op_flags;
7778         if (!(flags & OPf_PARENS)
7779           && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
7780               kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
7781             return ASSIGN_REF;
7782         ret = ASSIGN_REF;
7783     } else {
7784         if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
7785             o = cUNOPo->op_first;
7786         flags = o->op_flags;
7787         type = o->op_type;
7788         ret = 0;
7789     }
7790
7791     if (type == OP_COND_EXPR) {
7792         OP * const sib = OpSIBLING(cLOGOPo->op_first);
7793         const I32 t = assignment_type(sib);
7794         const I32 f = assignment_type(OpSIBLING(sib));
7795
7796         if (t == ASSIGN_LIST && f == ASSIGN_LIST)
7797             return ASSIGN_LIST;
7798         if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
7799             yyerror("Assignment to both a list and a scalar");
7800         return FALSE;
7801     }
7802
7803     if (type == OP_LIST &&
7804         (flags & OPf_WANT) == OPf_WANT_SCALAR &&
7805         o->op_private & OPpLVAL_INTRO)
7806         return ret;
7807
7808     if (type == OP_LIST || flags & OPf_PARENS ||
7809         type == OP_RV2AV || type == OP_RV2HV ||
7810         type == OP_ASLICE || type == OP_HSLICE ||
7811         type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
7812         return TRUE;
7813
7814     if (type == OP_PADAV || type == OP_PADHV)
7815         return TRUE;
7816
7817     if (type == OP_RV2SV)
7818         return ret;
7819
7820     return ret;
7821 }
7822
7823 static OP *
7824 S_newONCEOP(pTHX_ OP *initop, OP *padop)
7825 {
7826     dVAR;
7827     const PADOFFSET target = padop->op_targ;
7828     OP *const other = newOP(OP_PADSV,
7829                             padop->op_flags
7830                             | ((padop->op_private & ~OPpLVAL_INTRO) << 8));
7831     OP *const first = newOP(OP_NULL, 0);
7832     OP *const nullop = newCONDOP(0, first, initop, other);
7833     /* XXX targlex disabled for now; see ticket #124160
7834         newCONDOP(0, first, S_maybe_targlex(aTHX_ initop), other);
7835      */
7836     OP *const condop = first->op_next;
7837
7838     OpTYPE_set(condop, OP_ONCE);
7839     other->op_targ = target;
7840     nullop->op_flags |= OPf_WANT_SCALAR;
7841
7842     /* Store the initializedness of state vars in a separate
7843        pad entry.  */
7844     condop->op_targ =
7845       pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
7846     /* hijacking PADSTALE for uninitialized state variables */
7847     SvPADSTALE_on(PAD_SVl(condop->op_targ));
7848
7849     return nullop;
7850 }
7851
7852 /*
7853 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
7854
7855 Constructs, checks, and returns an assignment op.  C<left> and C<right>
7856 supply the parameters of the assignment; they are consumed by this
7857 function and become part of the constructed op tree.
7858
7859 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
7860 a suitable conditional optree is constructed.  If C<optype> is the opcode
7861 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
7862 performs the binary operation and assigns the result to the left argument.
7863 Either way, if C<optype> is non-zero then C<flags> has no effect.
7864
7865 If C<optype> is zero, then a plain scalar or list assignment is
7866 constructed.  Which type of assignment it is is automatically determined.
7867 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
7868 will be set automatically, and, shifted up eight bits, the eight bits
7869 of C<op_private>, except that the bit with value 1 or 2 is automatically
7870 set as required.
7871
7872 =cut
7873 */
7874
7875 OP *
7876 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
7877 {
7878     OP *o;
7879     I32 assign_type;
7880
7881     if (optype) {
7882         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
7883             right = scalar(right);
7884             return newLOGOP(optype, 0,
7885                 op_lvalue(scalar(left), optype),
7886                 newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right));
7887         }
7888         else {
7889             return newBINOP(optype, OPf_STACKED,
7890                 op_lvalue(scalar(left), optype), scalar(right));
7891         }
7892     }
7893
7894     if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
7895         OP *state_var_op = NULL;
7896         static const char no_list_state[] = "Initialization of state variables"
7897             " in list currently forbidden";
7898         OP *curop;
7899
7900         if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
7901             left->op_private &= ~ OPpSLICEWARNING;
7902
7903         PL_modcount = 0;
7904         left = op_lvalue(left, OP_AASSIGN);
7905         curop = list(force_list(left, 1));
7906         o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
7907         o->op_private = (U8)(0 | (flags >> 8));
7908
7909         if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
7910         {
7911             OP *lop = ((LISTOP*)left)->op_first, *vop, *eop;
7912             if (!(left->op_flags & OPf_PARENS) &&
7913                     lop->op_type == OP_PUSHMARK &&
7914                     (vop = OpSIBLING(lop)) &&
7915                     (vop->op_type == OP_PADAV || vop->op_type == OP_PADHV) &&
7916                     !(vop->op_flags & OPf_PARENS) &&
7917                     (vop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) ==
7918                         (OPpLVAL_INTRO|OPpPAD_STATE) &&
7919                     (eop = OpSIBLING(vop)) &&
7920                     eop->op_type == OP_ENTERSUB &&
7921                     !OpHAS_SIBLING(eop)) {
7922                 state_var_op = vop;
7923             } else {
7924                 while (lop) {
7925                     if ((lop->op_type == OP_PADSV ||
7926                          lop->op_type == OP_PADAV ||
7927                          lop->op_type == OP_PADHV ||
7928                          lop->op_type == OP_PADANY)
7929                       && (lop->op_private & OPpPAD_STATE)
7930                     )
7931                         yyerror(no_list_state);
7932                     lop = OpSIBLING(lop);
7933                 }
7934             }
7935         }
7936         else if (  (left->op_private & OPpLVAL_INTRO)
7937                 && (left->op_private & OPpPAD_STATE)
7938                 && (   left->op_type == OP_PADSV
7939                     || left->op_type == OP_PADAV
7940                     || left->op_type == OP_PADHV
7941                     || left->op_type == OP_PADANY)
7942         ) {
7943                 /* All single variable list context state assignments, hence
7944                    state ($a) = ...
7945                    (state $a) = ...
7946                    state @a = ...
7947                    state (@a) = ...
7948                    (state @a) = ...
7949                    state %a = ...
7950                    state (%a) = ...
7951                    (state %a) = ...
7952                 */
7953                 if (left->op_flags & OPf_PARENS)
7954                     yyerror(no_list_state);
7955                 else
7956                     state_var_op = left;
7957         }
7958
7959         /* optimise @a = split(...) into:
7960         * @{expr}:              split(..., @{expr}) (where @a is not flattened)
7961         * @a, my @a, local @a:  split(...)          (where @a is attached to
7962         *                                            the split op itself)
7963         */
7964
7965         if (   right
7966             && right->op_type == OP_SPLIT
7967             /* don't do twice, e.g. @b = (@a = split) */
7968             && !(right->op_private & OPpSPLIT_ASSIGN))
7969         {
7970             OP *gvop = NULL;
7971
7972             if (   (  left->op_type == OP_RV2AV
7973                    && (gvop=((UNOP*)left)->op_first)->op_type==OP_GV)
7974                 || left->op_type == OP_PADAV)
7975             {
7976                 /* @pkg or @lex or local @pkg' or 'my @lex' */
7977                 OP *tmpop;
7978                 if (gvop) {
7979 #ifdef USE_ITHREADS
7980                     ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff
7981                         = cPADOPx(gvop)->op_padix;
7982                     cPADOPx(gvop)->op_padix = 0;        /* steal it */
7983 #else
7984                     ((PMOP*)right)->op_pmreplrootu.op_pmtargetgv
7985                         = MUTABLE_GV(cSVOPx(gvop)->op_sv);
7986                     cSVOPx(gvop)->op_sv = NULL; /* steal it */
7987 #endif
7988                     right->op_private |=
7989                         left->op_private & OPpOUR_INTRO;
7990                 }
7991                 else {
7992                     ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff = left->op_targ;
7993                     left->op_targ = 0;  /* steal it */
7994                     right->op_private |= OPpSPLIT_LEX;
7995                 }
7996                 right->op_private |= left->op_private & OPpLVAL_INTRO;
7997
7998               detach_split:
7999                 tmpop = cUNOPo->op_first;       /* to list (nulled) */
8000                 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
8001                 assert(OpSIBLING(tmpop) == right);
8002                 assert(!OpHAS_SIBLING(right));
8003                 /* detach the split subtreee from the o tree,
8004                  * then free the residual o tree */
8005                 op_sibling_splice(cUNOPo->op_first, tmpop, 1, NULL);
8006                 op_free(o);                     /* blow off assign */
8007                 right->op_private |= OPpSPLIT_ASSIGN;
8008                 right->op_flags &= ~OPf_WANT;
8009                         /* "I don't know and I don't care." */
8010                 return right;
8011             }
8012             else if (left->op_type == OP_RV2AV) {
8013                 /* @{expr} */
8014
8015                 OP *pushop = cUNOPx(cBINOPo->op_last)->op_first;
8016                 assert(OpSIBLING(pushop) == left);
8017                 /* Detach the array ...  */
8018                 op_sibling_splice(cBINOPo->op_last, pushop, 1, NULL);
8019                 /* ... and attach it to the split.  */
8020                 op_sibling_splice(right, cLISTOPx(right)->op_last,
8021                                   0, left);
8022                 right->op_flags |= OPf_STACKED;
8023                 /* Detach split and expunge aassign as above.  */
8024                 goto detach_split;
8025             }
8026             else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
8027                     ((LISTOP*)right)->op_last->op_type == OP_CONST)
8028             {
8029                 /* convert split(...,0) to split(..., PL_modcount+1) */
8030                 SV ** const svp =
8031                     &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
8032                 SV * const sv = *svp;
8033                 if (SvIOK(sv) && SvIVX(sv) == 0)
8034                 {
8035                   if (right->op_private & OPpSPLIT_IMPLIM) {
8036                     /* our own SV, created in ck_split */
8037                     SvREADONLY_off(sv);
8038                     sv_setiv(sv, PL_modcount+1);
8039                   }
8040                   else {
8041                     /* SV may belong to someone else */
8042                     SvREFCNT_dec(sv);
8043                     *svp = newSViv(PL_modcount+1);
8044                   }
8045                 }
8046             }
8047         }
8048
8049         if (state_var_op)
8050             o = S_newONCEOP(aTHX_ o, state_var_op);
8051         return o;
8052     }
8053     if (assign_type == ASSIGN_REF)
8054         return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
8055     if (!right)
8056         right = newOP(OP_UNDEF, 0);
8057     if (right->op_type == OP_READLINE) {
8058         right->op_flags |= OPf_STACKED;
8059         return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
8060                 scalar(right));
8061     }
8062     else {
8063         o = newBINOP(OP_SASSIGN, flags,
8064             scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
8065     }
8066     return o;
8067 }
8068
8069 /*
8070 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
8071
8072 Constructs a state op (COP).  The state op is normally a C<nextstate> op,
8073 but will be a C<dbstate> op if debugging is enabled for currently-compiled
8074 code.  The state op is populated from C<PL_curcop> (or C<PL_compiling>).
8075 If C<label> is non-null, it supplies the name of a label to attach to
8076 the state op; this function takes ownership of the memory pointed at by
8077 C<label>, and will free it.  C<flags> gives the eight bits of C<op_flags>
8078 for the state op.
8079
8080 If C<o> is null, the state op is returned.  Otherwise the state op is
8081 combined with C<o> into a C<lineseq> list op, which is returned.  C<o>
8082 is consumed by this function and becomes part of the returned op tree.
8083
8084 =cut
8085 */
8086
8087 OP *
8088 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
8089 {
8090     dVAR;
8091     const U32 seq = intro_my();
8092     const U32 utf8 = flags & SVf_UTF8;
8093     COP *cop;
8094
8095     PL_parser->parsed_sub = 0;
8096
8097     flags &= ~SVf_UTF8;
8098
8099     NewOp(1101, cop, 1, COP);
8100     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
8101         OpTYPE_set(cop, OP_DBSTATE);
8102     }
8103     else {
8104         OpTYPE_set(cop, OP_NEXTSTATE);
8105     }
8106     cop->op_flags = (U8)flags;
8107     CopHINTS_set(cop, PL_hints);
8108 #ifdef VMS
8109     if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
8110 #endif
8111     cop->op_next = (OP*)cop;
8112
8113     cop->cop_seq = seq;
8114     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
8115     CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
8116     if (label) {
8117         Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
8118
8119         PL_hints |= HINT_BLOCK_SCOPE;
8120         /* It seems that we need to defer freeing this pointer, as other parts
8121            of the grammar end up wanting to copy it after this op has been
8122            created. */
8123         SAVEFREEPV(label);
8124     }
8125
8126     if (PL_parser->preambling != NOLINE) {
8127         CopLINE_set(cop, PL_parser->preambling);
8128         PL_parser->copline = NOLINE;
8129     }
8130     else if (PL_parser->copline == NOLINE)
8131         CopLINE_set(cop, CopLINE(PL_curcop));
8132     else {
8133         CopLINE_set(cop, PL_parser->copline);
8134         PL_parser->copline = NOLINE;
8135     }
8136 #ifdef USE_ITHREADS
8137     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
8138 #else
8139     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
8140 #endif
8141     CopSTASH_set(cop, PL_curstash);
8142
8143     if (cop->op_type == OP_DBSTATE) {
8144         /* this line can have a breakpoint - store the cop in IV */
8145         AV *av = CopFILEAVx(PL_curcop);
8146         if (av) {
8147             SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
8148             if (svp && *svp != &PL_sv_undef ) {
8149                 (void)SvIOK_on(*svp);
8150                 SvIV_set(*svp, PTR2IV(cop));
8151             }
8152         }
8153     }
8154
8155     if (flags & OPf_SPECIAL)
8156         op_null((OP*)cop);
8157     return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
8158 }
8159
8160 /*
8161 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
8162
8163 Constructs, checks, and returns a logical (flow control) op.  C<type>
8164 is the opcode.  C<flags> gives the eight bits of C<op_flags>, except
8165 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
8166 the eight bits of C<op_private>, except that the bit with value 1 is
8167 automatically set.  C<first> supplies the expression controlling the
8168 flow, and C<other> supplies the side (alternate) chain of ops; they are
8169 consumed by this function and become part of the constructed op tree.
8170
8171 =cut
8172 */
8173
8174 OP *
8175 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
8176 {
8177     PERL_ARGS_ASSERT_NEWLOGOP;
8178
8179     return new_logop(type, flags, &first, &other);
8180 }
8181
8182 STATIC OP *
8183 S_search_const(pTHX_ OP *o)
8184 {
8185     PERL_ARGS_ASSERT_SEARCH_CONST;
8186
8187     switch (o->op_type) {
8188         case OP_CONST:
8189             return o;
8190         case OP_NULL:
8191             if (o->op_flags & OPf_KIDS)
8192                 return search_const(cUNOPo->op_first);
8193             break;
8194         case OP_LEAVE:
8195         case OP_SCOPE:
8196         case OP_LINESEQ:
8197         {
8198             OP *kid;
8199             if (!(o->op_flags & OPf_KIDS))
8200                 return NULL;
8201             kid = cLISTOPo->op_first;
8202             do {
8203                 switch (kid->op_type) {
8204                     case OP_ENTER:
8205                     case OP_NULL:
8206                     case OP_NEXTSTATE:
8207                         kid = OpSIBLING(kid);
8208                         break;
8209                     default:
8210                         if (kid != cLISTOPo->op_last)
8211                             return NULL;
8212                         goto last;
8213                 }
8214             } while (kid);
8215             if (!kid)
8216                 kid = cLISTOPo->op_last;
8217           last:
8218             return search_const(kid);
8219         }
8220     }
8221
8222     return NULL;
8223 }
8224
8225 STATIC OP *
8226 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
8227 {
8228     dVAR;
8229     LOGOP *logop;
8230     OP *o;
8231     OP *first;
8232     OP *other;
8233     OP *cstop = NULL;
8234     int prepend_not = 0;
8235
8236     PERL_ARGS_ASSERT_NEW_LOGOP;
8237
8238     first = *firstp;
8239     other = *otherp;
8240
8241     /* [perl #59802]: Warn about things like "return $a or $b", which
8242        is parsed as "(return $a) or $b" rather than "return ($a or
8243        $b)".  NB: This also applies to xor, which is why we do it
8244        here.
8245      */
8246     switch (first->op_type) {
8247     case OP_NEXT:
8248     case OP_LAST:
8249     case OP_REDO:
8250         /* XXX: Perhaps we should emit a stronger warning for these.
8251            Even with the high-precedence operator they don't seem to do
8252            anything sensible.
8253
8254            But until we do, fall through here.
8255          */
8256     case OP_RETURN:
8257     case OP_EXIT:
8258     case OP_DIE:
8259     case OP_GOTO:
8260         /* XXX: Currently we allow people to "shoot themselves in the
8261            foot" by explicitly writing "(return $a) or $b".
8262
8263            Warn unless we are looking at the result from folding or if
8264            the programmer explicitly grouped the operators like this.
8265            The former can occur with e.g.
8266
8267                 use constant FEATURE => ( $] >= ... );
8268                 sub { not FEATURE and return or do_stuff(); }
8269          */
8270         if (!first->op_folded && !(first->op_flags & OPf_PARENS))
8271             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
8272                            "Possible precedence issue with control flow operator");
8273         /* XXX: Should we optimze this to "return $a;" (i.e. remove
8274            the "or $b" part)?
8275         */
8276         break;
8277     }
8278
8279     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
8280         return newBINOP(type, flags, scalar(first), scalar(other));
8281
8282     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
8283         || type == OP_CUSTOM);
8284
8285     scalarboolean(first);
8286
8287     /* search for a constant op that could let us fold the test */
8288     if ((cstop = search_const(first))) {
8289         if (cstop->op_private & OPpCONST_STRICT)
8290             no_bareword_allowed(cstop);
8291         else if ((cstop->op_private & OPpCONST_BARE))
8292                 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
8293         if ((type == OP_AND &&  SvTRUE(((SVOP*)cstop)->op_sv)) ||
8294             (type == OP_OR  && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
8295             (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
8296             /* Elide the (constant) lhs, since it can't affect the outcome */
8297             *firstp = NULL;
8298             if (other->op_type == OP_CONST)
8299                 other->op_private |= OPpCONST_SHORTCIRCUIT;
8300             op_free(first);
8301             if (other->op_type == OP_LEAVE)
8302                 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
8303             else if (other->op_type == OP_MATCH
8304                   || other->op_type == OP_SUBST
8305                   || other->op_type == OP_TRANSR
8306                   || other->op_type == OP_TRANS)
8307                 /* Mark the op as being unbindable with =~ */
8308                 other->op_flags |= OPf_SPECIAL;
8309
8310             other->op_folded = 1;
8311             return other;
8312         }
8313         else {
8314             /* Elide the rhs, since the outcome is entirely determined by
8315              * the (constant) lhs */
8316
8317             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
8318             const OP *o2 = other;
8319             if ( ! (o2->op_type == OP_LIST
8320                     && (( o2 = cUNOPx(o2)->op_first))
8321                     && o2->op_type == OP_PUSHMARK
8322                     && (( o2 = OpSIBLING(o2))) )
8323             )
8324                 o2 = other;
8325             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
8326                         || o2->op_type == OP_PADHV)
8327                 && o2->op_private & OPpLVAL_INTRO
8328                 && !(o2->op_private & OPpPAD_STATE))
8329             {
8330         Perl_croak(aTHX_ "This use of my() in false conditional is "
8331                           "no longer allowed");
8332             }
8333
8334             *otherp = NULL;
8335             if (cstop->op_type == OP_CONST)
8336                 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
8337             op_free(other);
8338             return first;
8339         }
8340     }
8341     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
8342         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
8343     {
8344         const OP * const k1 = ((UNOP*)first)->op_first;
8345         const OP * const k2 = OpSIBLING(k1);
8346         OPCODE warnop = 0;
8347         switch (first->op_type)
8348         {
8349         case OP_NULL:
8350             if (k2 && k2->op_type == OP_READLINE
8351                   && (k2->op_flags & OPf_STACKED)
8352                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8353             {
8354                 warnop = k2->op_type;
8355             }
8356             break;
8357
8358         case OP_SASSIGN:
8359             if (k1->op_type == OP_READDIR
8360                   || k1->op_type == OP_GLOB
8361                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8362                  || k1->op_type == OP_EACH
8363                  || k1->op_type == OP_AEACH)
8364             {
8365                 warnop = ((k1->op_type == OP_NULL)
8366                           ? (OPCODE)k1->op_targ : k1->op_type);
8367             }
8368             break;
8369         }
8370         if (warnop) {
8371             const line_t oldline = CopLINE(PL_curcop);
8372             /* This ensures that warnings are reported at the first line
8373                of the construction, not the last.  */
8374             CopLINE_set(PL_curcop, PL_parser->copline);
8375             Perl_warner(aTHX_ packWARN(WARN_MISC),
8376                  "Value of %s%s can be \"0\"; test with defined()",
8377                  PL_op_desc[warnop],
8378                  ((warnop == OP_READLINE || warnop == OP_GLOB)
8379                   ? " construct" : "() operator"));
8380             CopLINE_set(PL_curcop, oldline);
8381         }
8382     }
8383
8384     /* optimize AND and OR ops that have NOTs as children */
8385     if (first->op_type == OP_NOT
8386         && (first->op_flags & OPf_KIDS)
8387         && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
8388             || (other->op_type == OP_NOT))  /* if (!$x && !$y) { } */
8389         ) {
8390         if (type == OP_AND || type == OP_OR) {
8391             if (type == OP_AND)
8392                 type = OP_OR;
8393             else
8394                 type = OP_AND;
8395             op_null(first);
8396             if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
8397                 op_null(other);
8398                 prepend_not = 1; /* prepend a NOT op later */
8399             }
8400         }
8401     }
8402
8403     logop = alloc_LOGOP(type, first, LINKLIST(other));
8404     logop->op_flags |= (U8)flags;
8405     logop->op_private = (U8)(1 | (flags >> 8));
8406
8407     /* establish postfix order */
8408     logop->op_next = LINKLIST(first);
8409     first->op_next = (OP*)logop;
8410     assert(!OpHAS_SIBLING(first));
8411     op_sibling_splice((OP*)logop, first, 0, other);
8412
8413     CHECKOP(type,logop);
8414
8415     o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
8416                 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
8417                 (OP*)logop);
8418     other->op_next = o;
8419
8420     return o;
8421 }
8422
8423 /*
8424 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
8425
8426 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
8427 op.  C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
8428 will be set automatically, and, shifted up eight bits, the eight bits of
8429 C<op_private>, except that the bit with value 1 is automatically set.
8430 C<first> supplies the expression selecting between the two branches,
8431 and C<trueop> and C<falseop> supply the branches; they are consumed by
8432 this function and become part of the constructed op tree.
8433
8434 =cut
8435 */
8436
8437 OP *
8438 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
8439 {
8440     dVAR;
8441     LOGOP *logop;
8442     OP *start;
8443     OP *o;
8444     OP *cstop;
8445
8446     PERL_ARGS_ASSERT_NEWCONDOP;
8447
8448     if (!falseop)
8449         return newLOGOP(OP_AND, 0, first, trueop);
8450     if (!trueop)
8451         return newLOGOP(OP_OR, 0, first, falseop);
8452
8453     scalarboolean(first);
8454     if ((cstop = search_const(first))) {
8455         /* Left or right arm of the conditional?  */
8456         const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
8457         OP *live = left ? trueop : falseop;
8458         OP *const dead = left ? falseop : trueop;
8459         if (cstop->op_private & OPpCONST_BARE &&
8460             cstop->op_private & OPpCONST_STRICT) {
8461             no_bareword_allowed(cstop);
8462         }
8463         op_free(first);
8464         op_free(dead);
8465         if (live->op_type == OP_LEAVE)
8466             live = newUNOP(OP_NULL, OPf_SPECIAL, live);
8467         else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
8468               || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
8469             /* Mark the op as being unbindable with =~ */
8470             live->op_flags |= OPf_SPECIAL;
8471         live->op_folded = 1;
8472         return live;
8473     }
8474     logop = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop));
8475     logop->op_flags |= (U8)flags;
8476     logop->op_private = (U8)(1 | (flags >> 8));
8477     logop->op_next = LINKLIST(falseop);
8478
8479     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
8480             logop);
8481
8482     /* establish postfix order */
8483     start = LINKLIST(first);
8484     first->op_next = (OP*)logop;
8485
8486     /* make first, trueop, falseop siblings */
8487     op_sibling_splice((OP*)logop, first,  0, trueop);
8488     op_sibling_splice((OP*)logop, trueop, 0, falseop);
8489
8490     o = newUNOP(OP_NULL, 0, (OP*)logop);
8491
8492     trueop->op_next = falseop->op_next = o;
8493
8494     o->op_next = start;
8495     return o;
8496 }
8497
8498 /*
8499 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
8500
8501 Constructs and returns a C<range> op, with subordinate C<flip> and
8502 C<flop> ops.  C<flags> gives the eight bits of C<op_flags> for the
8503 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
8504 for both the C<flip> and C<range> ops, except that the bit with value
8505 1 is automatically set.  C<left> and C<right> supply the expressions
8506 controlling the endpoints of the range; they are consumed by this function
8507 and become part of the constructed op tree.
8508
8509 =cut
8510 */
8511
8512 OP *
8513 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
8514 {
8515     LOGOP *range;
8516     OP *flip;
8517     OP *flop;
8518     OP *leftstart;
8519     OP *o;
8520
8521     PERL_ARGS_ASSERT_NEWRANGE;
8522
8523     range = alloc_LOGOP(OP_RANGE, left, LINKLIST(right));
8524     range->op_flags = OPf_KIDS;
8525     leftstart = LINKLIST(left);
8526     range->op_private = (U8)(1 | (flags >> 8));
8527
8528     /* make left and right siblings */
8529     op_sibling_splice((OP*)range, left, 0, right);
8530
8531     range->op_next = (OP*)range;
8532     flip = newUNOP(OP_FLIP, flags, (OP*)range);
8533     flop = newUNOP(OP_FLOP, 0, flip);
8534     o = newUNOP(OP_NULL, 0, flop);
8535     LINKLIST(flop);
8536     range->op_next = leftstart;
8537
8538     left->op_next = flip;
8539     right->op_next = flop;
8540
8541     range->op_targ =
8542         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
8543     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
8544     flip->op_targ =
8545         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
8546     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
8547     SvPADTMP_on(PAD_SV(flip->op_targ));
8548
8549     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
8550     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
8551
8552     /* check barewords before they might be optimized aways */
8553     if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
8554         no_bareword_allowed(left);
8555     if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
8556         no_bareword_allowed(right);
8557
8558     flip->op_next = o;
8559     if (!flip->op_private || !flop->op_private)
8560         LINKLIST(o);            /* blow off optimizer unless constant */
8561
8562     return o;
8563 }
8564
8565 /*
8566 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
8567
8568 Constructs, checks, and returns an op tree expressing a loop.  This is
8569 only a loop in the control flow through the op tree; it does not have
8570 the heavyweight loop structure that allows exiting the loop by C<last>
8571 and suchlike.  C<flags> gives the eight bits of C<op_flags> for the
8572 top-level op, except that some bits will be set automatically as required.
8573 C<expr> supplies the expression controlling loop iteration, and C<block>
8574 supplies the body of the loop; they are consumed by this function and
8575 become part of the constructed op tree.  C<debuggable> is currently
8576 unused and should always be 1.
8577
8578 =cut
8579 */
8580
8581 OP *
8582 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
8583 {
8584     OP* listop;
8585     OP* o;
8586     const bool once = block && block->op_flags & OPf_SPECIAL &&
8587                       block->op_type == OP_NULL;
8588
8589     PERL_UNUSED_ARG(debuggable);
8590
8591     if (expr) {
8592         if (once && (
8593               (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
8594            || (  expr->op_type == OP_NOT
8595               && cUNOPx(expr)->op_first->op_type == OP_CONST
8596               && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
8597               )
8598            ))
8599             /* Return the block now, so that S_new_logop does not try to
8600                fold it away. */
8601             return block;       /* do {} while 0 does once */
8602         if (expr->op_type == OP_READLINE
8603             || expr->op_type == OP_READDIR
8604             || expr->op_type == OP_GLOB
8605             || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
8606             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
8607             expr = newUNOP(OP_DEFINED, 0,
8608                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
8609         } else if (expr->op_flags & OPf_KIDS) {
8610             const OP * const k1 = ((UNOP*)expr)->op_first;
8611             const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
8612             switch (expr->op_type) {
8613               case OP_NULL:
8614                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
8615                       && (k2->op_flags & OPf_STACKED)
8616                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8617                     expr = newUNOP(OP_DEFINED, 0, expr);
8618                 break;
8619
8620               case OP_SASSIGN:
8621                 if (k1 && (k1->op_type == OP_READDIR
8622                       || k1->op_type == OP_GLOB
8623                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8624                      || k1->op_type == OP_EACH
8625                      || k1->op_type == OP_AEACH))
8626                     expr = newUNOP(OP_DEFINED, 0, expr);
8627                 break;
8628             }
8629         }
8630     }
8631
8632     /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
8633      * op, in listop. This is wrong. [perl #27024] */
8634     if (!block)
8635         block = newOP(OP_NULL, 0);
8636     listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
8637     o = new_logop(OP_AND, 0, &expr, &listop);
8638
8639     if (once) {
8640         ASSUME(listop);
8641     }
8642
8643     if (listop)
8644         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
8645
8646     if (once && o != listop)
8647     {
8648         assert(cUNOPo->op_first->op_type == OP_AND
8649             || cUNOPo->op_first->op_type == OP_OR);
8650         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
8651     }
8652
8653     if (o == listop)
8654         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
8655
8656     o->op_flags |= flags;
8657     o = op_scope(o);
8658     o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
8659     return o;
8660 }
8661
8662 /*
8663 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
8664
8665 Constructs, checks, and returns an op tree expressing a C<while> loop.
8666 This is a heavyweight loop, with structure that allows exiting the loop
8667 by C<last> and suchlike.
8668
8669 C<loop> is an optional preconstructed C<enterloop> op to use in the
8670 loop; if it is null then a suitable op will be constructed automatically.
8671 C<expr> supplies the loop's controlling expression.  C<block> supplies the
8672 main body of the loop, and C<cont> optionally supplies a C<continue> block
8673 that operates as a second half of the body.  All of these optree inputs
8674 are consumed by this function and become part of the constructed op tree.
8675
8676 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
8677 op and, shifted up eight bits, the eight bits of C<op_private> for
8678 the C<leaveloop> op, except that (in both cases) some bits will be set
8679 automatically.  C<debuggable> is currently unused and should always be 1.
8680 C<has_my> can be supplied as true to force the
8681 loop body to be enclosed in its own scope.
8682
8683 =cut
8684 */
8685
8686 OP *
8687 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
8688         OP *expr, OP *block, OP *cont, I32 has_my)
8689 {
8690     dVAR;
8691     OP *redo;
8692     OP *next = NULL;
8693     OP *listop;
8694     OP *o;
8695     U8 loopflags = 0;
8696
8697     PERL_UNUSED_ARG(debuggable);
8698
8699     if (expr) {
8700         if (expr->op_type == OP_READLINE
8701          || expr->op_type == OP_READDIR
8702          || expr->op_type == OP_GLOB
8703          || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
8704                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
8705             expr = newUNOP(OP_DEFINED, 0,
8706                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
8707         } else if (expr->op_flags & OPf_KIDS) {
8708             const OP * const k1 = ((UNOP*)expr)->op_first;
8709             const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
8710             switch (expr->op_type) {
8711               case OP_NULL:
8712                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
8713                       && (k2->op_flags & OPf_STACKED)
8714                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8715                     expr = newUNOP(OP_DEFINED, 0, expr);
8716                 break;
8717
8718               case OP_SASSIGN:
8719                 if (k1 && (k1->op_type == OP_READDIR
8720                       || k1->op_type == OP_GLOB
8721                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8722                      || k1->op_type == OP_EACH
8723                      || k1->op_type == OP_AEACH))
8724                     expr = newUNOP(OP_DEFINED, 0, expr);
8725                 break;
8726             }
8727         }
8728     }
8729
8730     if (!block)
8731         block = newOP(OP_NULL, 0);
8732     else if (cont || has_my) {
8733         block = op_scope(block);
8734     }
8735
8736     if (cont) {
8737         next = LINKLIST(cont);
8738     }
8739     if (expr) {
8740         OP * const unstack = newOP(OP_UNSTACK, 0);
8741         if (!next)
8742             next = unstack;
8743         cont = op_append_elem(OP_LINESEQ, cont, unstack);
8744     }
8745
8746     assert(block);
8747     listop = op_append_list(OP_LINESEQ, block, cont);
8748     assert(listop);
8749     redo = LINKLIST(listop);
8750
8751     if (expr) {
8752         scalar(listop);
8753         o = new_logop(OP_AND, 0, &expr, &listop);
8754         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
8755             op_free((OP*)loop);
8756             return expr;                /* listop already freed by new_logop */
8757         }
8758         if (listop)
8759             ((LISTOP*)listop)->op_last->op_next =
8760                 (o == listop ? redo : LINKLIST(o));
8761     }
8762     else
8763         o = listop;
8764
8765     if (!loop) {
8766         NewOp(1101,loop,1,LOOP);
8767         OpTYPE_set(loop, OP_ENTERLOOP);
8768         loop->op_private = 0;
8769         loop->op_next = (OP*)loop;
8770     }
8771
8772     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
8773
8774     loop->op_redoop = redo;
8775     loop->op_lastop = o;
8776     o->op_private |= loopflags;
8777
8778     if (next)
8779         loop->op_nextop = next;
8780     else
8781         loop->op_nextop = o;
8782
8783     o->op_flags |= flags;
8784     o->op_private |= (flags >> 8);
8785     return o;
8786 }
8787
8788 /*
8789 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
8790
8791 Constructs, checks, and returns an op tree expressing a C<foreach>
8792 loop (iteration through a list of values).  This is a heavyweight loop,
8793 with structure that allows exiting the loop by C<last> and suchlike.
8794
8795 C<sv> optionally supplies the variable that will be aliased to each
8796 item in turn; if null, it defaults to C<$_>.
8797 C<expr> supplies the list of values to iterate over.  C<block> supplies
8798 the main body of the loop, and C<cont> optionally supplies a C<continue>
8799 block that operates as a second half of the body.  All of these optree
8800 inputs are consumed by this function and become part of the constructed
8801 op tree.
8802
8803 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
8804 op and, shifted up eight bits, the eight bits of C<op_private> for
8805 the C<leaveloop> op, except that (in both cases) some bits will be set
8806 automatically.
8807
8808 =cut
8809 */
8810
8811 OP *
8812 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
8813 {
8814     dVAR;
8815     LOOP *loop;
8816     OP *wop;
8817     PADOFFSET padoff = 0;
8818     I32 iterflags = 0;
8819     I32 iterpflags = 0;
8820
8821     PERL_ARGS_ASSERT_NEWFOROP;
8822
8823     if (sv) {
8824         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
8825             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
8826             OpTYPE_set(sv, OP_RV2GV);
8827
8828             /* The op_type check is needed to prevent a possible segfault
8829              * if the loop variable is undeclared and 'strict vars' is in
8830              * effect. This is illegal but is nonetheless parsed, so we
8831              * may reach this point with an OP_CONST where we're expecting
8832              * an OP_GV.
8833              */
8834             if (cUNOPx(sv)->op_first->op_type == OP_GV
8835              && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
8836                 iterpflags |= OPpITER_DEF;
8837         }
8838         else if (sv->op_type == OP_PADSV) { /* private variable */
8839             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
8840             padoff = sv->op_targ;
8841             sv->op_targ = 0;
8842             op_free(sv);
8843             sv = NULL;
8844             PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
8845         }
8846         else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
8847             NOOP;
8848         else
8849             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
8850         if (padoff) {
8851             PADNAME * const pn = PAD_COMPNAME(padoff);
8852             const char * const name = PadnamePV(pn);
8853
8854             if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
8855                 iterpflags |= OPpITER_DEF;
8856         }
8857     }
8858     else {
8859         sv = newGVOP(OP_GV, 0, PL_defgv);
8860         iterpflags |= OPpITER_DEF;
8861     }
8862
8863     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
8864         expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
8865         iterflags |= OPf_STACKED;
8866     }
8867     else if (expr->op_type == OP_NULL &&
8868              (expr->op_flags & OPf_KIDS) &&
8869              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
8870     {
8871         /* Basically turn for($x..$y) into the same as for($x,$y), but we
8872          * set the STACKED flag to indicate that these values are to be
8873          * treated as min/max values by 'pp_enteriter'.
8874          */
8875         const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
8876         LOGOP* const range = (LOGOP*) flip->op_first;
8877         OP* const left  = range->op_first;
8878         OP* const right = OpSIBLING(left);
8879         LISTOP* listop;
8880
8881         range->op_flags &= ~OPf_KIDS;
8882         /* detach range's children */
8883         op_sibling_splice((OP*)range, NULL, -1, NULL);
8884
8885         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
8886         listop->op_first->op_next = range->op_next;
8887         left->op_next = range->op_other;
8888         right->op_next = (OP*)listop;
8889         listop->op_next = listop->op_first;
8890
8891         op_free(expr);
8892         expr = (OP*)(listop);
8893         op_null(expr);
8894         iterflags |= OPf_STACKED;
8895     }
8896     else {
8897         expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
8898     }
8899
8900     loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
8901                                   op_append_elem(OP_LIST, list(expr),
8902                                                  scalar(sv)));
8903     assert(!loop->op_next);
8904     /* for my  $x () sets OPpLVAL_INTRO;
8905      * for our $x () sets OPpOUR_INTRO */
8906     loop->op_private = (U8)iterpflags;
8907     if (loop->op_slabbed
8908      && DIFF(loop, OpSLOT(loop)->opslot_next)
8909          < SIZE_TO_PSIZE(sizeof(LOOP)))
8910     {
8911         LOOP *tmp;
8912         NewOp(1234,tmp,1,LOOP);
8913         Copy(loop,tmp,1,LISTOP);
8914         assert(loop->op_last->op_sibparent == (OP*)loop);
8915         OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
8916         S_op_destroy(aTHX_ (OP*)loop);
8917         loop = tmp;
8918     }
8919     else if (!loop->op_slabbed)
8920     {
8921         loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
8922         OpLASTSIB_set(loop->op_last, (OP*)loop);
8923     }
8924     loop->op_targ = padoff;
8925     wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
8926     return wop;
8927 }
8928
8929 /*
8930 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
8931
8932 Constructs, checks, and returns a loop-exiting op (such as C<goto>
8933 or C<last>).  C<type> is the opcode.  C<label> supplies the parameter
8934 determining the target of the op; it is consumed by this function and
8935 becomes part of the constructed op tree.
8936
8937 =cut
8938 */
8939
8940 OP*
8941 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
8942 {
8943     OP *o = NULL;
8944
8945     PERL_ARGS_ASSERT_NEWLOOPEX;
8946
8947     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
8948         || type == OP_CUSTOM);
8949
8950     if (type != OP_GOTO) {
8951         /* "last()" means "last" */
8952         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
8953             o = newOP(type, OPf_SPECIAL);
8954         }
8955     }
8956     else {
8957         /* Check whether it's going to be a goto &function */
8958         if (label->op_type == OP_ENTERSUB
8959                 && !(label->op_flags & OPf_STACKED))
8960             label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
8961     }
8962
8963     /* Check for a constant argument */
8964     if (label->op_type == OP_CONST) {
8965             SV * const sv = ((SVOP *)label)->op_sv;
8966             STRLEN l;
8967             const char *s = SvPV_const(sv,l);
8968             if (l == strlen(s)) {
8969                 o = newPVOP(type,
8970                             SvUTF8(((SVOP*)label)->op_sv),
8971                             savesharedpv(
8972                                 SvPV_nolen_const(((SVOP*)label)->op_sv)));
8973             }
8974     }
8975
8976     /* If we have already created an op, we do not need the label. */
8977     if (o)
8978                 op_free(label);
8979     else o = newUNOP(type, OPf_STACKED, label);
8980
8981     PL_hints |= HINT_BLOCK_SCOPE;
8982     return o;
8983 }
8984
8985 /* if the condition is a literal array or hash
8986    (or @{ ... } etc), make a reference to it.
8987  */
8988 STATIC OP *
8989 S_ref_array_or_hash(pTHX_ OP *cond)
8990 {
8991     if (cond
8992     && (cond->op_type == OP_RV2AV
8993     ||  cond->op_type == OP_PADAV
8994     ||  cond->op_type == OP_RV2HV
8995     ||  cond->op_type == OP_PADHV))
8996
8997         return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
8998
8999     else if(cond
9000     && (cond->op_type == OP_ASLICE
9001     ||  cond->op_type == OP_KVASLICE
9002     ||  cond->op_type == OP_HSLICE
9003     ||  cond->op_type == OP_KVHSLICE)) {
9004
9005         /* anonlist now needs a list from this op, was previously used in
9006          * scalar context */
9007         cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
9008         cond->op_flags |= OPf_WANT_LIST;
9009
9010         return newANONLIST(op_lvalue(cond, OP_ANONLIST));
9011     }
9012
9013     else
9014         return cond;
9015 }
9016
9017 /* These construct the optree fragments representing given()
9018    and when() blocks.
9019
9020    entergiven and enterwhen are LOGOPs; the op_other pointer
9021    points up to the associated leave op. We need this so we
9022    can put it in the context and make break/continue work.
9023    (Also, of course, pp_enterwhen will jump straight to
9024    op_other if the match fails.)
9025  */
9026
9027 STATIC OP *
9028 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
9029                    I32 enter_opcode, I32 leave_opcode,
9030                    PADOFFSET entertarg)
9031 {
9032     dVAR;
9033     LOGOP *enterop;
9034     OP *o;
9035
9036     PERL_ARGS_ASSERT_NEWGIVWHENOP;
9037     PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
9038
9039     enterop = alloc_LOGOP(enter_opcode, block, NULL);
9040     enterop->op_targ = 0;
9041     enterop->op_private = 0;
9042
9043     o = newUNOP(leave_opcode, 0, (OP *) enterop);
9044
9045     if (cond) {
9046         /* prepend cond if we have one */
9047         op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
9048
9049         o->op_next = LINKLIST(cond);
9050         cond->op_next = (OP *) enterop;
9051     }
9052     else {
9053         /* This is a default {} block */
9054         enterop->op_flags |= OPf_SPECIAL;
9055         o      ->op_flags |= OPf_SPECIAL;
9056
9057         o->op_next = (OP *) enterop;
9058     }
9059
9060     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
9061                                        entergiven and enterwhen both
9062                                        use ck_null() */
9063
9064     enterop->op_next = LINKLIST(block);
9065     block->op_next = enterop->op_other = o;
9066
9067     return o;
9068 }
9069
9070 /* Does this look like a boolean operation? For these purposes
9071    a boolean operation is:
9072      - a subroutine call [*]
9073      - a logical connective
9074      - a comparison operator
9075      - a filetest operator, with the exception of -s -M -A -C
9076      - defined(), exists() or eof()
9077      - /$re/ or $foo =~ /$re/
9078
9079    [*] possibly surprising
9080  */
9081 STATIC bool
9082 S_looks_like_bool(pTHX_ const OP *o)
9083 {
9084     PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
9085
9086     switch(o->op_type) {
9087         case OP_OR:
9088         case OP_DOR:
9089             return looks_like_bool(cLOGOPo->op_first);
9090
9091         case OP_AND:
9092         {
9093             OP* sibl = OpSIBLING(cLOGOPo->op_first);
9094             ASSUME(sibl);
9095             return (
9096                 looks_like_bool(cLOGOPo->op_first)
9097              && looks_like_bool(sibl));
9098         }
9099
9100         case OP_NULL:
9101         case OP_SCALAR:
9102             return (
9103                 o->op_flags & OPf_KIDS
9104             && looks_like_bool(cUNOPo->op_first));
9105
9106         case OP_ENTERSUB:
9107
9108         case OP_NOT:    case OP_XOR:
9109
9110         case OP_EQ:     case OP_NE:     case OP_LT:
9111         case OP_GT:     case OP_LE:     case OP_GE:
9112
9113         case OP_I_EQ:   case OP_I_NE:   case OP_I_LT:
9114         case OP_I_GT:   case OP_I_LE:   case OP_I_GE:
9115
9116         case OP_SEQ:    case OP_SNE:    case OP_SLT:
9117         case OP_SGT:    case OP_SLE:    case OP_SGE:
9118
9119         case OP_SMARTMATCH:
9120
9121         case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
9122         case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
9123         case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
9124         case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
9125         case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
9126         case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
9127         case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
9128         case OP_FTTEXT:   case OP_FTBINARY:
9129
9130         case OP_DEFINED: case OP_EXISTS:
9131         case OP_MATCH:   case OP_EOF:
9132
9133         case OP_FLOP:
9134
9135             return TRUE;
9136
9137         case OP_INDEX:
9138         case OP_RINDEX:
9139             /* optimised-away (index() != -1) or similar comparison */
9140             if (o->op_private & OPpTRUEBOOL)
9141                 return TRUE;
9142             return FALSE;
9143
9144         case OP_CONST:
9145             /* Detect comparisons that have been optimized away */
9146             if (cSVOPo->op_sv == &PL_sv_yes
9147             ||  cSVOPo->op_sv == &PL_sv_no)
9148
9149                 return TRUE;
9150             else
9151                 return FALSE;
9152         /* FALLTHROUGH */
9153         default:
9154             return FALSE;
9155     }
9156 }
9157
9158 /*
9159 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
9160
9161 Constructs, checks, and returns an op tree expressing a C<given> block.
9162 C<cond> supplies the expression to whose value C<$_> will be locally
9163 aliased, and C<block> supplies the body of the C<given> construct; they
9164 are consumed by this function and become part of the constructed op tree.
9165 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
9166
9167 =cut
9168 */
9169
9170 OP *
9171 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
9172 {
9173     PERL_ARGS_ASSERT_NEWGIVENOP;
9174     PERL_UNUSED_ARG(defsv_off);
9175
9176     assert(!defsv_off);
9177     return newGIVWHENOP(
9178         ref_array_or_hash(cond),
9179         block,
9180         OP_ENTERGIVEN, OP_LEAVEGIVEN,
9181         0);
9182 }
9183
9184 /*
9185 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
9186
9187 Constructs, checks, and returns an op tree expressing a C<when> block.
9188 C<cond> supplies the test expression, and C<block> supplies the block
9189 that will be executed if the test evaluates to true; they are consumed
9190 by this function and become part of the constructed op tree.  C<cond>
9191 will be interpreted DWIMically, often as a comparison against C<$_>,
9192 and may be null to generate a C<default> block.
9193
9194 =cut
9195 */
9196
9197 OP *
9198 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
9199 {
9200     const bool cond_llb = (!cond || looks_like_bool(cond));
9201     OP *cond_op;
9202
9203     PERL_ARGS_ASSERT_NEWWHENOP;
9204
9205     if (cond_llb)
9206         cond_op = cond;
9207     else {
9208         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
9209                 newDEFSVOP(),
9210                 scalar(ref_array_or_hash(cond)));
9211     }
9212
9213     return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
9214 }
9215
9216 /* must not conflict with SVf_UTF8 */
9217 #define CV_CKPROTO_CURSTASH     0x1
9218
9219 void
9220 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
9221                     const STRLEN len, const U32 flags)
9222 {
9223     SV *name = NULL, *msg;
9224     const char * cvp = SvROK(cv)
9225                         ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
9226                            ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
9227                            : ""
9228                         : CvPROTO(cv);
9229     STRLEN clen = CvPROTOLEN(cv), plen = len;
9230
9231     PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
9232
9233     if (p == NULL && cvp == NULL)
9234         return;
9235
9236     if (!ckWARN_d(WARN_PROTOTYPE))
9237         return;
9238
9239     if (p && cvp) {
9240         p = S_strip_spaces(aTHX_ p, &plen);
9241         cvp = S_strip_spaces(aTHX_ cvp, &clen);
9242         if ((flags & SVf_UTF8) == SvUTF8(cv)) {
9243             if (plen == clen && memEQ(cvp, p, plen))
9244                 return;
9245         } else {
9246             if (flags & SVf_UTF8) {
9247                 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
9248                     return;
9249             }
9250             else {
9251                 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
9252                     return;
9253             }
9254         }
9255     }
9256
9257     msg = sv_newmortal();
9258
9259     if (gv)
9260     {
9261         if (isGV(gv))
9262             gv_efullname3(name = sv_newmortal(), gv, NULL);
9263         else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
9264             name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
9265         else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
9266             name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
9267             sv_catpvs(name, "::");
9268             if (SvROK(gv)) {
9269                 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
9270                 assert (CvNAMED(SvRV_const(gv)));
9271                 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
9272             }
9273             else sv_catsv(name, (SV *)gv);
9274         }
9275         else name = (SV *)gv;
9276     }
9277     sv_setpvs(msg, "Prototype mismatch:");
9278     if (name)
9279         Perl_sv_catpvf(aTHX_ msg, " sub %" SVf, SVfARG(name));
9280     if (cvp)
9281         Perl_sv_catpvf(aTHX_ msg, " (%" UTF8f ")",
9282             UTF8fARG(SvUTF8(cv),clen,cvp)
9283         );
9284     else
9285         sv_catpvs(msg, ": none");
9286     sv_catpvs(msg, " vs ");
9287     if (p)
9288         Perl_sv_catpvf(aTHX_ msg, "(%" UTF8f ")", UTF8fARG(flags & SVf_UTF8,len,p));
9289     else
9290         sv_catpvs(msg, "none");
9291     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%" SVf, SVfARG(msg));
9292 }
9293
9294 static void const_sv_xsub(pTHX_ CV* cv);
9295 static void const_av_xsub(pTHX_ CV* cv);
9296
9297 /*
9298
9299 =head1 Optree Manipulation Functions
9300
9301 =for apidoc cv_const_sv
9302
9303 If C<cv> is a constant sub eligible for inlining, returns the constant
9304 value returned by the sub.  Otherwise, returns C<NULL>.
9305
9306 Constant subs can be created with C<newCONSTSUB> or as described in
9307 L<perlsub/"Constant Functions">.
9308
9309 =cut
9310 */
9311 SV *
9312 Perl_cv_const_sv(const CV *const cv)
9313 {
9314     SV *sv;
9315     if (!cv)
9316         return NULL;
9317     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
9318         return NULL;
9319     sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
9320     if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
9321     return sv;
9322 }
9323
9324 SV *
9325 Perl_cv_const_sv_or_av(const CV * const cv)
9326 {
9327     if (!cv)
9328         return NULL;
9329     if (SvROK(cv)) return SvRV((SV *)cv);
9330     assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
9331     return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
9332 }
9333
9334 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
9335  * Can be called in 2 ways:
9336  *
9337  * !allow_lex
9338  *      look for a single OP_CONST with attached value: return the value
9339  *
9340  * allow_lex && !CvCONST(cv);
9341  *
9342  *      examine the clone prototype, and if contains only a single
9343  *      OP_CONST, return the value; or if it contains a single PADSV ref-
9344  *      erencing an outer lexical, turn on CvCONST to indicate the CV is
9345  *      a candidate for "constizing" at clone time, and return NULL.
9346  */
9347
9348 static SV *
9349 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
9350 {
9351     SV *sv = NULL;
9352     bool padsv = FALSE;
9353
9354     assert(o);
9355     assert(cv);
9356
9357     for (; o; o = o->op_next) {
9358         const OPCODE type = o->op_type;
9359
9360         if (type == OP_NEXTSTATE || type == OP_LINESEQ
9361              || type == OP_NULL
9362              || type == OP_PUSHMARK)
9363                 continue;
9364         if (type == OP_DBSTATE)
9365                 continue;
9366         if (type == OP_LEAVESUB)
9367             break;
9368         if (sv)
9369             return NULL;
9370         if (type == OP_CONST && cSVOPo->op_sv)
9371             sv = cSVOPo->op_sv;
9372         else if (type == OP_UNDEF && !o->op_private) {
9373             sv = newSV(0);
9374             SAVEFREESV(sv);
9375         }
9376         else if (allow_lex && type == OP_PADSV) {
9377                 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
9378                 {
9379                     sv = &PL_sv_undef; /* an arbitrary non-null value */
9380                     padsv = TRUE;
9381                 }
9382                 else
9383                     return NULL;
9384         }
9385         else {
9386             return NULL;
9387         }
9388     }
9389     if (padsv) {
9390         CvCONST_on(cv);
9391         return NULL;
9392     }
9393     return sv;
9394 }
9395
9396 static void
9397 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
9398                         PADNAME * const name, SV ** const const_svp)
9399 {
9400     assert (cv);
9401     assert (o || name);
9402     assert (const_svp);
9403     if (!block) {
9404         if (CvFLAGS(PL_compcv)) {
9405             /* might have had built-in attrs applied */
9406             const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
9407             if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
9408              && ckWARN(WARN_MISC))
9409             {
9410                 /* protect against fatal warnings leaking compcv */
9411                 SAVEFREESV(PL_compcv);
9412                 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
9413                 SvREFCNT_inc_simple_void_NN(PL_compcv);
9414             }
9415             CvFLAGS(cv) |=
9416                 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
9417                   & ~(CVf_LVALUE * pureperl));
9418         }
9419         return;
9420     }
9421
9422     /* redundant check for speed: */
9423     if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
9424         const line_t oldline = CopLINE(PL_curcop);
9425         SV *namesv = o
9426             ? cSVOPo->op_sv
9427             : sv_2mortal(newSVpvn_utf8(
9428                 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
9429               ));
9430         if (PL_parser && PL_parser->copline != NOLINE)
9431             /* This ensures that warnings are reported at the first
9432                line of a redefinition, not the last.  */
9433             CopLINE_set(PL_curcop, PL_parser->copline);
9434         /* protect against fatal warnings leaking compcv */
9435         SAVEFREESV(PL_compcv);
9436         report_redefined_cv(namesv, cv, const_svp);
9437         SvREFCNT_inc_simple_void_NN(PL_compcv);
9438         CopLINE_set(PL_curcop, oldline);
9439     }
9440     SAVEFREESV(cv);
9441     return;
9442 }
9443
9444 CV *
9445 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
9446 {
9447     CV **spot;
9448     SV **svspot;
9449     const char *ps;
9450     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
9451     U32 ps_utf8 = 0;
9452     CV *cv = NULL;
9453     CV *compcv = PL_compcv;
9454     SV *const_sv;
9455     PADNAME *name;
9456     PADOFFSET pax = o->op_targ;
9457     CV *outcv = CvOUTSIDE(PL_compcv);
9458     CV *clonee = NULL;
9459     HEK *hek = NULL;
9460     bool reusable = FALSE;
9461     OP *start = NULL;
9462 #ifdef PERL_DEBUG_READONLY_OPS
9463     OPSLAB *slab = NULL;
9464 #endif
9465
9466     PERL_ARGS_ASSERT_NEWMYSUB;
9467
9468     PL_hints |= HINT_BLOCK_SCOPE;
9469
9470     /* Find the pad slot for storing the new sub.
9471        We cannot use PL_comppad, as it is the pad owned by the new sub.  We
9472        need to look in CvOUTSIDE and find the pad belonging to the enclos-
9473        ing sub.  And then we need to dig deeper if this is a lexical from
9474        outside, as in:
9475            my sub foo; sub { sub foo { } }
9476      */
9477   redo:
9478     name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
9479     if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
9480         pax = PARENT_PAD_INDEX(name);
9481         outcv = CvOUTSIDE(outcv);
9482         assert(outcv);
9483         goto redo;
9484     }
9485     svspot =
9486         &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
9487                         [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
9488     spot = (CV **)svspot;
9489
9490     if (!(PL_parser && PL_parser->error_count))
9491         move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name), 0);
9492
9493     if (proto) {
9494         assert(proto->op_type == OP_CONST);
9495         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
9496         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
9497     }
9498     else
9499         ps = NULL;
9500
9501     if (proto)
9502         SAVEFREEOP(proto);
9503     if (attrs)
9504         SAVEFREEOP(attrs);
9505
9506     if (PL_parser && PL_parser->error_count) {
9507         op_free(block);
9508         SvREFCNT_dec(PL_compcv);
9509         PL_compcv = 0;
9510         goto done;
9511     }
9512
9513     if (CvDEPTH(outcv) && CvCLONE(compcv)) {
9514         cv = *spot;
9515         svspot = (SV **)(spot = &clonee);
9516     }
9517     else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
9518         cv = *spot;
9519     else {
9520         assert (SvTYPE(*spot) == SVt_PVCV);
9521         if (CvNAMED(*spot))
9522             hek = CvNAME_HEK(*spot);
9523         else {
9524             dVAR;
9525             U32 hash;
9526             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
9527             CvNAME_HEK_set(*spot, hek =
9528                 share_hek(
9529                     PadnamePV(name)+1,
9530                     (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
9531                     hash
9532                 )
9533             );
9534             CvLEXICAL_on(*spot);
9535         }
9536         cv = PadnamePROTOCV(name);
9537         svspot = (SV **)(spot = &PadnamePROTOCV(name));
9538     }
9539
9540     if (block) {
9541         /* This makes sub {}; work as expected.  */
9542         if (block->op_type == OP_STUB) {
9543             const line_t l = PL_parser->copline;
9544             op_free(block);
9545             block = newSTATEOP(0, NULL, 0);
9546             PL_parser->copline = l;
9547         }
9548         block = CvLVALUE(compcv)
9549              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
9550                    ? newUNOP(OP_LEAVESUBLV, 0,
9551                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
9552                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
9553         start = LINKLIST(block);
9554         block->op_next = 0;
9555         if (ps && !*ps && !attrs && !CvLVALUE(compcv))
9556             const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
9557         else
9558             const_sv = NULL;
9559     }
9560     else
9561         const_sv = NULL;
9562
9563     if (cv) {
9564         const bool exists = CvROOT(cv) || CvXSUB(cv);
9565
9566         /* if the subroutine doesn't exist and wasn't pre-declared
9567          * with a prototype, assume it will be AUTOLOADed,
9568          * skipping the prototype check
9569          */
9570         if (exists || SvPOK(cv))
9571             cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
9572                                  ps_utf8);
9573         /* already defined? */
9574         if (exists) {
9575             S_already_defined(aTHX_ cv, block, NULL, name, &const_sv);
9576             if (block)
9577                 cv = NULL;
9578             else {
9579                 if (attrs)
9580                     goto attrs;
9581                 /* just a "sub foo;" when &foo is already defined */
9582                 SAVEFREESV(compcv);
9583                 goto done;
9584             }
9585         }
9586         else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
9587             cv = NULL;
9588             reusable = TRUE;
9589         }
9590     }
9591
9592     if (const_sv) {
9593         SvREFCNT_inc_simple_void_NN(const_sv);
9594         SvFLAGS(const_sv) |= SVs_PADTMP;
9595         if (cv) {
9596             assert(!CvROOT(cv) && !CvCONST(cv));
9597             cv_forget_slab(cv);
9598         }
9599         else {
9600             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9601             CvFILE_set_from_cop(cv, PL_curcop);
9602             CvSTASH_set(cv, PL_curstash);
9603             *spot = cv;
9604         }
9605         SvPVCLEAR(MUTABLE_SV(cv));  /* prototype is "" */
9606         CvXSUBANY(cv).any_ptr = const_sv;
9607         CvXSUB(cv) = const_sv_xsub;
9608         CvCONST_on(cv);
9609         CvISXSUB_on(cv);
9610         PoisonPADLIST(cv);
9611         CvFLAGS(cv) |= CvMETHOD(compcv);
9612         op_free(block);
9613         SvREFCNT_dec(compcv);
9614         PL_compcv = NULL;
9615         goto setname;
9616     }
9617
9618     /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
9619        determine whether this sub definition is in the same scope as its
9620        declaration.  If this sub definition is inside an inner named pack-
9621        age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
9622        the package sub.  So check PadnameOUTER(name) too.
9623      */
9624     if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
9625         assert(!CvWEAKOUTSIDE(compcv));
9626         SvREFCNT_dec(CvOUTSIDE(compcv));
9627         CvWEAKOUTSIDE_on(compcv);
9628     }
9629     /* XXX else do we have a circular reference? */
9630
9631     if (cv) {   /* must reuse cv in case stub is referenced elsewhere */
9632         /* transfer PL_compcv to cv */
9633         if (block) {
9634             cv_flags_t preserved_flags =
9635                 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
9636             PADLIST *const temp_padl = CvPADLIST(cv);
9637             CV *const temp_cv = CvOUTSIDE(cv);
9638             const cv_flags_t other_flags =
9639                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
9640             OP * const cvstart = CvSTART(cv);
9641
9642             SvPOK_off(cv);
9643             CvFLAGS(cv) =
9644                 CvFLAGS(compcv) | preserved_flags;
9645             CvOUTSIDE(cv) = CvOUTSIDE(compcv);
9646             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
9647             CvPADLIST_set(cv, CvPADLIST(compcv));
9648             CvOUTSIDE(compcv) = temp_cv;
9649             CvPADLIST_set(compcv, temp_padl);
9650             CvSTART(cv) = CvSTART(compcv);
9651             CvSTART(compcv) = cvstart;
9652             CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
9653             CvFLAGS(compcv) |= other_flags;
9654
9655             if (CvFILE(cv) && CvDYNFILE(cv)) {
9656                 Safefree(CvFILE(cv));
9657             }
9658
9659             /* inner references to compcv must be fixed up ... */
9660             pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
9661             if (PERLDB_INTER)/* Advice debugger on the new sub. */
9662                 ++PL_sub_generation;
9663         }
9664         else {
9665             /* Might have had built-in attributes applied -- propagate them. */
9666             CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
9667         }
9668         /* ... before we throw it away */
9669         SvREFCNT_dec(compcv);
9670         PL_compcv = compcv = cv;
9671     }
9672     else {
9673         cv = compcv;
9674         *spot = cv;
9675     }
9676
9677   setname:
9678     CvLEXICAL_on(cv);
9679     if (!CvNAME_HEK(cv)) {
9680         if (hek) (void)share_hek_hek(hek);
9681         else {
9682             dVAR;
9683             U32 hash;
9684             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
9685             hek = share_hek(PadnamePV(name)+1,
9686                       (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
9687                       hash);
9688         }
9689         CvNAME_HEK_set(cv, hek);
9690     }
9691
9692     if (const_sv)
9693         goto clone;
9694
9695     CvFILE_set_from_cop(cv, PL_curcop);
9696     CvSTASH_set(cv, PL_curstash);
9697
9698     if (ps) {
9699         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
9700         if (ps_utf8)
9701             SvUTF8_on(MUTABLE_SV(cv));
9702     }
9703
9704     if (block) {
9705         /* If we assign an optree to a PVCV, then we've defined a
9706          * subroutine that the debugger could be able to set a breakpoint
9707          * in, so signal to pp_entereval that it should not throw away any
9708          * saved lines at scope exit.  */
9709
9710         PL_breakable_sub_gen++;
9711         CvROOT(cv) = block;
9712         /* The cv no longer needs to hold a refcount on the slab, as CvROOT
9713            itself has a refcount. */
9714         CvSLABBED_off(cv);
9715         OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
9716 #ifdef PERL_DEBUG_READONLY_OPS
9717         slab = (OPSLAB *)CvSTART(cv);
9718 #endif
9719         S_process_optree(aTHX_ cv, block, start);
9720     }
9721
9722   attrs:
9723     if (attrs) {
9724         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
9725         apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
9726     }
9727
9728     if (block) {
9729         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
9730             SV * const tmpstr = sv_newmortal();
9731             GV * const db_postponed = gv_fetchpvs("DB::postponed",
9732                                                   GV_ADDMULTI, SVt_PVHV);
9733             HV *hv;
9734             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
9735                                           CopFILE(PL_curcop),
9736                                           (long)PL_subline,
9737                                           (long)CopLINE(PL_curcop));
9738             if (HvNAME_HEK(PL_curstash)) {
9739                 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
9740                 sv_catpvs(tmpstr, "::");
9741             }
9742             else
9743                 sv_setpvs(tmpstr, "__ANON__::");
9744
9745             sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
9746                             PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
9747             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
9748                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
9749             hv = GvHVn(db_postponed);
9750             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
9751                 CV * const pcv = GvCV(db_postponed);
9752                 if (pcv) {
9753                     dSP;
9754                     PUSHMARK(SP);
9755                     XPUSHs(tmpstr);
9756                     PUTBACK;
9757                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
9758                 }
9759             }
9760         }
9761     }
9762
9763   clone:
9764     if (clonee) {
9765         assert(CvDEPTH(outcv));
9766         spot = (CV **)
9767             &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
9768         if (reusable)
9769             cv_clone_into(clonee, *spot);
9770         else *spot = cv_clone(clonee);
9771         SvREFCNT_dec_NN(clonee);
9772         cv = *spot;
9773     }
9774
9775     if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
9776         PADOFFSET depth = CvDEPTH(outcv);
9777         while (--depth) {
9778             SV *oldcv;
9779             svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
9780             oldcv = *svspot;
9781             *svspot = SvREFCNT_inc_simple_NN(cv);
9782             SvREFCNT_dec(oldcv);
9783         }
9784     }
9785
9786   done:
9787     if (PL_parser)
9788         PL_parser->copline = NOLINE;
9789     LEAVE_SCOPE(floor);
9790 #ifdef PERL_DEBUG_READONLY_OPS
9791     if (slab)
9792         Slab_to_ro(slab);
9793 #endif
9794     op_free(o);
9795     return cv;
9796 }
9797
9798 /*
9799 =for apidoc m|CV *|newATTRSUB_x|I32 floor|OP *o|OP *proto|OP *attrs|OP *block|bool o_is_gv
9800
9801 Construct a Perl subroutine, also performing some surrounding jobs.
9802
9803 This function is expected to be called in a Perl compilation context,
9804 and some aspects of the subroutine are taken from global variables
9805 associated with compilation.  In particular, C<PL_compcv> represents
9806 the subroutine that is currently being compiled.  It must be non-null
9807 when this function is called, and some aspects of the subroutine being
9808 constructed are taken from it.  The constructed subroutine may actually
9809 be a reuse of the C<PL_compcv> object, but will not necessarily be so.
9810
9811 If C<block> is null then the subroutine will have no body, and for the
9812 time being it will be an error to call it.  This represents a forward
9813 subroutine declaration such as S<C<sub foo ($$);>>.  If C<block> is
9814 non-null then it provides the Perl code of the subroutine body, which
9815 will be executed when the subroutine is called.  This body includes
9816 any argument unwrapping code resulting from a subroutine signature or
9817 similar.  The pad use of the code must correspond to the pad attached
9818 to C<PL_compcv>.  The code is not expected to include a C<leavesub> or
9819 C<leavesublv> op; this function will add such an op.  C<block> is consumed
9820 by this function and will become part of the constructed subroutine.
9821
9822 C<proto> specifies the subroutine's prototype, unless one is supplied
9823 as an attribute (see below).  If C<proto> is null, then the subroutine
9824 will not have a prototype.  If C<proto> is non-null, it must point to a
9825 C<const> op whose value is a string, and the subroutine will have that
9826 string as its prototype.  If a prototype is supplied as an attribute, the
9827 attribute takes precedence over C<proto>, but in that case C<proto> should
9828 preferably be null.  In any case, C<proto> is consumed by this function.
9829
9830 C<attrs> supplies attributes to be applied the subroutine.  A handful of
9831 attributes take effect by built-in means, being applied to C<PL_compcv>
9832 immediately when seen.  Other attributes are collected up and attached
9833 to the subroutine by this route.  C<attrs> may be null to supply no
9834 attributes, or point to a C<const> op for a single attribute, or point
9835 to a C<list> op whose children apart from the C<pushmark> are C<const>
9836 ops for one or more attributes.  Each C<const> op must be a string,
9837 giving the attribute name optionally followed by parenthesised arguments,
9838 in the manner in which attributes appear in Perl source.  The attributes
9839 will be applied to the sub by this function.  C<attrs> is consumed by
9840 this function.
9841
9842 If C<o_is_gv> is false and C<o> is null, then the subroutine will
9843 be anonymous.  If C<o_is_gv> is false and C<o> is non-null, then C<o>
9844 must point to a C<const> op, which will be consumed by this function,
9845 and its string value supplies a name for the subroutine.  The name may
9846 be qualified or unqualified, and if it is unqualified then a default
9847 stash will be selected in some manner.  If C<o_is_gv> is true, then C<o>
9848 doesn't point to an C<OP> at all, but is instead a cast pointer to a C<GV>
9849 by which the subroutine will be named.
9850
9851 If there is already a subroutine of the specified name, then the new
9852 sub will either replace the existing one in the glob or be merged with
9853 the existing one.  A warning may be generated about redefinition.
9854
9855 If the subroutine has one of a few special names, such as C<BEGIN> or
9856 C<END>, then it will be claimed by the appropriate queue for automatic
9857 running of phase-related subroutines.  In this case the relevant glob will
9858 be left not containing any subroutine, even if it did contain one before.
9859 In the case of C<BEGIN>, the subroutine will be executed and the reference
9860 to it disposed of before this function returns.
9861
9862 The function returns a pointer to the constructed subroutine.  If the sub
9863 is anonymous then ownership of one counted reference to the subroutine
9864 is transferred to the caller.  If the sub is named then the caller does
9865 not get ownership of a reference.  In most such cases, where the sub
9866 has a non-phase name, the sub will be alive at the point it is returned
9867 by virtue of being contained in the glob that names it.  A phase-named
9868 subroutine will usually be alive by virtue of the reference owned by the
9869 phase's automatic run queue.  But a C<BEGIN> subroutine, having already
9870 been executed, will quite likely have been destroyed already by the
9871 time this function returns, making it erroneous for the caller to make
9872 any use of the returned pointer.  It is the caller's responsibility to
9873 ensure that it knows which of these situations applies.
9874
9875 =cut
9876 */
9877
9878 /* _x = extended */
9879 CV *
9880 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
9881                             OP *block, bool o_is_gv)
9882 {
9883     GV *gv;
9884     const char *ps;
9885     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
9886     U32 ps_utf8 = 0;
9887     CV *cv = NULL;     /* the previous CV with this name, if any */
9888     SV *const_sv;
9889     const bool ec = PL_parser && PL_parser->error_count;
9890     /* If the subroutine has no body, no attributes, and no builtin attributes
9891        then it's just a sub declaration, and we may be able to get away with
9892        storing with a placeholder scalar in the symbol table, rather than a
9893        full CV.  If anything is present then it will take a full CV to
9894        store it.  */
9895     const I32 gv_fetch_flags
9896         = ec ? GV_NOADD_NOINIT :
9897         (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
9898         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
9899     STRLEN namlen = 0;
9900     const char * const name =
9901          o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
9902     bool has_name;
9903     bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
9904     bool evanescent = FALSE;
9905     OP *start = NULL;
9906 #ifdef PERL_DEBUG_READONLY_OPS
9907     OPSLAB *slab = NULL;
9908 #endif
9909
9910     if (o_is_gv) {
9911         gv = (GV*)o;
9912         o = NULL;
9913         has_name = TRUE;
9914     } else if (name) {
9915         /* Try to optimise and avoid creating a GV.  Instead, the CV’s name
9916            hek and CvSTASH pointer together can imply the GV.  If the name
9917            contains a package name, then GvSTASH(CvGV(cv)) may differ from
9918            CvSTASH, so forego the optimisation if we find any.
9919            Also, we may be called from load_module at run time, so
9920            PL_curstash (which sets CvSTASH) may not point to the stash the
9921            sub is stored in.  */
9922         /* XXX This optimization is currently disabled for packages other
9923                than main, since there was too much CPAN breakage.  */
9924         const I32 flags =
9925            ec ? GV_NOADD_NOINIT
9926               :   (IN_PERL_RUNTIME && PL_curstash != CopSTASH(PL_curcop))
9927                || PL_curstash != PL_defstash
9928                || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
9929                     ? gv_fetch_flags
9930                     : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
9931         gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
9932         has_name = TRUE;
9933     } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
9934         SV * const sv = sv_newmortal();
9935         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%" IVdf "]",
9936                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
9937                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
9938         gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
9939         has_name = TRUE;
9940     } else if (PL_curstash) {
9941         gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
9942         has_name = FALSE;
9943     } else {
9944         gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
9945         has_name = FALSE;
9946     }
9947
9948     if (!ec) {
9949         if (isGV(gv)) {
9950             move_proto_attr(&proto, &attrs, gv, 0);
9951         } else {
9952             assert(cSVOPo);
9953             move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv, 1);
9954         }
9955     }
9956
9957     if (proto) {
9958         assert(proto->op_type == OP_CONST);
9959         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
9960         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
9961     }
9962     else
9963         ps = NULL;
9964
9965     if (o)
9966         SAVEFREEOP(o);
9967     if (proto)
9968         SAVEFREEOP(proto);
9969     if (attrs)
9970         SAVEFREEOP(attrs);
9971
9972     if (ec) {
9973         op_free(block);
9974
9975         if (name)
9976             SvREFCNT_dec(PL_compcv);
9977         else
9978             cv = PL_compcv;
9979
9980         PL_compcv = 0;
9981         if (name && block) {
9982             const char *s = (char *) my_memrchr(name, ':', namlen);
9983             s = s ? s+1 : name;
9984             if (strEQ(s, "BEGIN")) {
9985                 if (PL_in_eval & EVAL_KEEPERR)
9986                     Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
9987                 else {
9988                     SV * const errsv = ERRSV;
9989                     /* force display of errors found but not reported */
9990                     sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
9991                     Perl_croak_nocontext("%" SVf, SVfARG(errsv));
9992                 }
9993             }
9994         }
9995         goto done;
9996     }
9997
9998     if (!block && SvTYPE(gv) != SVt_PVGV) {
9999         /* If we are not defining a new sub and the existing one is not a
10000            full GV + CV... */
10001         if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
10002             /* We are applying attributes to an existing sub, so we need it
10003                upgraded if it is a constant.  */
10004             if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
10005                 gv_init_pvn(gv, PL_curstash, name, namlen,
10006                             SVf_UTF8 * name_is_utf8);
10007         }
10008         else {                  /* Maybe prototype now, and had at maximum
10009                                    a prototype or const/sub ref before.  */
10010             if (SvTYPE(gv) > SVt_NULL) {
10011                 cv_ckproto_len_flags((const CV *)gv,
10012                                     o ? (const GV *)cSVOPo->op_sv : NULL, ps,
10013                                     ps_len, ps_utf8);
10014             }
10015
10016             if (!SvROK(gv)) {
10017                 if (ps) {
10018                     sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
10019                     if (ps_utf8)
10020                         SvUTF8_on(MUTABLE_SV(gv));
10021                 }
10022                 else
10023                     sv_setiv(MUTABLE_SV(gv), -1);
10024             }
10025
10026             SvREFCNT_dec(PL_compcv);
10027             cv = PL_compcv = NULL;
10028             goto done;
10029         }
10030     }
10031
10032     cv = (!name || (isGV(gv) && GvCVGEN(gv)))
10033         ? NULL
10034         : isGV(gv)
10035             ? GvCV(gv)
10036             : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
10037                 ? (CV *)SvRV(gv)
10038                 : NULL;
10039
10040     if (block) {
10041         assert(PL_parser);
10042         /* This makes sub {}; work as expected.  */
10043         if (block->op_type == OP_STUB) {
10044             const line_t l = PL_parser->copline;
10045             op_free(block);
10046             block = newSTATEOP(0, NULL, 0);
10047             PL_parser->copline = l;
10048         }
10049         block = CvLVALUE(PL_compcv)
10050              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
10051                     && (!isGV(gv) || !GvASSUMECV(gv)))
10052                    ? newUNOP(OP_LEAVESUBLV, 0,
10053                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
10054                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
10055         start = LINKLIST(block);
10056         block->op_next = 0;
10057         if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
10058             const_sv =
10059                 S_op_const_sv(aTHX_ start, PL_compcv,
10060                                         cBOOL(CvCLONE(PL_compcv)));
10061         else
10062             const_sv = NULL;
10063     }
10064     else
10065         const_sv = NULL;
10066
10067     if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
10068         cv_ckproto_len_flags((const CV *)gv,
10069                              o ? (const GV *)cSVOPo->op_sv : NULL, ps,
10070                              ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
10071         if (SvROK(gv)) {
10072             /* All the other code for sub redefinition warnings expects the
10073                clobbered sub to be a CV.  Instead of making all those code
10074                paths more complex, just inline the RV version here.  */
10075             const line_t oldline = CopLINE(PL_curcop);
10076             assert(IN_PERL_COMPILETIME);
10077             if (PL_parser && PL_parser->copline != NOLINE)
10078                 /* This ensures that warnings are reported at the first
10079                    line of a redefinition, not the last.  */
10080                 CopLINE_set(PL_curcop, PL_parser->copline);
10081             /* protect against fatal warnings leaking compcv */
10082             SAVEFREESV(PL_compcv);
10083
10084             if (ckWARN(WARN_REDEFINE)
10085              || (  ckWARN_d(WARN_REDEFINE)
10086                 && (  !const_sv || SvRV(gv) == const_sv
10087                    || sv_cmp(SvRV(gv), const_sv)  ))) {
10088                 assert(cSVOPo);
10089                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10090                           "Constant subroutine %" SVf " redefined",
10091                           SVfARG(cSVOPo->op_sv));
10092             }
10093
10094             SvREFCNT_inc_simple_void_NN(PL_compcv);
10095             CopLINE_set(PL_curcop, oldline);
10096             SvREFCNT_dec(SvRV(gv));
10097         }
10098     }
10099
10100     if (cv) {
10101         const bool exists = CvROOT(cv) || CvXSUB(cv);
10102
10103         /* if the subroutine doesn't exist and wasn't pre-declared
10104          * with a prototype, assume it will be AUTOLOADed,
10105          * skipping the prototype check
10106          */
10107         if (exists || SvPOK(cv))
10108             cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
10109         /* already defined (or promised)? */
10110         if (exists || (isGV(gv) && GvASSUMECV(gv))) {
10111             S_already_defined(aTHX_ cv, block, o, NULL, &const_sv);
10112             if (block)
10113                 cv = NULL;
10114             else {
10115                 if (attrs)
10116                     goto attrs;
10117                 /* just a "sub foo;" when &foo is already defined */
10118                 SAVEFREESV(PL_compcv);
10119                 goto done;
10120             }
10121         }
10122     }
10123
10124     if (const_sv) {
10125         SvREFCNT_inc_simple_void_NN(const_sv);
10126         SvFLAGS(const_sv) |= SVs_PADTMP;
10127         if (cv) {
10128             assert(!CvROOT(cv) && !CvCONST(cv));
10129             cv_forget_slab(cv);
10130             SvPVCLEAR(MUTABLE_SV(cv));  /* prototype is "" */
10131             CvXSUBANY(cv).any_ptr = const_sv;
10132             CvXSUB(cv) = const_sv_xsub;
10133             CvCONST_on(cv);
10134             CvISXSUB_on(cv);
10135             PoisonPADLIST(cv);
10136             CvFLAGS(cv) |= CvMETHOD(PL_compcv);
10137         }
10138         else {
10139             if (isGV(gv) || CvMETHOD(PL_compcv)) {
10140                 if (name && isGV(gv))
10141                     GvCV_set(gv, NULL);
10142                 cv = newCONSTSUB_flags(
10143                     NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
10144                     const_sv
10145                 );
10146                 assert(cv);
10147                 assert(SvREFCNT((SV*)cv) != 0);
10148                 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
10149             }
10150             else {
10151                 if (!SvROK(gv)) {
10152                     SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
10153                     prepare_SV_for_RV((SV *)gv);
10154                     SvOK_off((SV *)gv);
10155                     SvROK_on(gv);
10156                 }
10157                 SvRV_set(gv, const_sv);
10158             }
10159         }
10160         op_free(block);
10161         SvREFCNT_dec(PL_compcv);
10162         PL_compcv = NULL;
10163         goto done;
10164     }
10165
10166     /* don't copy new BEGIN CV to old BEGIN CV - RT #129099 */
10167     if (name && cv && *name == 'B' && strEQ(name, "BEGIN"))
10168         cv = NULL;
10169
10170     if (cv) {                           /* must reuse cv if autoloaded */
10171         /* transfer PL_compcv to cv */
10172         if (block) {
10173             cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
10174             PADLIST *const temp_av = CvPADLIST(cv);
10175             CV *const temp_cv = CvOUTSIDE(cv);
10176             const cv_flags_t other_flags =
10177                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
10178             OP * const cvstart = CvSTART(cv);
10179
10180             if (isGV(gv)) {
10181                 CvGV_set(cv,gv);
10182                 assert(!CvCVGV_RC(cv));
10183                 assert(CvGV(cv) == gv);
10184             }
10185             else {
10186                 dVAR;
10187                 U32 hash;
10188                 PERL_HASH(hash, name, namlen);
10189                 CvNAME_HEK_set(cv,
10190                                share_hek(name,
10191                                          name_is_utf8
10192                                             ? -(SSize_t)namlen
10193                                             :  (SSize_t)namlen,
10194                                          hash));
10195             }
10196
10197             SvPOK_off(cv);
10198             CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
10199                                              | CvNAMED(cv);
10200             CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
10201             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
10202             CvPADLIST_set(cv,CvPADLIST(PL_compcv));
10203             CvOUTSIDE(PL_compcv) = temp_cv;
10204             CvPADLIST_set(PL_compcv, temp_av);
10205             CvSTART(cv) = CvSTART(PL_compcv);
10206             CvSTART(PL_compcv) = cvstart;
10207             CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
10208             CvFLAGS(PL_compcv) |= other_flags;
10209
10210             if (CvFILE(cv) && CvDYNFILE(cv)) {
10211                 Safefree(CvFILE(cv));
10212             }
10213             CvFILE_set_from_cop(cv, PL_curcop);
10214             CvSTASH_set(cv, PL_curstash);
10215
10216             /* inner references to PL_compcv must be fixed up ... */
10217             pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
10218             if (PERLDB_INTER)/* Advice debugger on the new sub. */
10219                 ++PL_sub_generation;
10220         }
10221         else {
10222             /* Might have had built-in attributes applied -- propagate them. */
10223             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
10224         }
10225         /* ... before we throw it away */
10226         SvREFCNT_dec(PL_compcv);
10227         PL_compcv = cv;
10228     }
10229     else {
10230         cv = PL_compcv;
10231         if (name && isGV(gv)) {
10232             GvCV_set(gv, cv);
10233             GvCVGEN(gv) = 0;
10234             if (HvENAME_HEK(GvSTASH(gv)))
10235                 /* sub Foo::bar { (shift)+1 } */
10236                 gv_method_changed(gv);
10237         }
10238         else if (name) {
10239             if (!SvROK(gv)) {
10240                 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
10241                 prepare_SV_for_RV((SV *)gv);
10242                 SvOK_off((SV *)gv);
10243                 SvROK_on(gv);
10244             }
10245             SvRV_set(gv, (SV *)cv);
10246             if (HvENAME_HEK(PL_curstash))
10247                 mro_method_changed_in(PL_curstash);
10248         }
10249     }
10250     assert(cv);
10251     assert(SvREFCNT((SV*)cv) != 0);
10252
10253     if (!CvHASGV(cv)) {
10254         if (isGV(gv))
10255             CvGV_set(cv, gv);
10256         else {
10257             dVAR;
10258             U32 hash;
10259             PERL_HASH(hash, name, namlen);
10260             CvNAME_HEK_set(cv, share_hek(name,
10261                                          name_is_utf8
10262                                             ? -(SSize_t)namlen
10263                                             :  (SSize_t)namlen,
10264                                          hash));
10265         }
10266         CvFILE_set_from_cop(cv, PL_curcop);
10267         CvSTASH_set(cv, PL_curstash);
10268     }
10269
10270     if (ps) {
10271         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
10272         if ( ps_utf8 )
10273             SvUTF8_on(MUTABLE_SV(cv));
10274     }
10275
10276     if (block) {
10277         /* If we assign an optree to a PVCV, then we've defined a
10278          * subroutine that the debugger could be able to set a breakpoint
10279          * in, so signal to pp_entereval that it should not throw away any
10280          * saved lines at scope exit.  */
10281
10282         PL_breakable_sub_gen++;
10283         CvROOT(cv) = block;
10284         /* The cv no longer needs to hold a refcount on the slab, as CvROOT
10285            itself has a refcount. */
10286         CvSLABBED_off(cv);
10287         OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
10288 #ifdef PERL_DEBUG_READONLY_OPS
10289         slab = (OPSLAB *)CvSTART(cv);
10290 #endif
10291         S_process_optree(aTHX_ cv, block, start);
10292     }
10293
10294   attrs:
10295     if (attrs) {
10296         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
10297         HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
10298                         ? GvSTASH(CvGV(cv))
10299                         : PL_curstash;
10300         if (!name)
10301             SAVEFREESV(cv);
10302         apply_attrs(stash, MUTABLE_SV(cv), attrs);
10303         if (!name)
10304             SvREFCNT_inc_simple_void_NN(cv);
10305     }
10306
10307     if (block && has_name) {
10308         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
10309             SV * const tmpstr = cv_name(cv,NULL,0);
10310             GV * const db_postponed = gv_fetchpvs("DB::postponed",
10311                                                   GV_ADDMULTI, SVt_PVHV);
10312             HV *hv;
10313             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
10314                                           CopFILE(PL_curcop),
10315                                           (long)PL_subline,
10316                                           (long)CopLINE(PL_curcop));
10317             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
10318                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
10319             hv = GvHVn(db_postponed);
10320             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
10321                 CV * const pcv = GvCV(db_postponed);
10322                 if (pcv) {
10323                     dSP;
10324                     PUSHMARK(SP);
10325                     XPUSHs(tmpstr);
10326                     PUTBACK;
10327                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
10328                 }
10329             }
10330         }
10331
10332         if (name) {
10333             if (PL_parser && PL_parser->error_count)
10334                 clear_special_blocks(name, gv, cv);
10335             else
10336                 evanescent =
10337                     process_special_blocks(floor, name, gv, cv);
10338         }
10339     }
10340     assert(cv);
10341
10342   done:
10343     assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
10344     if (PL_parser)
10345         PL_parser->copline = NOLINE;
10346     LEAVE_SCOPE(floor);
10347
10348     assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
10349     if (!evanescent) {
10350 #ifdef PERL_DEBUG_READONLY_OPS
10351     if (slab)
10352         Slab_to_ro(slab);
10353 #endif
10354     if (cv && name && block && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
10355         pad_add_weakref(cv);
10356     }
10357     return cv;
10358 }
10359
10360 STATIC void
10361 S_clear_special_blocks(pTHX_ const char *const fullname,
10362                        GV *const gv, CV *const cv) {
10363     const char *colon;
10364     const char *name;
10365
10366     PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
10367
10368     colon = strrchr(fullname,':');
10369     name = colon ? colon + 1 : fullname;
10370
10371     if ((*name == 'B' && strEQ(name, "BEGIN"))
10372         || (*name == 'E' && strEQ(name, "END"))
10373         || (*name == 'U' && strEQ(name, "UNITCHECK"))
10374         || (*name == 'C' && strEQ(name, "CHECK"))
10375         || (*name == 'I' && strEQ(name, "INIT"))) {
10376         if (!isGV(gv)) {
10377             (void)CvGV(cv);
10378             assert(isGV(gv));
10379         }
10380         GvCV_set(gv, NULL);
10381         SvREFCNT_dec_NN(MUTABLE_SV(cv));
10382     }
10383 }
10384
10385 /* Returns true if the sub has been freed.  */
10386 STATIC bool
10387 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
10388                          GV *const gv,
10389                          CV *const cv)
10390 {
10391     const char *const colon = strrchr(fullname,':');
10392     const char *const name = colon ? colon + 1 : fullname;
10393
10394     PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
10395
10396     if (*name == 'B') {
10397         if (strEQ(name, "BEGIN")) {
10398             const I32 oldscope = PL_scopestack_ix;
10399             dSP;
10400             (void)CvGV(cv);
10401             if (floor) LEAVE_SCOPE(floor);
10402             ENTER;
10403             PUSHSTACKi(PERLSI_REQUIRE);
10404             SAVECOPFILE(&PL_compiling);
10405             SAVECOPLINE(&PL_compiling);
10406             SAVEVPTR(PL_curcop);
10407
10408             DEBUG_x( dump_sub(gv) );
10409             Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
10410             GvCV_set(gv,0);             /* cv has been hijacked */
10411             call_list(oldscope, PL_beginav);
10412
10413             POPSTACK;
10414             LEAVE;
10415             return !PL_savebegin;
10416         }
10417         else
10418             return FALSE;
10419     } else {
10420         if (*name == 'E') {
10421             if strEQ(name, "END") {
10422                 DEBUG_x( dump_sub(gv) );
10423                 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
10424             } else
10425                 return FALSE;
10426         } else if (*name == 'U') {
10427             if (strEQ(name, "UNITCHECK")) {
10428                 /* It's never too late to run a unitcheck block */
10429                 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
10430             }
10431             else
10432                 return FALSE;
10433         } else if (*name == 'C') {
10434             if (strEQ(name, "CHECK")) {
10435                 if (PL_main_start)
10436                     /* diag_listed_as: Too late to run %s block */
10437                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
10438                                    "Too late to run CHECK block");
10439                 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
10440             }
10441             else
10442                 return FALSE;
10443         } else if (*name == 'I') {
10444             if (strEQ(name, "INIT")) {
10445                 if (PL_main_start)
10446                     /* diag_listed_as: Too late to run %s block */
10447                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
10448                                    "Too late to run INIT block");
10449                 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
10450             }
10451             else
10452                 return FALSE;
10453         } else
10454             return FALSE;
10455         DEBUG_x( dump_sub(gv) );
10456         (void)CvGV(cv);
10457         GvCV_set(gv,0);         /* cv has been hijacked */
10458         return FALSE;
10459     }
10460 }
10461
10462 /*
10463 =for apidoc Am|CV *|newCONSTSUB|HV *stash|const char *name|SV *sv
10464
10465 Behaves like L</newCONSTSUB_flags>, except that C<name> is nul-terminated
10466 rather than of counted length, and no flags are set.  (This means that
10467 C<name> is always interpreted as Latin-1.)
10468
10469 =cut
10470 */
10471
10472 CV *
10473 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
10474 {
10475     return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
10476 }
10477
10478 /*
10479 =for apidoc Am|CV *|newCONSTSUB_flags|HV *stash|const char *name|STRLEN len|U32 flags|SV *sv
10480
10481 Construct a constant subroutine, also performing some surrounding
10482 jobs.  A scalar constant-valued subroutine is eligible for inlining
10483 at compile-time, and in Perl code can be created by S<C<sub FOO () {
10484 123 }>>.  Other kinds of constant subroutine have other treatment.
10485
10486 The subroutine will have an empty prototype and will ignore any arguments
10487 when called.  Its constant behaviour is determined by C<sv>.  If C<sv>
10488 is null, the subroutine will yield an empty list.  If C<sv> points to a
10489 scalar, the subroutine will always yield that scalar.  If C<sv> points
10490 to an array, the subroutine will always yield a list of the elements of
10491 that array in list context, or the number of elements in the array in
10492 scalar context.  This function takes ownership of one counted reference
10493 to the scalar or array, and will arrange for the object to live as long
10494 as the subroutine does.  If C<sv> points to a scalar then the inlining
10495 assumes that the value of the scalar will never change, so the caller
10496 must ensure that the scalar is not subsequently written to.  If C<sv>
10497 points to an array then no such assumption is made, so it is ostensibly
10498 safe to mutate the array or its elements, but whether this is really
10499 supported has not been determined.
10500
10501 The subroutine will have C<CvFILE> set according to C<PL_curcop>.
10502 Other aspects of the subroutine will be left in their default state.
10503 The caller is free to mutate the subroutine beyond its initial state
10504 after this function has returned.
10505
10506 If C<name> is null then the subroutine will be anonymous, with its
10507 C<CvGV> referring to an C<__ANON__> glob.  If C<name> is non-null then the
10508 subroutine will be named accordingly, referenced by the appropriate glob.
10509 C<name> is a string of length C<len> bytes giving a sigilless symbol
10510 name, in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1
10511 otherwise.  The name may be either qualified or unqualified.  If the
10512 name is unqualified then it defaults to being in the stash specified by
10513 C<stash> if that is non-null, or to C<PL_curstash> if C<stash> is null.
10514 The symbol is always added to the stash if necessary, with C<GV_ADDMULTI>
10515 semantics.
10516
10517 C<flags> should not have bits set other than C<SVf_UTF8>.
10518
10519 If there is already a subroutine of the specified name, then the new sub
10520 will replace the existing one in the glob.  A warning may be generated
10521 about the redefinition.
10522
10523 If the subroutine has one of a few special names, such as C<BEGIN> or
10524 C<END>, then it will be claimed by the appropriate queue for automatic
10525 running of phase-related subroutines.  In this case the relevant glob will
10526 be left not containing any subroutine, even if it did contain one before.
10527 Execution of the subroutine will likely be a no-op, unless C<sv> was
10528 a tied array or the caller modified the subroutine in some interesting
10529 way before it was executed.  In the case of C<BEGIN>, the treatment is
10530 buggy: the sub will be executed when only half built, and may be deleted
10531 prematurely, possibly causing a crash.
10532
10533 The function returns a pointer to the constructed subroutine.  If the sub
10534 is anonymous then ownership of one counted reference to the subroutine
10535 is transferred to the caller.  If the sub is named then the caller does
10536 not get ownership of a reference.  In most such cases, where the sub
10537 has a non-phase name, the sub will be alive at the point it is returned
10538 by virtue of being contained in the glob that names it.  A phase-named
10539 subroutine will usually be alive by virtue of the reference owned by
10540 the phase's automatic run queue.  A C<BEGIN> subroutine may have been
10541 destroyed already by the time this function returns, but currently bugs
10542 occur in that case before the caller gets control.  It is the caller's
10543 responsibility to ensure that it knows which of these situations applies.
10544
10545 =cut
10546 */
10547
10548 CV *
10549 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
10550                              U32 flags, SV *sv)
10551 {
10552     CV* cv;
10553     const char *const file = CopFILE(PL_curcop);
10554
10555     ENTER;
10556
10557     if (IN_PERL_RUNTIME) {
10558         /* at runtime, it's not safe to manipulate PL_curcop: it may be
10559          * an op shared between threads. Use a non-shared COP for our
10560          * dirty work */
10561          SAVEVPTR(PL_curcop);
10562          SAVECOMPILEWARNINGS();
10563          PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
10564          PL_curcop = &PL_compiling;
10565     }
10566     SAVECOPLINE(PL_curcop);
10567     CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
10568
10569     SAVEHINTS();
10570     PL_hints &= ~HINT_BLOCK_SCOPE;
10571
10572     if (stash) {
10573         SAVEGENERICSV(PL_curstash);
10574         PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
10575     }
10576
10577     /* Protect sv against leakage caused by fatal warnings. */
10578     if (sv) SAVEFREESV(sv);
10579
10580     /* file becomes the CvFILE. For an XS, it's usually static storage,
10581        and so doesn't get free()d.  (It's expected to be from the C pre-
10582        processor __FILE__ directive). But we need a dynamically allocated one,
10583        and we need it to get freed.  */
10584     cv = newXS_len_flags(name, len,
10585                          sv && SvTYPE(sv) == SVt_PVAV
10586                              ? const_av_xsub
10587                              : const_sv_xsub,
10588                          file ? file : "", "",
10589                          &sv, XS_DYNAMIC_FILENAME | flags);
10590     assert(cv);
10591     assert(SvREFCNT((SV*)cv) != 0);
10592     CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
10593     CvCONST_on(cv);
10594
10595     LEAVE;
10596
10597     return cv;
10598 }
10599
10600 /*
10601 =for apidoc U||newXS
10602
10603 Used by C<xsubpp> to hook up XSUBs as Perl subs.  C<filename> needs to be
10604 static storage, as it is used directly as CvFILE(), without a copy being made.
10605
10606 =cut
10607 */
10608
10609 CV *
10610 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
10611 {
10612     PERL_ARGS_ASSERT_NEWXS;
10613     return newXS_len_flags(
10614         name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
10615     );
10616 }
10617
10618 CV *
10619 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
10620                  const char *const filename, const char *const proto,
10621                  U32 flags)
10622 {
10623     PERL_ARGS_ASSERT_NEWXS_FLAGS;
10624     return newXS_len_flags(
10625        name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
10626     );
10627 }
10628
10629 CV *
10630 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
10631 {
10632     PERL_ARGS_ASSERT_NEWXS_DEFFILE;
10633     return newXS_len_flags(
10634         name, strlen(name), subaddr, NULL, NULL, NULL, 0
10635     );
10636 }
10637
10638 /*
10639 =for apidoc m|CV *|newXS_len_flags|const char *name|STRLEN len|XSUBADDR_t subaddr|const char *const filename|const char *const proto|SV **const_svp|U32 flags
10640
10641 Construct an XS subroutine, also performing some surrounding jobs.
10642
10643 The subroutine will have the entry point C<subaddr>.  It will have
10644 the prototype specified by the nul-terminated string C<proto>, or
10645 no prototype if C<proto> is null.  The prototype string is copied;
10646 the caller can mutate the supplied string afterwards.  If C<filename>
10647 is non-null, it must be a nul-terminated filename, and the subroutine
10648 will have its C<CvFILE> set accordingly.  By default C<CvFILE> is set to
10649 point directly to the supplied string, which must be static.  If C<flags>
10650 has the C<XS_DYNAMIC_FILENAME> bit set, then a copy of the string will
10651 be taken instead.
10652
10653 Other aspects of the subroutine will be left in their default state.
10654 If anything else needs to be done to the subroutine for it to function
10655 correctly, it is the caller's responsibility to do that after this
10656 function has constructed it.  However, beware of the subroutine
10657 potentially being destroyed before this function returns, as described
10658 below.
10659
10660 If C<name> is null then the subroutine will be anonymous, with its
10661 C<CvGV> referring to an C<__ANON__> glob.  If C<name> is non-null then the
10662 subroutine will be named accordingly, referenced by the appropriate glob.
10663 C<name> is a string of length C<len> bytes giving a sigilless symbol name,
10664 in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1 otherwise.
10665 The name may be either qualified or unqualified, with the stash defaulting
10666 in the same manner as for C<gv_fetchpvn_flags>.  C<flags> may contain
10667 flag bits understood by C<gv_fetchpvn_flags> with the same meaning as
10668 they have there, such as C<GV_ADDWARN>.  The symbol is always added to
10669 the stash if necessary, with C<GV_ADDMULTI> semantics.
10670
10671 If there is already a subroutine of the specified name, then the new sub
10672 will replace the existing one in the glob.  A warning may be generated
10673 about the redefinition.  If the old subroutine was C<CvCONST> then the
10674 decision about whether to warn is influenced by an expectation about
10675 whether the new subroutine will become a constant of similar value.
10676 That expectation is determined by C<const_svp>.  (Note that the call to
10677 this function doesn't make the new subroutine C<CvCONST> in any case;
10678 that is left to the caller.)  If C<const_svp> is null then it indicates
10679 that the new subroutine will not become a constant.  If C<const_svp>
10680 is non-null then it indicates that the new subroutine will become a
10681 constant, and it points to an C<SV*> that provides the constant value
10682 that the subroutine will have.
10683
10684 If the subroutine has one of a few special names, such as C<BEGIN> or
10685 C<END>, then it will be claimed by the appropriate queue for automatic
10686 running of phase-related subroutines.  In this case the relevant glob will
10687 be left not containing any subroutine, even if it did contain one before.
10688 In the case of C<BEGIN>, the subroutine will be executed and the reference
10689 to it disposed of before this function returns, and also before its
10690 prototype is set.  If a C<BEGIN> subroutine would not be sufficiently
10691 constructed by this function to be ready for execution then the caller
10692 must prevent this happening by giving the subroutine a different name.
10693
10694 The function returns a pointer to the constructed subroutine.  If the sub
10695 is anonymous then ownership of one counted reference to the subroutine
10696 is transferred to the caller.  If the sub is named then the caller does
10697 not get ownership of a reference.  In most such cases, where the sub
10698 has a non-phase name, the sub will be alive at the point it is returned
10699 by virtue of being contained in the glob that names it.  A phase-named
10700 subroutine will usually be alive by virtue of the reference owned by the
10701 phase's automatic run queue.  But a C<BEGIN> subroutine, having already
10702 been executed, will quite likely have been destroyed already by the
10703 time this function returns, making it erroneous for the caller to make
10704 any use of the returned pointer.  It is the caller's responsibility to
10705 ensure that it knows which of these situations applies.
10706
10707 =cut
10708 */
10709
10710 CV *
10711 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
10712                            XSUBADDR_t subaddr, const char *const filename,
10713                            const char *const proto, SV **const_svp,
10714                            U32 flags)
10715 {
10716     CV *cv;
10717     bool interleave = FALSE;
10718     bool evanescent = FALSE;
10719
10720     PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
10721
10722     {
10723         GV * const gv = gv_fetchpvn(
10724                             name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
10725                             name ? len : PL_curstash ? sizeof("__ANON__") - 1:
10726                                 sizeof("__ANON__::__ANON__") - 1,
10727                             GV_ADDMULTI | flags, SVt_PVCV);
10728
10729         if ((cv = (name ? GvCV(gv) : NULL))) {
10730             if (GvCVGEN(gv)) {
10731                 /* just a cached method */
10732                 SvREFCNT_dec(cv);
10733                 cv = NULL;
10734             }
10735             else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
10736                 /* already defined (or promised) */
10737                 /* Redundant check that allows us to avoid creating an SV
10738                    most of the time: */
10739                 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
10740                     report_redefined_cv(newSVpvn_flags(
10741                                          name,len,(flags&SVf_UTF8)|SVs_TEMP
10742                                         ),
10743                                         cv, const_svp);
10744                 }
10745                 interleave = TRUE;
10746                 ENTER;
10747                 SAVEFREESV(cv);
10748                 cv = NULL;
10749             }
10750         }
10751
10752         if (cv)                         /* must reuse cv if autoloaded */
10753             cv_undef(cv);
10754         else {
10755             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
10756             if (name) {
10757                 GvCV_set(gv,cv);
10758                 GvCVGEN(gv) = 0;
10759                 if (HvENAME_HEK(GvSTASH(gv)))
10760                     gv_method_changed(gv); /* newXS */
10761             }
10762         }
10763         assert(cv);
10764         assert(SvREFCNT((SV*)cv) != 0);
10765
10766         CvGV_set(cv, gv);
10767         if(filename) {
10768             /* XSUBs can't be perl lang/perl5db.pl debugged
10769             if (PERLDB_LINE_OR_SAVESRC)
10770                 (void)gv_fetchfile(filename); */
10771             assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
10772             if (flags & XS_DYNAMIC_FILENAME) {
10773                 CvDYNFILE_on(cv);
10774                 CvFILE(cv) = savepv(filename);
10775             } else {
10776             /* NOTE: not copied, as it is expected to be an external constant string */
10777                 CvFILE(cv) = (char *)filename;
10778             }
10779         } else {
10780             assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
10781             CvFILE(cv) = (char*)PL_xsubfilename;
10782         }
10783         CvISXSUB_on(cv);
10784         CvXSUB(cv) = subaddr;
10785 #ifndef PERL_IMPLICIT_CONTEXT
10786         CvHSCXT(cv) = &PL_stack_sp;
10787 #else
10788         PoisonPADLIST(cv);
10789 #endif
10790
10791         if (name)
10792             evanescent = process_special_blocks(0, name, gv, cv);
10793         else
10794             CvANON_on(cv);
10795     } /* <- not a conditional branch */
10796
10797     assert(cv);
10798     assert(evanescent || SvREFCNT((SV*)cv) != 0);
10799
10800     if (!evanescent) sv_setpv(MUTABLE_SV(cv), proto);
10801     if (interleave) LEAVE;
10802     assert(evanescent || SvREFCNT((SV*)cv) != 0);
10803     return cv;
10804 }
10805
10806 CV *
10807 Perl_newSTUB(pTHX_ GV *gv, bool fake)
10808 {
10809     CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
10810     GV *cvgv;
10811     PERL_ARGS_ASSERT_NEWSTUB;
10812     assert(!GvCVu(gv));
10813     GvCV_set(gv, cv);
10814     GvCVGEN(gv) = 0;
10815     if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
10816         gv_method_changed(gv);
10817     if (SvFAKE(gv)) {
10818         cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
10819         SvFAKE_off(cvgv);
10820     }
10821     else cvgv = gv;
10822     CvGV_set(cv, cvgv);
10823     CvFILE_set_from_cop(cv, PL_curcop);
10824     CvSTASH_set(cv, PL_curstash);
10825     GvMULTI_on(gv);
10826     return cv;
10827 }
10828
10829 void
10830 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
10831 {
10832     CV *cv;
10833     GV *gv;
10834     OP *root;
10835     OP *start;
10836
10837     if (PL_parser && PL_parser->error_count) {
10838         op_free(block);
10839         goto finish;
10840     }
10841
10842     gv = o
10843         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
10844         : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
10845
10846     GvMULTI_on(gv);
10847     if ((cv = GvFORM(gv))) {
10848         if (ckWARN(WARN_REDEFINE)) {
10849             const line_t oldline = CopLINE(PL_curcop);
10850             if (PL_parser && PL_parser->copline != NOLINE)
10851                 CopLINE_set(PL_curcop, PL_parser->copline);
10852             if (o) {
10853                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10854                             "Format %" SVf " redefined", SVfARG(cSVOPo->op_sv));
10855             } else {
10856                 /* diag_listed_as: Format %s redefined */
10857                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10858                             "Format STDOUT redefined");
10859             }
10860             CopLINE_set(PL_curcop, oldline);
10861         }
10862         SvREFCNT_dec(cv);
10863     }
10864     cv = PL_compcv;
10865     GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
10866     CvGV_set(cv, gv);
10867     CvFILE_set_from_cop(cv, PL_curcop);
10868
10869
10870     root = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
10871     CvROOT(cv) = root;
10872     start = LINKLIST(root);
10873     root->op_next = 0;
10874     S_process_optree(aTHX_ cv, root, start);
10875     cv_forget_slab(cv);
10876
10877   finish:
10878     op_free(o);
10879     if (PL_parser)
10880         PL_parser->copline = NOLINE;
10881     LEAVE_SCOPE(floor);
10882     PL_compiling.cop_seq = 0;
10883 }
10884
10885 OP *
10886 Perl_newANONLIST(pTHX_ OP *o)
10887 {
10888     return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
10889 }
10890
10891 OP *
10892 Perl_newANONHASH(pTHX_ OP *o)
10893 {
10894     return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
10895 }
10896
10897 OP *
10898 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
10899 {
10900     return newANONATTRSUB(floor, proto, NULL, block);
10901 }
10902
10903 OP *
10904 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
10905 {
10906     SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
10907     OP * anoncode =
10908         newSVOP(OP_ANONCODE, 0,
10909                 cv);
10910     if (CvANONCONST(cv))
10911         anoncode = newUNOP(OP_ANONCONST, 0,
10912                            op_convert_list(OP_ENTERSUB,
10913                                            OPf_STACKED|OPf_WANT_SCALAR,
10914                                            anoncode));
10915     return newUNOP(OP_REFGEN, 0, anoncode);
10916 }
10917
10918 OP *
10919 Perl_oopsAV(pTHX_ OP *o)
10920 {
10921     dVAR;
10922
10923     PERL_ARGS_ASSERT_OOPSAV;
10924
10925     switch (o->op_type) {
10926     case OP_PADSV:
10927     case OP_PADHV:
10928         OpTYPE_set(o, OP_PADAV);
10929         return ref(o, OP_RV2AV);
10930
10931     case OP_RV2SV:
10932     case OP_RV2HV:
10933         OpTYPE_set(o, OP_RV2AV);
10934         ref(o, OP_RV2AV);
10935         break;
10936
10937     default:
10938         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
10939         break;
10940     }
10941     return o;
10942 }
10943
10944 OP *
10945 Perl_oopsHV(pTHX_ OP *o)
10946 {
10947     dVAR;
10948
10949     PERL_ARGS_ASSERT_OOPSHV;
10950
10951     switch (o->op_type) {
10952     case OP_PADSV:
10953     case OP_PADAV:
10954         OpTYPE_set(o, OP_PADHV);
10955         return ref(o, OP_RV2HV);
10956
10957     case OP_RV2SV:
10958     case OP_RV2AV:
10959         OpTYPE_set(o, OP_RV2HV);
10960         /* rv2hv steals the bottom bit for its own uses */
10961         o->op_private &= ~OPpARG1_MASK;
10962         ref(o, OP_RV2HV);
10963         break;
10964
10965     default:
10966         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
10967         break;
10968     }
10969     return o;
10970 }
10971
10972 OP *
10973 Perl_newAVREF(pTHX_ OP *o)
10974 {
10975     dVAR;
10976
10977     PERL_ARGS_ASSERT_NEWAVREF;
10978
10979     if (o->op_type == OP_PADANY) {
10980         OpTYPE_set(o, OP_PADAV);
10981         return o;
10982     }
10983     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
10984         Perl_croak(aTHX_ "Can't use an array as a reference");
10985     }
10986     return newUNOP(OP_RV2AV, 0, scalar(o));
10987 }
10988
10989 OP *
10990 Perl_newGVREF(pTHX_ I32 type, OP *o)
10991 {
10992     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
10993         return newUNOP(OP_NULL, 0, o);
10994     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
10995 }
10996
10997 OP *
10998 Perl_newHVREF(pTHX_ OP *o)
10999 {
11000     dVAR;
11001
11002     PERL_ARGS_ASSERT_NEWHVREF;
11003
11004     if (o->op_type == OP_PADANY) {
11005         OpTYPE_set(o, OP_PADHV);
11006         return o;
11007     }
11008     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
11009         Perl_croak(aTHX_ "Can't use a hash as a reference");
11010     }
11011     return newUNOP(OP_RV2HV, 0, scalar(o));
11012 }
11013
11014 OP *
11015 Perl_newCVREF(pTHX_ I32 flags, OP *o)
11016 {
11017     if (o->op_type == OP_PADANY) {
11018         dVAR;
11019         OpTYPE_set(o, OP_PADCV);
11020     }
11021     return newUNOP(OP_RV2CV, flags, scalar(o));
11022 }
11023
11024 OP *
11025 Perl_newSVREF(pTHX_ OP *o)
11026 {
11027     dVAR;
11028
11029     PERL_ARGS_ASSERT_NEWSVREF;
11030
11031     if (o->op_type == OP_PADANY) {
11032         OpTYPE_set(o, OP_PADSV);
11033         scalar(o);
11034         return o;
11035     }
11036     return newUNOP(OP_RV2SV, 0, scalar(o));
11037 }
11038
11039 /* Check routines. See the comments at the top of this file for details
11040  * on when these are called */
11041
11042 OP *
11043 Perl_ck_anoncode(pTHX_ OP *o)
11044 {
11045     PERL_ARGS_ASSERT_CK_ANONCODE;
11046
11047     cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
11048     cSVOPo->op_sv = NULL;
11049     return o;
11050 }
11051
11052 static void
11053 S_io_hints(pTHX_ OP *o)
11054 {
11055 #if O_BINARY != 0 || O_TEXT != 0
11056     HV * const table =
11057         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
11058     if (table) {
11059         SV **svp = hv_fetchs(table, "open_IN", FALSE);
11060         if (svp && *svp) {
11061             STRLEN len = 0;
11062             const char *d = SvPV_const(*svp, len);
11063             const I32 mode = mode_from_discipline(d, len);
11064             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
11065 #  if O_BINARY != 0
11066             if (mode & O_BINARY)
11067                 o->op_private |= OPpOPEN_IN_RAW;
11068 #  endif
11069 #  if O_TEXT != 0
11070             if (mode & O_TEXT)
11071                 o->op_private |= OPpOPEN_IN_CRLF;
11072 #  endif
11073         }
11074
11075         svp = hv_fetchs(table, "open_OUT", FALSE);
11076         if (svp && *svp) {
11077             STRLEN len = 0;
11078             const char *d = SvPV_const(*svp, len);
11079             const I32 mode = mode_from_discipline(d, len);
11080             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
11081 #  if O_BINARY != 0
11082             if (mode & O_BINARY)
11083                 o->op_private |= OPpOPEN_OUT_RAW;
11084 #  endif
11085 #  if O_TEXT != 0
11086             if (mode & O_TEXT)
11087                 o->op_private |= OPpOPEN_OUT_CRLF;
11088 #  endif
11089         }
11090     }
11091 #else
11092     PERL_UNUSED_CONTEXT;
11093     PERL_UNUSED_ARG(o);
11094 #endif
11095 }
11096
11097 OP *
11098 Perl_ck_backtick(pTHX_ OP *o)
11099 {
11100     GV *gv;
11101     OP *newop = NULL;
11102     OP *sibl;
11103     PERL_ARGS_ASSERT_CK_BACKTICK;
11104     o = ck_fun(o);
11105     /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
11106     if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
11107      && (gv = gv_override("readpipe",8)))
11108     {
11109         /* detach rest of siblings from o and its first child */
11110         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
11111         newop = S_new_entersubop(aTHX_ gv, sibl);
11112     }
11113     else if (!(o->op_flags & OPf_KIDS))
11114         newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
11115     if (newop) {
11116         op_free(o);
11117         return newop;
11118     }
11119     S_io_hints(aTHX_ o);
11120     return o;
11121 }
11122
11123 OP *
11124 Perl_ck_bitop(pTHX_ OP *o)
11125 {
11126     PERL_ARGS_ASSERT_CK_BITOP;
11127
11128     o->op_private = (U8)(PL_hints & HINT_INTEGER);
11129
11130     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
11131             && OP_IS_INFIX_BIT(o->op_type))
11132     {
11133         const OP * const left = cBINOPo->op_first;
11134         const OP * const right = OpSIBLING(left);
11135         if ((OP_IS_NUMCOMPARE(left->op_type) &&
11136                 (left->op_flags & OPf_PARENS) == 0) ||
11137             (OP_IS_NUMCOMPARE(right->op_type) &&
11138                 (right->op_flags & OPf_PARENS) == 0))
11139             Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
11140                           "Possible precedence problem on bitwise %s operator",
11141                            o->op_type ==  OP_BIT_OR
11142                          ||o->op_type == OP_NBIT_OR  ? "|"
11143                         :  o->op_type ==  OP_BIT_AND
11144                          ||o->op_type == OP_NBIT_AND ? "&"
11145                         :  o->op_type ==  OP_BIT_XOR
11146                          ||o->op_type == OP_NBIT_XOR ? "^"
11147                         :  o->op_type == OP_SBIT_OR  ? "|."
11148                         :  o->op_type == OP_SBIT_AND ? "&." : "^."
11149                            );
11150     }
11151     return o;
11152 }
11153
11154 PERL_STATIC_INLINE bool
11155 is_dollar_bracket(pTHX_ const OP * const o)
11156 {
11157     const OP *kid;
11158     PERL_UNUSED_CONTEXT;
11159     return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
11160         && (kid = cUNOPx(o)->op_first)
11161         && kid->op_type == OP_GV
11162         && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
11163 }
11164
11165 /* for lt, gt, le, ge, eq, ne and their i_ variants */
11166
11167 OP *
11168 Perl_ck_cmp(pTHX_ OP *o)
11169 {
11170     bool is_eq;
11171     bool neg;
11172     bool reverse;
11173     bool iv0;
11174     OP *indexop, *constop, *start;
11175     SV *sv;
11176     IV iv;
11177
11178     PERL_ARGS_ASSERT_CK_CMP;
11179
11180     is_eq = (   o->op_type == OP_EQ
11181              || o->op_type == OP_NE
11182              || o->op_type == OP_I_EQ
11183              || o->op_type == OP_I_NE);
11184
11185     if (!is_eq && ckWARN(WARN_SYNTAX)) {
11186         const OP *kid = cUNOPo->op_first;
11187         if (kid &&
11188             (
11189                 (   is_dollar_bracket(aTHX_ kid)
11190                  && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
11191                 )
11192              || (   kid->op_type == OP_CONST
11193                  && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
11194                 )
11195            )
11196         )
11197             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11198                         "$[ used in %s (did you mean $] ?)", OP_DESC(o));
11199     }
11200
11201     /* convert (index(...) == -1) and variations into
11202      *   (r)index/BOOL(,NEG)
11203      */
11204
11205     reverse = FALSE;
11206
11207     indexop = cUNOPo->op_first;
11208     constop = OpSIBLING(indexop);
11209     start = NULL;
11210     if (indexop->op_type == OP_CONST) {
11211         constop = indexop;
11212         indexop = OpSIBLING(constop);
11213         start = constop;
11214         reverse = TRUE;
11215     }
11216
11217     if (indexop->op_type != OP_INDEX && indexop->op_type != OP_RINDEX)
11218         return o;
11219
11220     /* ($lex = index(....)) == -1 */
11221     if (indexop->op_private & OPpTARGET_MY)
11222         return o;
11223
11224     if (constop->op_type != OP_CONST)
11225         return o;
11226
11227     sv = cSVOPx_sv(constop);
11228     if (!(sv && SvIOK_notUV(sv)))
11229         return o;
11230
11231     iv = SvIVX(sv);
11232     if (iv != -1 && iv != 0)
11233         return o;
11234     iv0 = (iv == 0);
11235
11236     if (o->op_type == OP_LT || o->op_type == OP_I_LT) {
11237         if (!(iv0 ^ reverse))
11238             return o;
11239         neg = iv0;
11240     }
11241     else if (o->op_type == OP_LE || o->op_type == OP_I_LE) {
11242         if (iv0 ^ reverse)
11243             return o;
11244         neg = !iv0;
11245     }
11246     else if (o->op_type == OP_GE || o->op_type == OP_I_GE) {
11247         if (!(iv0 ^ reverse))
11248             return o;
11249         neg = !iv0;
11250     }
11251     else if (o->op_type == OP_GT || o->op_type == OP_I_GT) {
11252         if (iv0 ^ reverse)
11253             return o;
11254         neg = iv0;
11255     }
11256     else if (o->op_type == OP_EQ || o->op_type == OP_I_EQ) {
11257         if (iv0)
11258             return o;
11259         neg = TRUE;
11260     }
11261     else {
11262         assert(o->op_type == OP_NE || o->op_type == OP_I_NE);
11263         if (iv0)
11264             return o;
11265         neg = FALSE;
11266     }
11267
11268     indexop->op_flags &= ~OPf_PARENS;
11269     indexop->op_flags |= (o->op_flags & OPf_PARENS);
11270     indexop->op_private |= OPpTRUEBOOL;
11271     if (neg)
11272         indexop->op_private |= OPpINDEX_BOOLNEG;
11273     /* cut out the index op and free the eq,const ops */
11274     (void)op_sibling_splice(o, start, 1, NULL);
11275     op_free(o);
11276
11277     return indexop;
11278 }
11279
11280
11281 OP *
11282 Perl_ck_concat(pTHX_ OP *o)
11283 {
11284     const OP * const kid = cUNOPo->op_first;
11285
11286     PERL_ARGS_ASSERT_CK_CONCAT;
11287     PERL_UNUSED_CONTEXT;
11288
11289     /* reuse the padtmp returned by the concat child */
11290     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
11291             !(kUNOP->op_first->op_flags & OPf_MOD))
11292     {
11293         o->op_flags |= OPf_STACKED;
11294         o->op_private |= OPpCONCAT_NESTED;
11295     }
11296     return o;
11297 }
11298
11299 OP *
11300 Perl_ck_spair(pTHX_ OP *o)
11301 {
11302     dVAR;
11303
11304     PERL_ARGS_ASSERT_CK_SPAIR;
11305
11306     if (o->op_flags & OPf_KIDS) {
11307         OP* newop;
11308         OP* kid;
11309         OP* kidkid;
11310         const OPCODE type = o->op_type;
11311         o = modkids(ck_fun(o), type);
11312         kid    = cUNOPo->op_first;
11313         kidkid = kUNOP->op_first;
11314         newop = OpSIBLING(kidkid);
11315         if (newop) {
11316             const OPCODE type = newop->op_type;
11317             if (OpHAS_SIBLING(newop))
11318                 return o;
11319             if (o->op_type == OP_REFGEN
11320              && (  type == OP_RV2CV
11321                 || (  !(newop->op_flags & OPf_PARENS)
11322                    && (  type == OP_RV2AV || type == OP_PADAV
11323                       || type == OP_RV2HV || type == OP_PADHV))))
11324                 NOOP; /* OK (allow srefgen for \@a and \%h) */
11325             else if (OP_GIMME(newop,0) != G_SCALAR)
11326                 return o;
11327         }
11328         /* excise first sibling */
11329         op_sibling_splice(kid, NULL, 1, NULL);
11330         op_free(kidkid);
11331     }
11332     /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
11333      * and OP_CHOMP into OP_SCHOMP */
11334     o->op_ppaddr = PL_ppaddr[++o->op_type];
11335     return ck_fun(o);
11336 }
11337
11338 OP *
11339 Perl_ck_delete(pTHX_ OP *o)
11340 {
11341     PERL_ARGS_ASSERT_CK_DELETE;
11342
11343     o = ck_fun(o);
11344     o->op_private = 0;
11345     if (o->op_flags & OPf_KIDS) {
11346         OP * const kid = cUNOPo->op_first;
11347         switch (kid->op_type) {
11348         case OP_ASLICE:
11349             o->op_flags |= OPf_SPECIAL;
11350             /* FALLTHROUGH */
11351         case OP_HSLICE:
11352             o->op_private |= OPpSLICE;
11353             break;
11354         case OP_AELEM:
11355             o->op_flags |= OPf_SPECIAL;
11356             /* FALLTHROUGH */
11357         case OP_HELEM:
11358             break;
11359         case OP_KVASLICE:
11360             o->op_flags |= OPf_SPECIAL;
11361             /* FALLTHROUGH */
11362         case OP_KVHSLICE:
11363             o->op_private |= OPpKVSLICE;
11364             break;
11365         default:
11366             Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
11367                              "element or slice");
11368         }
11369         if (kid->op_private & OPpLVAL_INTRO)
11370             o->op_private |= OPpLVAL_INTRO;
11371         op_null(kid);
11372     }
11373     return o;
11374 }
11375
11376 OP *
11377 Perl_ck_eof(pTHX_ OP *o)
11378 {
11379     PERL_ARGS_ASSERT_CK_EOF;
11380
11381     if (o->op_flags & OPf_KIDS) {
11382         OP *kid;
11383         if (cLISTOPo->op_first->op_type == OP_STUB) {
11384             OP * const newop
11385                 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
11386             op_free(o);
11387             o = newop;
11388         }
11389         o = ck_fun(o);
11390         kid = cLISTOPo->op_first;
11391         if (kid->op_type == OP_RV2GV)
11392             kid->op_private |= OPpALLOW_FAKE;
11393     }
11394     return o;
11395 }
11396
11397
11398 OP *
11399 Perl_ck_eval(pTHX_ OP *o)
11400 {
11401     dVAR;
11402
11403     PERL_ARGS_ASSERT_CK_EVAL;
11404
11405     PL_hints |= HINT_BLOCK_SCOPE;
11406     if (o->op_flags & OPf_KIDS) {
11407         SVOP * const kid = (SVOP*)cUNOPo->op_first;
11408         assert(kid);
11409
11410         if (o->op_type == OP_ENTERTRY) {
11411             LOGOP *enter;
11412
11413             /* cut whole sibling chain free from o */
11414             op_sibling_splice(o, NULL, -1, NULL);
11415             op_free(o);
11416
11417             enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL);
11418
11419             /* establish postfix order */
11420             enter->op_next = (OP*)enter;
11421
11422             o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
11423             OpTYPE_set(o, OP_LEAVETRY);
11424             enter->op_other = o;
11425             return o;
11426         }
11427         else {
11428             scalar((OP*)kid);
11429             S_set_haseval(aTHX);
11430         }
11431     }
11432     else {
11433         const U8 priv = o->op_private;
11434         op_free(o);
11435         /* the newUNOP will recursively call ck_eval(), which will handle
11436          * all the stuff at the end of this function, like adding
11437          * OP_HINTSEVAL
11438          */
11439         return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
11440     }
11441     o->op_targ = (PADOFFSET)PL_hints;
11442     if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
11443     if ((PL_hints & HINT_LOCALIZE_HH) != 0
11444      && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
11445         /* Store a copy of %^H that pp_entereval can pick up. */
11446         OP *hhop = newSVOP(OP_HINTSEVAL, 0,
11447                            MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
11448         /* append hhop to only child  */
11449         op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
11450
11451         o->op_private |= OPpEVAL_HAS_HH;
11452     }
11453     if (!(o->op_private & OPpEVAL_BYTES)
11454          && FEATURE_UNIEVAL_IS_ENABLED)
11455             o->op_private |= OPpEVAL_UNICODE;
11456     return o;
11457 }
11458
11459 OP *
11460 Perl_ck_exec(pTHX_ OP *o)
11461 {
11462     PERL_ARGS_ASSERT_CK_EXEC;
11463
11464     if (o->op_flags & OPf_STACKED) {
11465         OP *kid;
11466         o = ck_fun(o);
11467         kid = OpSIBLING(cUNOPo->op_first);
11468         if (kid->op_type == OP_RV2GV)
11469             op_null(kid);
11470     }
11471     else
11472         o = listkids(o);
11473     return o;
11474 }
11475
11476 OP *
11477 Perl_ck_exists(pTHX_ OP *o)
11478 {
11479     PERL_ARGS_ASSERT_CK_EXISTS;
11480
11481     o = ck_fun(o);
11482     if (o->op_flags & OPf_KIDS) {
11483         OP * const kid = cUNOPo->op_first;
11484         if (kid->op_type == OP_ENTERSUB) {
11485             (void) ref(kid, o->op_type);
11486             if (kid->op_type != OP_RV2CV
11487                         && !(PL_parser && PL_parser->error_count))
11488                 Perl_croak(aTHX_
11489                           "exists argument is not a subroutine name");
11490             o->op_private |= OPpEXISTS_SUB;
11491         }
11492         else if (kid->op_type == OP_AELEM)
11493             o->op_flags |= OPf_SPECIAL;
11494         else if (kid->op_type != OP_HELEM)
11495             Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
11496                              "element or a subroutine");
11497         op_null(kid);
11498     }
11499     return o;
11500 }
11501
11502 OP *
11503 Perl_ck_rvconst(pTHX_ OP *o)
11504 {
11505     dVAR;
11506     SVOP * const kid = (SVOP*)cUNOPo->op_first;
11507
11508     PERL_ARGS_ASSERT_CK_RVCONST;
11509
11510     if (o->op_type == OP_RV2HV)
11511         /* rv2hv steals the bottom bit for its own uses */
11512         o->op_private &= ~OPpARG1_MASK;
11513
11514     o->op_private |= (PL_hints & HINT_STRICT_REFS);
11515
11516     if (kid->op_type == OP_CONST) {
11517         int iscv;
11518         GV *gv;
11519         SV * const kidsv = kid->op_sv;
11520
11521         /* Is it a constant from cv_const_sv()? */
11522         if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
11523             return o;
11524         }
11525         if (SvTYPE(kidsv) == SVt_PVAV) return o;
11526         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
11527             const char *badthing;
11528             switch (o->op_type) {
11529             case OP_RV2SV:
11530                 badthing = "a SCALAR";
11531                 break;
11532             case OP_RV2AV:
11533                 badthing = "an ARRAY";
11534                 break;
11535             case OP_RV2HV:
11536                 badthing = "a HASH";
11537                 break;
11538             default:
11539                 badthing = NULL;
11540                 break;
11541             }
11542             if (badthing)
11543                 Perl_croak(aTHX_
11544                            "Can't use bareword (\"%" SVf "\") as %s ref while \"strict refs\" in use",
11545                            SVfARG(kidsv), badthing);
11546         }
11547         /*
11548          * This is a little tricky.  We only want to add the symbol if we
11549          * didn't add it in the lexer.  Otherwise we get duplicate strict
11550          * warnings.  But if we didn't add it in the lexer, we must at
11551          * least pretend like we wanted to add it even if it existed before,
11552          * or we get possible typo warnings.  OPpCONST_ENTERED says
11553          * whether the lexer already added THIS instance of this symbol.
11554          */
11555         iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
11556         gv = gv_fetchsv(kidsv,
11557                 o->op_type == OP_RV2CV
11558                         && o->op_private & OPpMAY_RETURN_CONSTANT
11559                     ? GV_NOEXPAND
11560                     : iscv | !(kid->op_private & OPpCONST_ENTERED),
11561                 iscv
11562                     ? SVt_PVCV
11563                     : o->op_type == OP_RV2SV
11564                         ? SVt_PV
11565                         : o->op_type == OP_RV2AV
11566                             ? SVt_PVAV
11567                             : o->op_type == OP_RV2HV
11568                                 ? SVt_PVHV
11569                                 : SVt_PVGV);
11570         if (gv) {
11571             if (!isGV(gv)) {
11572                 assert(iscv);
11573                 assert(SvROK(gv));
11574                 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
11575                   && SvTYPE(SvRV(gv)) != SVt_PVCV)
11576                     gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
11577             }
11578             OpTYPE_set(kid, OP_GV);
11579             SvREFCNT_dec(kid->op_sv);
11580 #ifdef USE_ITHREADS
11581             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
11582             STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
11583             kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
11584             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
11585             PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
11586 #else
11587             kid->op_sv = SvREFCNT_inc_simple_NN(gv);
11588 #endif
11589             kid->op_private = 0;
11590             /* FAKE globs in the symbol table cause weird bugs (#77810) */
11591             SvFAKE_off(gv);
11592         }
11593     }
11594     return o;
11595 }
11596
11597 OP *
11598 Perl_ck_ftst(pTHX_ OP *o)
11599 {
11600     dVAR;
11601     const I32 type = o->op_type;
11602
11603     PERL_ARGS_ASSERT_CK_FTST;
11604
11605     if (o->op_flags & OPf_REF) {
11606         NOOP;
11607     }
11608     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
11609         SVOP * const kid = (SVOP*)cUNOPo->op_first;
11610         const OPCODE kidtype = kid->op_type;
11611
11612         if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
11613          && !kid->op_folded) {
11614             OP * const newop = newGVOP(type, OPf_REF,
11615                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
11616             op_free(o);
11617             return newop;
11618         }
11619
11620         if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
11621             SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
11622             if (name) {
11623                 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
11624                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
11625                             array_passed_to_stat, name);
11626             }
11627             else {
11628                 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
11629                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
11630             }
11631        }
11632         scalar((OP *) kid);
11633         if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
11634             o->op_private |= OPpFT_ACCESS;
11635         if (type != OP_STAT && type != OP_LSTAT
11636             && PL_check[kidtype] == Perl_ck_ftst
11637             && kidtype != OP_STAT && kidtype != OP_LSTAT
11638         ) {
11639             o->op_private |= OPpFT_STACKED;
11640             kid->op_private |= OPpFT_STACKING;
11641             if (kidtype == OP_FTTTY && (
11642                    !(kid->op_private & OPpFT_STACKED)
11643                 || kid->op_private & OPpFT_AFTER_t
11644                ))
11645                 o->op_private |= OPpFT_AFTER_t;
11646         }
11647     }
11648     else {
11649         op_free(o);
11650         if (type == OP_FTTTY)
11651             o = newGVOP(type, OPf_REF, PL_stdingv);
11652         else
11653             o = newUNOP(type, 0, newDEFSVOP());
11654     }
11655     return o;
11656 }
11657
11658 OP *
11659 Perl_ck_fun(pTHX_ OP *o)
11660 {
11661     const int type = o->op_type;
11662     I32 oa = PL_opargs[type] >> OASHIFT;
11663
11664     PERL_ARGS_ASSERT_CK_FUN;
11665
11666     if (o->op_flags & OPf_STACKED) {
11667         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
11668             oa &= ~OA_OPTIONAL;
11669         else
11670             return no_fh_allowed(o);
11671     }
11672
11673     if (o->op_flags & OPf_KIDS) {
11674         OP *prev_kid = NULL;
11675         OP *kid = cLISTOPo->op_first;
11676         I32 numargs = 0;
11677         bool seen_optional = FALSE;
11678
11679         if (kid->op_type == OP_PUSHMARK ||
11680             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
11681         {
11682             prev_kid = kid;
11683             kid = OpSIBLING(kid);
11684         }
11685         if (kid && kid->op_type == OP_COREARGS) {
11686             bool optional = FALSE;
11687             while (oa) {
11688                 numargs++;
11689                 if (oa & OA_OPTIONAL) optional = TRUE;
11690                 oa = oa >> 4;
11691             }
11692             if (optional) o->op_private |= numargs;
11693             return o;
11694         }
11695
11696         while (oa) {
11697             if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
11698                 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
11699                     kid = newDEFSVOP();
11700                     /* append kid to chain */
11701                     op_sibling_splice(o, prev_kid, 0, kid);
11702                 }
11703                 seen_optional = TRUE;
11704             }
11705             if (!kid) break;
11706
11707             numargs++;
11708             switch (oa & 7) {
11709             case OA_SCALAR:
11710                 /* list seen where single (scalar) arg expected? */
11711                 if (numargs == 1 && !(oa >> 4)
11712                     && kid->op_type == OP_LIST && type != OP_SCALAR)
11713                 {
11714                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
11715                 }
11716                 if (type != OP_DELETE) scalar(kid);
11717                 break;
11718             case OA_LIST:
11719                 if (oa < 16) {
11720                     kid = 0;
11721                     continue;
11722                 }
11723                 else
11724                     list(kid);
11725                 break;
11726             case OA_AVREF:
11727                 if ((type == OP_PUSH || type == OP_UNSHIFT)
11728                     && !OpHAS_SIBLING(kid))
11729                     Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11730                                    "Useless use of %s with no values",
11731                                    PL_op_desc[type]);
11732
11733                 if (kid->op_type == OP_CONST
11734                       && (  !SvROK(cSVOPx_sv(kid))
11735                          || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV  )
11736                         )
11737                     bad_type_pv(numargs, "array", o, kid);
11738                 else if (kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV
11739                          || kid->op_type == OP_RV2GV) {
11740                     bad_type_pv(1, "array", o, kid);
11741                 }
11742                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
11743                     yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
11744                                          PL_op_desc[type]), 0);
11745                 }
11746                 else {
11747                     op_lvalue(kid, type);
11748                 }
11749                 break;
11750             case OA_HVREF:
11751                 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
11752                     bad_type_pv(numargs, "hash", o, kid);
11753                 op_lvalue(kid, type);
11754                 break;
11755             case OA_CVREF:
11756                 {
11757                     /* replace kid with newop in chain */
11758                     OP * const newop =
11759                         S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
11760                     newop->op_next = newop;
11761                     kid = newop;
11762                 }
11763                 break;
11764             case OA_FILEREF:
11765                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
11766                     if (kid->op_type == OP_CONST &&
11767                         (kid->op_private & OPpCONST_BARE))
11768                     {
11769                         OP * const newop = newGVOP(OP_GV, 0,
11770                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
11771                         /* replace kid with newop in chain */
11772                         op_sibling_splice(o, prev_kid, 1, newop);
11773                         op_free(kid);
11774                         kid = newop;
11775                     }
11776                     else if (kid->op_type == OP_READLINE) {
11777                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
11778                         bad_type_pv(numargs, "HANDLE", o, kid);
11779                     }
11780                     else {
11781                         I32 flags = OPf_SPECIAL;
11782                         I32 priv = 0;
11783                         PADOFFSET targ = 0;
11784
11785                         /* is this op a FH constructor? */
11786                         if (is_handle_constructor(o,numargs)) {
11787                             const char *name = NULL;
11788                             STRLEN len = 0;
11789                             U32 name_utf8 = 0;
11790                             bool want_dollar = TRUE;
11791
11792                             flags = 0;
11793                             /* Set a flag to tell rv2gv to vivify
11794                              * need to "prove" flag does not mean something
11795                              * else already - NI-S 1999/05/07
11796                              */
11797                             priv = OPpDEREF;
11798                             if (kid->op_type == OP_PADSV) {
11799                                 PADNAME * const pn
11800                                     = PAD_COMPNAME_SV(kid->op_targ);
11801                                 name = PadnamePV (pn);
11802                                 len  = PadnameLEN(pn);
11803                                 name_utf8 = PadnameUTF8(pn);
11804                             }
11805                             else if (kid->op_type == OP_RV2SV
11806                                      && kUNOP->op_first->op_type == OP_GV)
11807                             {
11808                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
11809                                 name = GvNAME(gv);
11810                                 len = GvNAMELEN(gv);
11811                                 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
11812                             }
11813                             else if (kid->op_type == OP_AELEM
11814                                      || kid->op_type == OP_HELEM)
11815                             {
11816                                  OP *firstop;
11817                                  OP *op = ((BINOP*)kid)->op_first;
11818                                  name = NULL;
11819                                  if (op) {
11820                                       SV *tmpstr = NULL;
11821                                       const char * const a =
11822                                            kid->op_type == OP_AELEM ?
11823                                            "[]" : "{}";
11824                                       if (((op->op_type == OP_RV2AV) ||
11825                                            (op->op_type == OP_RV2HV)) &&
11826                                           (firstop = ((UNOP*)op)->op_first) &&
11827                                           (firstop->op_type == OP_GV)) {
11828                                            /* packagevar $a[] or $h{} */
11829                                            GV * const gv = cGVOPx_gv(firstop);
11830                                            if (gv)
11831                                                 tmpstr =
11832                                                      Perl_newSVpvf(aTHX_
11833                                                                    "%s%c...%c",
11834                                                                    GvNAME(gv),
11835                                                                    a[0], a[1]);
11836                                       }
11837                                       else if (op->op_type == OP_PADAV
11838                                                || op->op_type == OP_PADHV) {
11839                                            /* lexicalvar $a[] or $h{} */
11840                                            const char * const padname =
11841                                                 PAD_COMPNAME_PV(op->op_targ);
11842                                            if (padname)
11843                                                 tmpstr =
11844                                                      Perl_newSVpvf(aTHX_
11845                                                                    "%s%c...%c",
11846                                                                    padname + 1,
11847                                                                    a[0], a[1]);
11848                                       }
11849                                       if (tmpstr) {
11850                                            name = SvPV_const(tmpstr, len);
11851                                            name_utf8 = SvUTF8(tmpstr);
11852                                            sv_2mortal(tmpstr);
11853                                       }
11854                                  }
11855                                  if (!name) {
11856                                       name = "__ANONIO__";
11857                                       len = 10;
11858                                       want_dollar = FALSE;
11859                                  }
11860                                  op_lvalue(kid, type);
11861                             }
11862                             if (name) {
11863                                 SV *namesv;
11864                                 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
11865                                 namesv = PAD_SVl(targ);
11866                                 if (want_dollar && *name != '$')
11867                                     sv_setpvs(namesv, "$");
11868                                 else
11869                                     SvPVCLEAR(namesv);
11870                                 sv_catpvn(namesv, name, len);
11871                                 if ( name_utf8 ) SvUTF8_on(namesv);
11872                             }
11873                         }
11874                         scalar(kid);
11875                         kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
11876                                     OP_RV2GV, flags);
11877                         kid->op_targ = targ;
11878                         kid->op_private |= priv;
11879                     }
11880                 }
11881                 scalar(kid);
11882                 break;
11883             case OA_SCALARREF:
11884                 if ((type == OP_UNDEF || type == OP_POS)
11885                     && numargs == 1 && !(oa >> 4)
11886                     && kid->op_type == OP_LIST)
11887                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
11888                 op_lvalue(scalar(kid), type);
11889                 break;
11890             }
11891             oa >>= 4;
11892             prev_kid = kid;
11893             kid = OpSIBLING(kid);
11894         }
11895         /* FIXME - should the numargs or-ing move after the too many
11896          * arguments check? */
11897         o->op_private |= numargs;
11898         if (kid)
11899             return too_many_arguments_pv(o,OP_DESC(o), 0);
11900         listkids(o);
11901     }
11902     else if (PL_opargs[type] & OA_DEFGV) {
11903         /* Ordering of these two is important to keep f_map.t passing.  */
11904         op_free(o);
11905         return newUNOP(type, 0, newDEFSVOP());
11906     }
11907
11908     if (oa) {
11909         while (oa & OA_OPTIONAL)
11910             oa >>= 4;
11911         if (oa && oa != OA_LIST)
11912             return too_few_arguments_pv(o,OP_DESC(o), 0);
11913     }
11914     return o;
11915 }
11916
11917 OP *
11918 Perl_ck_glob(pTHX_ OP *o)
11919 {
11920     GV *gv;
11921
11922     PERL_ARGS_ASSERT_CK_GLOB;
11923
11924     o = ck_fun(o);
11925     if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
11926         op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
11927
11928     if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
11929     {
11930         /* convert
11931          *     glob
11932          *       \ null - const(wildcard)
11933          * into
11934          *     null
11935          *       \ enter
11936          *            \ list
11937          *                 \ mark - glob - rv2cv
11938          *                             |        \ gv(CORE::GLOBAL::glob)
11939          *                             |
11940          *                              \ null - const(wildcard)
11941          */
11942         o->op_flags |= OPf_SPECIAL;
11943         o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
11944         o = S_new_entersubop(aTHX_ gv, o);
11945         o = newUNOP(OP_NULL, 0, o);
11946         o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
11947         return o;
11948     }
11949     else o->op_flags &= ~OPf_SPECIAL;
11950 #if !defined(PERL_EXTERNAL_GLOB)
11951     if (!PL_globhook) {
11952         ENTER;
11953         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
11954                                newSVpvs("File::Glob"), NULL, NULL, NULL);
11955         LEAVE;
11956     }
11957 #endif /* !PERL_EXTERNAL_GLOB */
11958     gv = (GV *)newSV(0);
11959     gv_init(gv, 0, "", 0, 0);
11960     gv_IOadd(gv);
11961     op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
11962     SvREFCNT_dec_NN(gv); /* newGVOP increased it */
11963     scalarkids(o);
11964     return o;
11965 }
11966
11967 OP *
11968 Perl_ck_grep(pTHX_ OP *o)
11969 {
11970     LOGOP *gwop;
11971     OP *kid;
11972     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
11973
11974     PERL_ARGS_ASSERT_CK_GREP;
11975
11976     /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
11977
11978     if (o->op_flags & OPf_STACKED) {
11979         kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
11980         if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
11981             return no_fh_allowed(o);
11982         o->op_flags &= ~OPf_STACKED;
11983     }
11984     kid = OpSIBLING(cLISTOPo->op_first);
11985     if (type == OP_MAPWHILE)
11986         list(kid);
11987     else
11988         scalar(kid);
11989     o = ck_fun(o);
11990     if (PL_parser && PL_parser->error_count)
11991         return o;
11992     kid = OpSIBLING(cLISTOPo->op_first);
11993     if (kid->op_type != OP_NULL)
11994         Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
11995     kid = kUNOP->op_first;
11996
11997     gwop = alloc_LOGOP(type, o, LINKLIST(kid));
11998     kid->op_next = (OP*)gwop;
11999     o->op_private = gwop->op_private = 0;
12000     gwop->op_targ = pad_alloc(type, SVs_PADTMP);
12001
12002     kid = OpSIBLING(cLISTOPo->op_first);
12003     for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
12004         op_lvalue(kid, OP_GREPSTART);
12005
12006     return (OP*)gwop;
12007 }
12008
12009 OP *
12010 Perl_ck_index(pTHX_ OP *o)
12011 {
12012     PERL_ARGS_ASSERT_CK_INDEX;
12013
12014     if (o->op_flags & OPf_KIDS) {
12015         OP *kid = OpSIBLING(cLISTOPo->op_first);        /* get past pushmark */
12016         if (kid)
12017             kid = OpSIBLING(kid);                       /* get past "big" */
12018         if (kid && kid->op_type == OP_CONST) {
12019             const bool save_taint = TAINT_get;
12020             SV *sv = kSVOP->op_sv;
12021             if (   (!SvPOK(sv) || SvNIOKp(sv) || isREGEXP(sv))
12022                 && SvOK(sv) && !SvROK(sv))
12023             {
12024                 sv = newSV(0);
12025                 sv_copypv(sv, kSVOP->op_sv);
12026                 SvREFCNT_dec_NN(kSVOP->op_sv);
12027                 kSVOP->op_sv = sv;
12028             }
12029             if (SvOK(sv)) fbm_compile(sv, 0);
12030             TAINT_set(save_taint);
12031 #ifdef NO_TAINT_SUPPORT
12032             PERL_UNUSED_VAR(save_taint);
12033 #endif
12034         }
12035     }
12036     return ck_fun(o);
12037 }
12038
12039 OP *
12040 Perl_ck_lfun(pTHX_ OP *o)
12041 {
12042     const OPCODE type = o->op_type;
12043
12044     PERL_ARGS_ASSERT_CK_LFUN;
12045
12046     return modkids(ck_fun(o), type);
12047 }
12048
12049 OP *
12050 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
12051 {
12052     PERL_ARGS_ASSERT_CK_DEFINED;
12053
12054     if ((o->op_flags & OPf_KIDS)) {
12055         switch (cUNOPo->op_first->op_type) {
12056         case OP_RV2AV:
12057         case OP_PADAV:
12058             Perl_croak(aTHX_ "Can't use 'defined(@array)'"
12059                              " (Maybe you should just omit the defined()?)");
12060             NOT_REACHED; /* NOTREACHED */
12061             break;
12062         case OP_RV2HV:
12063         case OP_PADHV:
12064             Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
12065                              " (Maybe you should just omit the defined()?)");
12066             NOT_REACHED; /* NOTREACHED */
12067             break;
12068         default:
12069             /* no warning */
12070             break;
12071         }
12072     }
12073     return ck_rfun(o);
12074 }
12075
12076 OP *
12077 Perl_ck_readline(pTHX_ OP *o)
12078 {
12079     PERL_ARGS_ASSERT_CK_READLINE;
12080
12081     if (o->op_flags & OPf_KIDS) {
12082          OP *kid = cLISTOPo->op_first;
12083          if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
12084     }
12085     else {
12086         OP * const newop
12087             = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
12088         op_free(o);
12089         return newop;
12090     }
12091     return o;
12092 }
12093
12094 OP *
12095 Perl_ck_rfun(pTHX_ OP *o)
12096 {
12097     const OPCODE type = o->op_type;
12098
12099     PERL_ARGS_ASSERT_CK_RFUN;
12100
12101     return refkids(ck_fun(o), type);
12102 }
12103
12104 OP *
12105 Perl_ck_listiob(pTHX_ OP *o)
12106 {
12107     OP *kid;
12108
12109     PERL_ARGS_ASSERT_CK_LISTIOB;
12110
12111     kid = cLISTOPo->op_first;
12112     if (!kid) {
12113         o = force_list(o, 1);
12114         kid = cLISTOPo->op_first;
12115     }
12116     if (kid->op_type == OP_PUSHMARK)
12117         kid = OpSIBLING(kid);
12118     if (kid && o->op_flags & OPf_STACKED)
12119         kid = OpSIBLING(kid);
12120     else if (kid && !OpHAS_SIBLING(kid)) {              /* print HANDLE; */
12121         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
12122          && !kid->op_folded) {
12123             o->op_flags |= OPf_STACKED; /* make it a filehandle */
12124             scalar(kid);
12125             /* replace old const op with new OP_RV2GV parent */
12126             kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
12127                                         OP_RV2GV, OPf_REF);
12128             kid = OpSIBLING(kid);
12129         }
12130     }
12131
12132     if (!kid)
12133         op_append_elem(o->op_type, o, newDEFSVOP());
12134
12135     if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
12136     return listkids(o);
12137 }
12138
12139 OP *
12140 Perl_ck_smartmatch(pTHX_ OP *o)
12141 {
12142     dVAR;
12143     PERL_ARGS_ASSERT_CK_SMARTMATCH;
12144     if (0 == (o->op_flags & OPf_SPECIAL)) {
12145         OP *first  = cBINOPo->op_first;
12146         OP *second = OpSIBLING(first);
12147
12148         /* Implicitly take a reference to an array or hash */
12149
12150         /* remove the original two siblings, then add back the
12151          * (possibly different) first and second sibs.
12152          */
12153         op_sibling_splice(o, NULL, 1, NULL);
12154         op_sibling_splice(o, NULL, 1, NULL);
12155         first  = ref_array_or_hash(first);
12156         second = ref_array_or_hash(second);
12157         op_sibling_splice(o, NULL, 0, second);
12158         op_sibling_splice(o, NULL, 0, first);
12159
12160         /* Implicitly take a reference to a regular expression */
12161         if (first->op_type == OP_MATCH && !(first->op_flags & OPf_STACKED)) {
12162             OpTYPE_set(first, OP_QR);
12163         }
12164         if (second->op_type == OP_MATCH && !(second->op_flags & OPf_STACKED)) {
12165             OpTYPE_set(second, OP_QR);
12166         }
12167     }
12168
12169     return o;
12170 }
12171
12172
12173 static OP *
12174 S_maybe_targlex(pTHX_ OP *o)
12175 {
12176     OP * const kid = cLISTOPo->op_first;
12177     /* has a disposable target? */
12178     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
12179         && !(kid->op_flags & OPf_STACKED)
12180         /* Cannot steal the second time! */
12181         && !(kid->op_private & OPpTARGET_MY)
12182         )
12183     {
12184         OP * const kkid = OpSIBLING(kid);
12185
12186         /* Can just relocate the target. */
12187         if (kkid && kkid->op_type == OP_PADSV
12188             && (!(kkid->op_private & OPpLVAL_INTRO)
12189                || kkid->op_private & OPpPAD_STATE))
12190         {
12191             kid->op_targ = kkid->op_targ;
12192             kkid->op_targ = 0;
12193             /* Now we do not need PADSV and SASSIGN.
12194              * Detach kid and free the rest. */
12195             op_sibling_splice(o, NULL, 1, NULL);
12196             op_free(o);
12197             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
12198             return kid;
12199         }
12200     }
12201     return o;
12202 }
12203
12204 OP *
12205 Perl_ck_sassign(pTHX_ OP *o)
12206 {
12207     dVAR;
12208     OP * const kid = cBINOPo->op_first;
12209
12210     PERL_ARGS_ASSERT_CK_SASSIGN;
12211
12212     if (OpHAS_SIBLING(kid)) {
12213         OP *kkid = OpSIBLING(kid);
12214         /* For state variable assignment with attributes, kkid is a list op
12215            whose op_last is a padsv. */
12216         if ((kkid->op_type == OP_PADSV ||
12217              (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
12218               (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
12219              )
12220             )
12221                 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
12222                     == (OPpLVAL_INTRO|OPpPAD_STATE)) {
12223             return S_newONCEOP(aTHX_ o, kkid);
12224         }
12225     }
12226     return S_maybe_targlex(aTHX_ o);
12227 }
12228
12229
12230 OP *
12231 Perl_ck_match(pTHX_ OP *o)
12232 {
12233     PERL_UNUSED_CONTEXT;
12234     PERL_ARGS_ASSERT_CK_MATCH;
12235
12236     return o;
12237 }
12238
12239 OP *
12240 Perl_ck_method(pTHX_ OP *o)
12241 {
12242     SV *sv, *methsv, *rclass;
12243     const char* method;
12244     char* compatptr;
12245     int utf8;
12246     STRLEN len, nsplit = 0, i;
12247     OP* new_op;
12248     OP * const kid = cUNOPo->op_first;
12249
12250     PERL_ARGS_ASSERT_CK_METHOD;
12251     if (kid->op_type != OP_CONST) return o;
12252
12253     sv = kSVOP->op_sv;
12254
12255     /* replace ' with :: */
12256     while ((compatptr = (char *) memchr(SvPVX(sv), '\'',
12257                                         SvEND(sv) - SvPVX(sv) )))
12258     {
12259         *compatptr = ':';
12260         sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
12261     }
12262
12263     method = SvPVX_const(sv);
12264     len = SvCUR(sv);
12265     utf8 = SvUTF8(sv) ? -1 : 1;
12266
12267     for (i = len - 1; i > 0; --i) if (method[i] == ':') {
12268         nsplit = i+1;
12269         break;
12270     }
12271
12272     methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
12273
12274     if (!nsplit) { /* $proto->method() */
12275         op_free(o);
12276         return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
12277     }
12278
12279     if (memEQs(method, nsplit, "SUPER::")) { /* $proto->SUPER::method() */
12280         op_free(o);
12281         return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
12282     }
12283
12284     /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
12285     if (nsplit >= 9 && strBEGINs(method+nsplit-9, "::SUPER::")) {
12286         rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
12287         new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
12288     } else {
12289         rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
12290         new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
12291     }
12292 #ifdef USE_ITHREADS
12293     op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
12294 #else
12295     cMETHOPx(new_op)->op_rclass_sv = rclass;
12296 #endif
12297     op_free(o);
12298     return new_op;
12299 }
12300
12301 OP *
12302 Perl_ck_null(pTHX_ OP *o)
12303 {
12304     PERL_ARGS_ASSERT_CK_NULL;
12305     PERL_UNUSED_CONTEXT;
12306     return o;
12307 }
12308
12309 OP *
12310 Perl_ck_open(pTHX_ OP *o)
12311 {
12312     PERL_ARGS_ASSERT_CK_OPEN;
12313
12314     S_io_hints(aTHX_ o);
12315     {
12316          /* In case of three-arg dup open remove strictness
12317           * from the last arg if it is a bareword. */
12318          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
12319          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
12320          OP *oa;
12321          const char *mode;
12322
12323          if ((last->op_type == OP_CONST) &&             /* The bareword. */
12324              (last->op_private & OPpCONST_BARE) &&
12325              (last->op_private & OPpCONST_STRICT) &&
12326              (oa = OpSIBLING(first)) &&         /* The fh. */
12327              (oa = OpSIBLING(oa)) &&                    /* The mode. */
12328              (oa->op_type == OP_CONST) &&
12329              SvPOK(((SVOP*)oa)->op_sv) &&
12330              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
12331              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
12332              (last == OpSIBLING(oa)))                   /* The bareword. */
12333               last->op_private &= ~OPpCONST_STRICT;
12334     }
12335     return ck_fun(o);
12336 }
12337
12338 OP *
12339 Perl_ck_prototype(pTHX_ OP *o)
12340 {
12341     PERL_ARGS_ASSERT_CK_PROTOTYPE;
12342     if (!(o->op_flags & OPf_KIDS)) {
12343         op_free(o);
12344         return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
12345     }
12346     return o;
12347 }
12348
12349 OP *
12350 Perl_ck_refassign(pTHX_ OP *o)
12351 {
12352     OP * const right = cLISTOPo->op_first;
12353     OP * const left = OpSIBLING(right);
12354     OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
12355     bool stacked = 0;
12356
12357     PERL_ARGS_ASSERT_CK_REFASSIGN;
12358     assert (left);
12359     assert (left->op_type == OP_SREFGEN);
12360
12361     o->op_private = 0;
12362     /* we use OPpPAD_STATE in refassign to mean either of those things,
12363      * and the code assumes the two flags occupy the same bit position
12364      * in the various ops below */
12365     assert(OPpPAD_STATE == OPpOUR_INTRO);
12366
12367     switch (varop->op_type) {
12368     case OP_PADAV:
12369         o->op_private |= OPpLVREF_AV;
12370         goto settarg;
12371     case OP_PADHV:
12372         o->op_private |= OPpLVREF_HV;
12373         /* FALLTHROUGH */
12374     case OP_PADSV:
12375       settarg:
12376         o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
12377         o->op_targ = varop->op_targ;
12378         varop->op_targ = 0;
12379         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
12380         break;
12381
12382     case OP_RV2AV:
12383         o->op_private |= OPpLVREF_AV;
12384         goto checkgv;
12385         NOT_REACHED; /* NOTREACHED */
12386     case OP_RV2HV:
12387         o->op_private |= OPpLVREF_HV;
12388         /* FALLTHROUGH */
12389     case OP_RV2SV:
12390       checkgv:
12391         o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
12392         if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
12393       detach_and_stack:
12394         /* Point varop to its GV kid, detached.  */
12395         varop = op_sibling_splice(varop, NULL, -1, NULL);
12396         stacked = TRUE;
12397         break;
12398     case OP_RV2CV: {
12399         OP * const kidparent =
12400             OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
12401         OP * const kid = cUNOPx(kidparent)->op_first;
12402         o->op_private |= OPpLVREF_CV;
12403         if (kid->op_type == OP_GV) {
12404             varop = kidparent;
12405             goto detach_and_stack;
12406         }
12407         if (kid->op_type != OP_PADCV)   goto bad;
12408         o->op_targ = kid->op_targ;
12409         kid->op_targ = 0;
12410         break;
12411     }
12412     case OP_AELEM:
12413     case OP_HELEM:
12414         o->op_private |= (varop->op_private & OPpLVAL_INTRO);
12415         o->op_private |= OPpLVREF_ELEM;
12416         op_null(varop);
12417         stacked = TRUE;
12418         /* Detach varop.  */
12419         op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
12420         break;
12421     default:
12422       bad:
12423         /* diag_listed_as: Can't modify reference to %s in %s assignment */
12424         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
12425                                 "assignment",
12426                                  OP_DESC(varop)));
12427         return o;
12428     }
12429     if (!FEATURE_REFALIASING_IS_ENABLED)
12430         Perl_croak(aTHX_
12431                   "Experimental aliasing via reference not enabled");
12432     Perl_ck_warner_d(aTHX_
12433                      packWARN(WARN_EXPERIMENTAL__REFALIASING),
12434                     "Aliasing via reference is experimental");
12435     if (stacked) {
12436         o->op_flags |= OPf_STACKED;
12437         op_sibling_splice(o, right, 1, varop);
12438     }
12439     else {
12440         o->op_flags &=~ OPf_STACKED;
12441         op_sibling_splice(o, right, 1, NULL);
12442     }
12443     op_free(left);
12444     return o;
12445 }
12446
12447 OP *
12448 Perl_ck_repeat(pTHX_ OP *o)
12449 {
12450     PERL_ARGS_ASSERT_CK_REPEAT;
12451
12452     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
12453         OP* kids;
12454         o->op_private |= OPpREPEAT_DOLIST;
12455         kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
12456         kids = force_list(kids, 1); /* promote it to a list */
12457         op_sibling_splice(o, NULL, 0, kids); /* and add back */
12458     }
12459     else
12460         scalar(o);
12461     return o;
12462 }
12463
12464 OP *
12465 Perl_ck_require(pTHX_ OP *o)
12466 {
12467     GV* gv;
12468
12469     PERL_ARGS_ASSERT_CK_REQUIRE;
12470
12471     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
12472         SVOP * const kid = (SVOP*)cUNOPo->op_first;
12473         U32 hash;
12474         char *s;
12475         STRLEN len;
12476         if (kid->op_type == OP_CONST) {
12477           SV * const sv = kid->op_sv;
12478           U32 const was_readonly = SvREADONLY(sv);
12479           if (kid->op_private & OPpCONST_BARE) {
12480             dVAR;
12481             const char *end;
12482             HEK *hek;
12483
12484             if (was_readonly) {
12485                     SvREADONLY_off(sv);
12486             }
12487             if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
12488
12489             s = SvPVX(sv);
12490             len = SvCUR(sv);
12491             end = s + len;
12492             /* treat ::foo::bar as foo::bar */
12493             if (len >= 2 && s[0] == ':' && s[1] == ':')
12494                 DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
12495             if (s == end)
12496                 DIE(aTHX_ "Bareword in require maps to empty filename");
12497
12498             for (; s < end; s++) {
12499                 if (*s == ':' && s[1] == ':') {
12500                     *s = '/';
12501                     Move(s+2, s+1, end - s - 1, char);
12502                     --end;
12503                 }
12504             }
12505             SvEND_set(sv, end);
12506             sv_catpvs(sv, ".pm");
12507             PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
12508             hek = share_hek(SvPVX(sv),
12509                             (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
12510                             hash);
12511             sv_sethek(sv, hek);
12512             unshare_hek(hek);
12513             SvFLAGS(sv) |= was_readonly;
12514           }
12515           else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
12516                 && !SvVOK(sv)) {
12517             s = SvPV(sv, len);
12518             if (SvREFCNT(sv) > 1) {
12519                 kid->op_sv = newSVpvn_share(
12520                     s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
12521                 SvREFCNT_dec_NN(sv);
12522             }
12523             else {
12524                 dVAR;
12525                 HEK *hek;
12526                 if (was_readonly) SvREADONLY_off(sv);
12527                 PERL_HASH(hash, s, len);
12528                 hek = share_hek(s,
12529                                 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
12530                                 hash);
12531                 sv_sethek(sv, hek);
12532                 unshare_hek(hek);
12533                 SvFLAGS(sv) |= was_readonly;
12534             }
12535           }
12536         }
12537     }
12538
12539     if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
12540         /* handle override, if any */
12541      && (gv = gv_override("require", 7))) {
12542         OP *kid, *newop;
12543         if (o->op_flags & OPf_KIDS) {
12544             kid = cUNOPo->op_first;
12545             op_sibling_splice(o, NULL, -1, NULL);
12546         }
12547         else {
12548             kid = newDEFSVOP();
12549         }
12550         op_free(o);
12551         newop = S_new_entersubop(aTHX_ gv, kid);
12552         return newop;
12553     }
12554
12555     return ck_fun(o);
12556 }
12557
12558 OP *
12559 Perl_ck_return(pTHX_ OP *o)
12560 {
12561     OP *kid;
12562
12563     PERL_ARGS_ASSERT_CK_RETURN;
12564
12565     kid = OpSIBLING(cLISTOPo->op_first);
12566     if (PL_compcv && CvLVALUE(PL_compcv)) {
12567         for (; kid; kid = OpSIBLING(kid))
12568             op_lvalue(kid, OP_LEAVESUBLV);
12569     }
12570
12571     return o;
12572 }
12573
12574 OP *
12575 Perl_ck_select(pTHX_ OP *o)
12576 {
12577     dVAR;
12578     OP* kid;
12579
12580     PERL_ARGS_ASSERT_CK_SELECT;
12581
12582     if (o->op_flags & OPf_KIDS) {
12583         kid = OpSIBLING(cLISTOPo->op_first);     /* get past pushmark */
12584         if (kid && OpHAS_SIBLING(kid)) {
12585             OpTYPE_set(o, OP_SSELECT);
12586             o = ck_fun(o);
12587             return fold_constants(op_integerize(op_std_init(o)));
12588         }
12589     }
12590     o = ck_fun(o);
12591     kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
12592     if (kid && kid->op_type == OP_RV2GV)
12593         kid->op_private &= ~HINT_STRICT_REFS;
12594     return o;
12595 }
12596
12597 OP *
12598 Perl_ck_shift(pTHX_ OP *o)
12599 {
12600     const I32 type = o->op_type;
12601
12602     PERL_ARGS_ASSERT_CK_SHIFT;
12603
12604     if (!(o->op_flags & OPf_KIDS)) {
12605         OP *argop;
12606
12607         if (!CvUNIQUE(PL_compcv)) {
12608             o->op_flags |= OPf_SPECIAL;
12609             return o;
12610         }
12611
12612         argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
12613         op_free(o);
12614         return newUNOP(type, 0, scalar(argop));
12615     }
12616     return scalar(ck_fun(o));
12617 }
12618
12619 OP *
12620 Perl_ck_sort(pTHX_ OP *o)
12621 {
12622     OP *firstkid;
12623     OP *kid;
12624     HV * const hinthv =
12625         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
12626     U8 stacked;
12627
12628     PERL_ARGS_ASSERT_CK_SORT;
12629
12630     if (hinthv) {
12631             SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
12632             if (svp) {
12633                 const I32 sorthints = (I32)SvIV(*svp);
12634                 if ((sorthints & HINT_SORT_STABLE) != 0)
12635                     o->op_private |= OPpSORT_STABLE;
12636                 if ((sorthints & HINT_SORT_UNSTABLE) != 0)
12637                     o->op_private |= OPpSORT_UNSTABLE;
12638             }
12639     }
12640
12641     if (o->op_flags & OPf_STACKED)
12642         simplify_sort(o);
12643     firstkid = OpSIBLING(cLISTOPo->op_first);           /* get past pushmark */
12644
12645     if ((stacked = o->op_flags & OPf_STACKED)) {        /* may have been cleared */
12646         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
12647
12648         /* if the first arg is a code block, process it and mark sort as
12649          * OPf_SPECIAL */
12650         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
12651             LINKLIST(kid);
12652             if (kid->op_type == OP_LEAVE)
12653                     op_null(kid);                       /* wipe out leave */
12654             /* Prevent execution from escaping out of the sort block. */
12655             kid->op_next = 0;
12656
12657             /* provide scalar context for comparison function/block */
12658             kid = scalar(firstkid);
12659             kid->op_next = kid;
12660             o->op_flags |= OPf_SPECIAL;
12661         }
12662         else if (kid->op_type == OP_CONST
12663               && kid->op_private & OPpCONST_BARE) {
12664             char tmpbuf[256];
12665             STRLEN len;
12666             PADOFFSET off;
12667             const char * const name = SvPV(kSVOP_sv, len);
12668             *tmpbuf = '&';
12669             assert (len < 256);
12670             Copy(name, tmpbuf+1, len, char);
12671             off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv));
12672             if (off != NOT_IN_PAD) {
12673                 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
12674                     SV * const fq =
12675                         newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
12676                     sv_catpvs(fq, "::");
12677                     sv_catsv(fq, kSVOP_sv);
12678                     SvREFCNT_dec_NN(kSVOP_sv);
12679                     kSVOP->op_sv = fq;
12680                 }
12681                 else {
12682                     OP * const padop = newOP(OP_PADCV, 0);
12683                     padop->op_targ = off;
12684                     /* replace the const op with the pad op */
12685                     op_sibling_splice(firstkid, NULL, 1, padop);
12686                     op_free(kid);
12687                 }
12688             }
12689         }
12690
12691         firstkid = OpSIBLING(firstkid);
12692     }
12693
12694     for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
12695         /* provide list context for arguments */
12696         list(kid);
12697         if (stacked)
12698             op_lvalue(kid, OP_GREPSTART);
12699     }
12700
12701     return o;
12702 }
12703
12704 /* for sort { X } ..., where X is one of
12705  *   $a <=> $b, $b <=> $a, $a cmp $b, $b cmp $a
12706  * elide the second child of the sort (the one containing X),
12707  * and set these flags as appropriate
12708         OPpSORT_NUMERIC;
12709         OPpSORT_INTEGER;
12710         OPpSORT_DESCEND;
12711  * Also, check and warn on lexical $a, $b.
12712  */
12713
12714 STATIC void
12715 S_simplify_sort(pTHX_ OP *o)
12716 {
12717     OP *kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
12718     OP *k;
12719     int descending;
12720     GV *gv;
12721     const char *gvname;
12722     bool have_scopeop;
12723
12724     PERL_ARGS_ASSERT_SIMPLIFY_SORT;
12725
12726     kid = kUNOP->op_first;                              /* get past null */
12727     if (!(have_scopeop = kid->op_type == OP_SCOPE)
12728      && kid->op_type != OP_LEAVE)
12729         return;
12730     kid = kLISTOP->op_last;                             /* get past scope */
12731     switch(kid->op_type) {
12732         case OP_NCMP:
12733         case OP_I_NCMP:
12734         case OP_SCMP:
12735             if (!have_scopeop) goto padkids;
12736             break;
12737         default:
12738             return;
12739     }
12740     k = kid;                                            /* remember this node*/
12741     if (kBINOP->op_first->op_type != OP_RV2SV
12742      || kBINOP->op_last ->op_type != OP_RV2SV)
12743     {
12744         /*
12745            Warn about my($a) or my($b) in a sort block, *if* $a or $b is
12746            then used in a comparison.  This catches most, but not
12747            all cases.  For instance, it catches
12748                sort { my($a); $a <=> $b }
12749            but not
12750                sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
12751            (although why you'd do that is anyone's guess).
12752         */
12753
12754        padkids:
12755         if (!ckWARN(WARN_SYNTAX)) return;
12756         kid = kBINOP->op_first;
12757         do {
12758             if (kid->op_type == OP_PADSV) {
12759                 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
12760                 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
12761                  && (  PadnamePV(name)[1] == 'a'
12762                     || PadnamePV(name)[1] == 'b'  ))
12763                     /* diag_listed_as: "my %s" used in sort comparison */
12764                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12765                                      "\"%s %s\" used in sort comparison",
12766                                       PadnameIsSTATE(name)
12767                                         ? "state"
12768                                         : "my",
12769                                       PadnamePV(name));
12770             }
12771         } while ((kid = OpSIBLING(kid)));
12772         return;
12773     }
12774     kid = kBINOP->op_first;                             /* get past cmp */
12775     if (kUNOP->op_first->op_type != OP_GV)
12776         return;
12777     kid = kUNOP->op_first;                              /* get past rv2sv */
12778     gv = kGVOP_gv;
12779     if (GvSTASH(gv) != PL_curstash)
12780         return;
12781     gvname = GvNAME(gv);
12782     if (*gvname == 'a' && gvname[1] == '\0')
12783         descending = 0;
12784     else if (*gvname == 'b' && gvname[1] == '\0')
12785         descending = 1;
12786     else
12787         return;
12788
12789     kid = k;                                            /* back to cmp */
12790     /* already checked above that it is rv2sv */
12791     kid = kBINOP->op_last;                              /* down to 2nd arg */
12792     if (kUNOP->op_first->op_type != OP_GV)
12793         return;
12794     kid = kUNOP->op_first;                              /* get past rv2sv */
12795     gv = kGVOP_gv;
12796     if (GvSTASH(gv) != PL_curstash)
12797         return;
12798     gvname = GvNAME(gv);
12799     if ( descending
12800          ? !(*gvname == 'a' && gvname[1] == '\0')
12801          : !(*gvname == 'b' && gvname[1] == '\0'))
12802         return;
12803     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
12804     if (descending)
12805         o->op_private |= OPpSORT_DESCEND;
12806     if (k->op_type == OP_NCMP)
12807         o->op_private |= OPpSORT_NUMERIC;
12808     if (k->op_type == OP_I_NCMP)
12809         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
12810     kid = OpSIBLING(cLISTOPo->op_first);
12811     /* cut out and delete old block (second sibling) */
12812     op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
12813     op_free(kid);
12814 }
12815
12816 OP *
12817 Perl_ck_split(pTHX_ OP *o)
12818 {
12819     dVAR;
12820     OP *kid;
12821     OP *sibs;
12822
12823     PERL_ARGS_ASSERT_CK_SPLIT;
12824
12825     assert(o->op_type == OP_LIST);
12826
12827     if (o->op_flags & OPf_STACKED)
12828         return no_fh_allowed(o);
12829
12830     kid = cLISTOPo->op_first;
12831     /* delete leading NULL node, then add a CONST if no other nodes */
12832     assert(kid->op_type == OP_NULL);
12833     op_sibling_splice(o, NULL, 1,
12834         OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
12835     op_free(kid);
12836     kid = cLISTOPo->op_first;
12837
12838     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
12839         /* remove match expression, and replace with new optree with
12840          * a match op at its head */
12841         op_sibling_splice(o, NULL, 1, NULL);
12842         /* pmruntime will handle split " " behavior with flag==2 */
12843         kid = pmruntime(newPMOP(OP_MATCH, 0), kid, NULL, 2, 0);
12844         op_sibling_splice(o, NULL, 0, kid);
12845     }
12846
12847     assert(kid->op_type == OP_MATCH || kid->op_type == OP_SPLIT);
12848
12849     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
12850       Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
12851                      "Use of /g modifier is meaningless in split");
12852     }
12853
12854     /* eliminate the split op, and move the match op (plus any children)
12855      * into its place, then convert the match op into a split op. i.e.
12856      *
12857      *  SPLIT                    MATCH                 SPLIT(ex-MATCH)
12858      *    |                        |                     |
12859      *  MATCH - A - B - C   =>     R - A - B - C   =>    R - A - B - C
12860      *    |                        |                     |
12861      *    R                        X - Y                 X - Y
12862      *    |
12863      *    X - Y
12864      *
12865      * (R, if it exists, will be a regcomp op)
12866      */
12867
12868     op_sibling_splice(o, NULL, 1, NULL); /* detach match op from o */
12869     sibs = op_sibling_splice(o, NULL, -1, NULL); /* detach any other sibs */
12870     op_sibling_splice(kid, cLISTOPx(kid)->op_last, 0, sibs); /* and reattach */
12871     OpTYPE_set(kid, OP_SPLIT);
12872     kid->op_flags   = (o->op_flags | (kid->op_flags & OPf_KIDS));
12873     kid->op_private = o->op_private;
12874     op_free(o);
12875     o = kid;
12876     kid = sibs; /* kid is now the string arg of the split */
12877
12878     if (!kid) {
12879         kid = newDEFSVOP();
12880         op_append_elem(OP_SPLIT, o, kid);
12881     }
12882     scalar(kid);
12883
12884     kid = OpSIBLING(kid);
12885     if (!kid) {
12886         kid = newSVOP(OP_CONST, 0, newSViv(0));
12887         op_append_elem(OP_SPLIT, o, kid);
12888         o->op_private |= OPpSPLIT_IMPLIM;
12889     }
12890     scalar(kid);
12891
12892     if (OpHAS_SIBLING(kid))
12893         return too_many_arguments_pv(o,OP_DESC(o), 0);
12894
12895     return o;
12896 }
12897
12898 OP *
12899 Perl_ck_stringify(pTHX_ OP *o)
12900 {
12901     OP * const kid = OpSIBLING(cUNOPo->op_first);
12902     PERL_ARGS_ASSERT_CK_STRINGIFY;
12903     if ((   kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
12904          || kid->op_type == OP_LC   || kid->op_type == OP_LCFIRST
12905          || kid->op_type == OP_UC   || kid->op_type == OP_UCFIRST)
12906         && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
12907     {
12908         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
12909         op_free(o);
12910         return kid;
12911     }
12912     return ck_fun(o);
12913 }
12914
12915 OP *
12916 Perl_ck_join(pTHX_ OP *o)
12917 {
12918     OP * const kid = OpSIBLING(cLISTOPo->op_first);
12919
12920     PERL_ARGS_ASSERT_CK_JOIN;
12921
12922     if (kid && kid->op_type == OP_MATCH) {
12923         if (ckWARN(WARN_SYNTAX)) {
12924             const REGEXP *re = PM_GETRE(kPMOP);
12925             const SV *msg = re
12926                     ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
12927                                             SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
12928                     : newSVpvs_flags( "STRING", SVs_TEMP );
12929             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12930                         "/%" SVf "/ should probably be written as \"%" SVf "\"",
12931                         SVfARG(msg), SVfARG(msg));
12932         }
12933     }
12934     if (kid
12935      && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
12936         || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
12937         || (  kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
12938            && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
12939     {
12940         const OP * const bairn = OpSIBLING(kid); /* the list */
12941         if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
12942          && OP_GIMME(bairn,0) == G_SCALAR)
12943         {
12944             OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
12945                                      op_sibling_splice(o, kid, 1, NULL));
12946             op_free(o);
12947             return ret;
12948         }
12949     }
12950
12951     return ck_fun(o);
12952 }
12953
12954 /*
12955 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
12956
12957 Examines an op, which is expected to identify a subroutine at runtime,
12958 and attempts to determine at compile time which subroutine it identifies.
12959 This is normally used during Perl compilation to determine whether
12960 a prototype can be applied to a function call.  C<cvop> is the op
12961 being considered, normally an C<rv2cv> op.  A pointer to the identified
12962 subroutine is returned, if it could be determined statically, and a null
12963 pointer is returned if it was not possible to determine statically.
12964
12965 Currently, the subroutine can be identified statically if the RV that the
12966 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
12967 A C<gv> op is suitable if the GV's CV slot is populated.  A C<const> op is
12968 suitable if the constant value must be an RV pointing to a CV.  Details of
12969 this process may change in future versions of Perl.  If the C<rv2cv> op
12970 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
12971 the subroutine statically: this flag is used to suppress compile-time
12972 magic on a subroutine call, forcing it to use default runtime behaviour.
12973
12974 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
12975 of a GV reference is modified.  If a GV was examined and its CV slot was
12976 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
12977 If the op is not optimised away, and the CV slot is later populated with
12978 a subroutine having a prototype, that flag eventually triggers the warning
12979 "called too early to check prototype".
12980
12981 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
12982 of returning a pointer to the subroutine it returns a pointer to the
12983 GV giving the most appropriate name for the subroutine in this context.
12984 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
12985 (C<CvANON>) subroutine that is referenced through a GV it will be the
12986 referencing GV.  The resulting C<GV*> is cast to C<CV*> to be returned.
12987 A null pointer is returned as usual if there is no statically-determinable
12988 subroutine.
12989
12990 =cut
12991 */
12992
12993 /* shared by toke.c:yylex */
12994 CV *
12995 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
12996 {
12997     PADNAME *name = PAD_COMPNAME(off);
12998     CV *compcv = PL_compcv;
12999     while (PadnameOUTER(name)) {
13000         assert(PARENT_PAD_INDEX(name));
13001         compcv = CvOUTSIDE(compcv);
13002         name = PadlistNAMESARRAY(CvPADLIST(compcv))
13003                 [off = PARENT_PAD_INDEX(name)];
13004     }
13005     assert(!PadnameIsOUR(name));
13006     if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
13007         return PadnamePROTOCV(name);
13008     }
13009     return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
13010 }
13011
13012 CV *
13013 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
13014 {
13015     OP *rvop;
13016     CV *cv;
13017     GV *gv;
13018     PERL_ARGS_ASSERT_RV2CV_OP_CV;
13019     if (flags & ~RV2CVOPCV_FLAG_MASK)
13020         Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
13021     if (cvop->op_type != OP_RV2CV)
13022         return NULL;
13023     if (cvop->op_private & OPpENTERSUB_AMPER)
13024         return NULL;
13025     if (!(cvop->op_flags & OPf_KIDS))
13026         return NULL;
13027     rvop = cUNOPx(cvop)->op_first;
13028     switch (rvop->op_type) {
13029         case OP_GV: {
13030             gv = cGVOPx_gv(rvop);
13031             if (!isGV(gv)) {
13032                 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
13033                     cv = MUTABLE_CV(SvRV(gv));
13034                     gv = NULL;
13035                     break;
13036                 }
13037                 if (flags & RV2CVOPCV_RETURN_STUB)
13038                     return (CV *)gv;
13039                 else return NULL;
13040             }
13041             cv = GvCVu(gv);
13042             if (!cv) {
13043                 if (flags & RV2CVOPCV_MARK_EARLY)
13044                     rvop->op_private |= OPpEARLY_CV;
13045                 return NULL;
13046             }
13047         } break;
13048         case OP_CONST: {
13049             SV *rv = cSVOPx_sv(rvop);
13050             if (!SvROK(rv))
13051                 return NULL;
13052             cv = (CV*)SvRV(rv);
13053             gv = NULL;
13054         } break;
13055         case OP_PADCV: {
13056             cv = find_lexical_cv(rvop->op_targ);
13057             gv = NULL;
13058         } break;
13059         default: {
13060             return NULL;
13061         } NOT_REACHED; /* NOTREACHED */
13062     }
13063     if (SvTYPE((SV*)cv) != SVt_PVCV)
13064         return NULL;
13065     if (flags & RV2CVOPCV_RETURN_NAME_GV) {
13066         if ((!CvANON(cv) && !CvLEXICAL(cv)) || !gv)
13067             gv = CvGV(cv);
13068         return (CV*)gv;
13069     }
13070     else if (flags & RV2CVOPCV_MAYBE_NAME_GV) {
13071         if (CvLEXICAL(cv) || CvNAMED(cv))
13072             return NULL;
13073         if (!CvANON(cv) || !gv)
13074             gv = CvGV(cv);
13075         return (CV*)gv;
13076
13077     } else {
13078         return cv;
13079     }
13080 }
13081
13082 /*
13083 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
13084
13085 Performs the default fixup of the arguments part of an C<entersub>
13086 op tree.  This consists of applying list context to each of the
13087 argument ops.  This is the standard treatment used on a call marked
13088 with C<&>, or a method call, or a call through a subroutine reference,
13089 or any other call where the callee can't be identified at compile time,
13090 or a call where the callee has no prototype.
13091
13092 =cut
13093 */
13094
13095 OP *
13096 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
13097 {
13098     OP *aop;
13099
13100     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
13101
13102     aop = cUNOPx(entersubop)->op_first;
13103     if (!OpHAS_SIBLING(aop))
13104         aop = cUNOPx(aop)->op_first;
13105     for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
13106         /* skip the extra attributes->import() call implicitly added in
13107          * something like foo(my $x : bar)
13108          */
13109         if (   aop->op_type == OP_ENTERSUB
13110             && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
13111         )
13112             continue;
13113         list(aop);
13114         op_lvalue(aop, OP_ENTERSUB);
13115     }
13116     return entersubop;
13117 }
13118
13119 /*
13120 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
13121
13122 Performs the fixup of the arguments part of an C<entersub> op tree
13123 based on a subroutine prototype.  This makes various modifications to
13124 the argument ops, from applying context up to inserting C<refgen> ops,
13125 and checking the number and syntactic types of arguments, as directed by
13126 the prototype.  This is the standard treatment used on a subroutine call,
13127 not marked with C<&>, where the callee can be identified at compile time
13128 and has a prototype.
13129
13130 C<protosv> supplies the subroutine prototype to be applied to the call.
13131 It may be a normal defined scalar, of which the string value will be used.
13132 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
13133 that has been cast to C<SV*>) which has a prototype.  The prototype
13134 supplied, in whichever form, does not need to match the actual callee
13135 referenced by the op tree.
13136
13137 If the argument ops disagree with the prototype, for example by having
13138 an unacceptable number of arguments, a valid op tree is returned anyway.
13139 The error is reflected in the parser state, normally resulting in a single
13140 exception at the top level of parsing which covers all the compilation
13141 errors that occurred.  In the error message, the callee is referred to
13142 by the name defined by the C<namegv> parameter.
13143
13144 =cut
13145 */
13146
13147 OP *
13148 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
13149 {
13150     STRLEN proto_len;
13151     const char *proto, *proto_end;
13152     OP *aop, *prev, *cvop, *parent;
13153     int optional = 0;
13154     I32 arg = 0;
13155     I32 contextclass = 0;
13156     const char *e = NULL;
13157     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
13158     if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
13159         Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
13160                    "flags=%lx", (unsigned long) SvFLAGS(protosv));
13161     if (SvTYPE(protosv) == SVt_PVCV)
13162          proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
13163     else proto = SvPV(protosv, proto_len);
13164     proto = S_strip_spaces(aTHX_ proto, &proto_len);
13165     proto_end = proto + proto_len;
13166     parent = entersubop;
13167     aop = cUNOPx(entersubop)->op_first;
13168     if (!OpHAS_SIBLING(aop)) {
13169         parent = aop;
13170         aop = cUNOPx(aop)->op_first;
13171     }
13172     prev = aop;
13173     aop = OpSIBLING(aop);
13174     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13175     while (aop != cvop) {
13176         OP* o3 = aop;
13177
13178         if (proto >= proto_end)
13179         {
13180             SV * const namesv = cv_name((CV *)namegv, NULL, 0);
13181             yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13182                                         SVfARG(namesv)), SvUTF8(namesv));
13183             return entersubop;
13184         }
13185
13186         switch (*proto) {
13187             case ';':
13188                 optional = 1;
13189                 proto++;
13190                 continue;
13191             case '_':
13192                 /* _ must be at the end */
13193                 if (proto[1] && !strchr(";@%", proto[1]))
13194                     goto oops;
13195                 /* FALLTHROUGH */
13196             case '$':
13197                 proto++;
13198                 arg++;
13199                 scalar(aop);
13200                 break;
13201             case '%':
13202             case '@':
13203                 list(aop);
13204                 arg++;
13205                 break;
13206             case '&':
13207                 proto++;
13208                 arg++;
13209                 if (    o3->op_type != OP_UNDEF
13210                     && (o3->op_type != OP_SREFGEN
13211                         || (  cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
13212                                 != OP_ANONCODE
13213                             && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
13214                                 != OP_RV2CV)))
13215                     bad_type_gv(arg, namegv, o3,
13216                             arg == 1 ? "block or sub {}" : "sub {}");
13217                 break;
13218             case '*':
13219                 /* '*' allows any scalar type, including bareword */
13220                 proto++;
13221                 arg++;
13222                 if (o3->op_type == OP_RV2GV)
13223                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
13224                 else if (o3->op_type == OP_CONST)
13225                     o3->op_private &= ~OPpCONST_STRICT;
13226                 scalar(aop);
13227                 break;
13228             case '+':
13229                 proto++;
13230                 arg++;
13231                 if (o3->op_type == OP_RV2AV ||
13232                     o3->op_type == OP_PADAV ||
13233                     o3->op_type == OP_RV2HV ||
13234                     o3->op_type == OP_PADHV
13235                 ) {
13236                     goto wrapref;
13237                 }
13238                 scalar(aop);
13239                 break;
13240             case '[': case ']':
13241                 goto oops;
13242
13243             case '\\':
13244                 proto++;
13245                 arg++;
13246             again:
13247                 switch (*proto++) {
13248                     case '[':
13249                         if (contextclass++ == 0) {
13250                             e = (char *) memchr(proto, ']', proto_end - proto);
13251                             if (!e || e == proto)
13252                                 goto oops;
13253                         }
13254                         else
13255                             goto oops;
13256                         goto again;
13257
13258                     case ']':
13259                         if (contextclass) {
13260                             const char *p = proto;
13261                             const char *const end = proto;
13262                             contextclass = 0;
13263                             while (*--p != '[')
13264                                 /* \[$] accepts any scalar lvalue */
13265                                 if (*p == '$'
13266                                  && Perl_op_lvalue_flags(aTHX_
13267                                      scalar(o3),
13268                                      OP_READ, /* not entersub */
13269                                      OP_LVALUE_NO_CROAK
13270                                     )) goto wrapref;
13271                             bad_type_gv(arg, namegv, o3,
13272                                     Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
13273                         } else
13274                             goto oops;
13275                         break;
13276                     case '*':
13277                         if (o3->op_type == OP_RV2GV)
13278                             goto wrapref;
13279                         if (!contextclass)
13280                             bad_type_gv(arg, namegv, o3, "symbol");
13281                         break;
13282                     case '&':
13283                         if (o3->op_type == OP_ENTERSUB
13284                          && !(o3->op_flags & OPf_STACKED))
13285                             goto wrapref;
13286                         if (!contextclass)
13287                             bad_type_gv(arg, namegv, o3, "subroutine");
13288                         break;
13289                     case '$':
13290                         if (o3->op_type == OP_RV2SV ||
13291                                 o3->op_type == OP_PADSV ||
13292                                 o3->op_type == OP_HELEM ||
13293                                 o3->op_type == OP_AELEM)
13294                             goto wrapref;
13295                         if (!contextclass) {
13296                             /* \$ accepts any scalar lvalue */
13297                             if (Perl_op_lvalue_flags(aTHX_
13298                                     scalar(o3),
13299                                     OP_READ,  /* not entersub */
13300                                     OP_LVALUE_NO_CROAK
13301                                )) goto wrapref;
13302                             bad_type_gv(arg, namegv, o3, "scalar");
13303                         }
13304                         break;
13305                     case '@':
13306                         if (o3->op_type == OP_RV2AV ||
13307                                 o3->op_type == OP_PADAV)
13308                         {
13309                             o3->op_flags &=~ OPf_PARENS;
13310                             goto wrapref;
13311                         }
13312                         if (!contextclass)
13313                             bad_type_gv(arg, namegv, o3, "array");
13314                         break;
13315                     case '%':
13316                         if (o3->op_type == OP_RV2HV ||
13317                                 o3->op_type == OP_PADHV)
13318                         {
13319                             o3->op_flags &=~ OPf_PARENS;
13320                             goto wrapref;
13321                         }
13322                         if (!contextclass)
13323                             bad_type_gv(arg, namegv, o3, "hash");
13324                         break;
13325                     wrapref:
13326                             aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
13327                                                 OP_REFGEN, 0);
13328                         if (contextclass && e) {
13329                             proto = e + 1;
13330                             contextclass = 0;
13331                         }
13332                         break;
13333                     default: goto oops;
13334                 }
13335                 if (contextclass)
13336                     goto again;
13337                 break;
13338             case ' ':
13339                 proto++;
13340                 continue;
13341             default:
13342             oops: {
13343                 Perl_croak(aTHX_ "Malformed prototype for %" SVf ": %" SVf,
13344                                   SVfARG(cv_name((CV *)namegv, NULL, 0)),
13345                                   SVfARG(protosv));
13346             }
13347         }
13348
13349         op_lvalue(aop, OP_ENTERSUB);
13350         prev = aop;
13351         aop = OpSIBLING(aop);
13352     }
13353     if (aop == cvop && *proto == '_') {
13354         /* generate an access to $_ */
13355         op_sibling_splice(parent, prev, 0, newDEFSVOP());
13356     }
13357     if (!optional && proto_end > proto &&
13358         (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
13359     {
13360         SV * const namesv = cv_name((CV *)namegv, NULL, 0);
13361         yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %" SVf,
13362                                     SVfARG(namesv)), SvUTF8(namesv));
13363     }
13364     return entersubop;
13365 }
13366
13367 /*
13368 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
13369
13370 Performs the fixup of the arguments part of an C<entersub> op tree either
13371 based on a subroutine prototype or using default list-context processing.
13372 This is the standard treatment used on a subroutine call, not marked
13373 with C<&>, where the callee can be identified at compile time.
13374
13375 C<protosv> supplies the subroutine prototype to be applied to the call,
13376 or indicates that there is no prototype.  It may be a normal scalar,
13377 in which case if it is defined then the string value will be used
13378 as a prototype, and if it is undefined then there is no prototype.
13379 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
13380 that has been cast to C<SV*>), of which the prototype will be used if it
13381 has one.  The prototype (or lack thereof) supplied, in whichever form,
13382 does not need to match the actual callee referenced by the op tree.
13383
13384 If the argument ops disagree with the prototype, for example by having
13385 an unacceptable number of arguments, a valid op tree is returned anyway.
13386 The error is reflected in the parser state, normally resulting in a single
13387 exception at the top level of parsing which covers all the compilation
13388 errors that occurred.  In the error message, the callee is referred to
13389 by the name defined by the C<namegv> parameter.
13390
13391 =cut
13392 */
13393
13394 OP *
13395 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
13396         GV *namegv, SV *protosv)
13397 {
13398     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
13399     if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
13400         return ck_entersub_args_proto(entersubop, namegv, protosv);
13401     else
13402         return ck_entersub_args_list(entersubop);
13403 }
13404
13405 OP *
13406 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
13407 {
13408     IV cvflags = SvIVX(protosv);
13409     int opnum = cvflags & 0xffff;
13410     OP *aop = cUNOPx(entersubop)->op_first;
13411
13412     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
13413
13414     if (!opnum) {
13415         OP *cvop;
13416         if (!OpHAS_SIBLING(aop))
13417             aop = cUNOPx(aop)->op_first;
13418         aop = OpSIBLING(aop);
13419         for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13420         if (aop != cvop) {
13421             SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
13422             yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13423                 SVfARG(namesv)), SvUTF8(namesv));
13424         }
13425
13426         op_free(entersubop);
13427         switch(cvflags >> 16) {
13428         case 'F': return newSVOP(OP_CONST, 0,
13429                                         newSVpv(CopFILE(PL_curcop),0));
13430         case 'L': return newSVOP(
13431                            OP_CONST, 0,
13432                            Perl_newSVpvf(aTHX_
13433                              "%" IVdf, (IV)CopLINE(PL_curcop)
13434                            )
13435                          );
13436         case 'P': return newSVOP(OP_CONST, 0,
13437                                    (PL_curstash
13438                                      ? newSVhek(HvNAME_HEK(PL_curstash))
13439                                      : &PL_sv_undef
13440                                    )
13441                                 );
13442         }
13443         NOT_REACHED; /* NOTREACHED */
13444     }
13445     else {
13446         OP *prev, *cvop, *first, *parent;
13447         U32 flags = 0;
13448
13449         parent = entersubop;
13450         if (!OpHAS_SIBLING(aop)) {
13451             parent = aop;
13452             aop = cUNOPx(aop)->op_first;
13453         }
13454
13455         first = prev = aop;
13456         aop = OpSIBLING(aop);
13457         /* find last sibling */
13458         for (cvop = aop;
13459              OpHAS_SIBLING(cvop);
13460              prev = cvop, cvop = OpSIBLING(cvop))
13461             ;
13462         if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
13463             /* Usually, OPf_SPECIAL on an op with no args means that it had
13464              * parens, but these have their own meaning for that flag: */
13465             && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
13466             && opnum != OP_DELETE && opnum != OP_EXISTS)
13467                 flags |= OPf_SPECIAL;
13468         /* excise cvop from end of sibling chain */
13469         op_sibling_splice(parent, prev, 1, NULL);
13470         op_free(cvop);
13471         if (aop == cvop) aop = NULL;
13472
13473         /* detach remaining siblings from the first sibling, then
13474          * dispose of original optree */
13475
13476         if (aop)
13477             op_sibling_splice(parent, first, -1, NULL);
13478         op_free(entersubop);
13479
13480         if (cvflags == (OP_ENTEREVAL | (1<<16)))
13481             flags |= OPpEVAL_BYTES <<8;
13482
13483         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
13484         case OA_UNOP:
13485         case OA_BASEOP_OR_UNOP:
13486         case OA_FILESTATOP:
13487             return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
13488         case OA_BASEOP:
13489             if (aop) {
13490                 SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
13491                 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13492                     SVfARG(namesv)), SvUTF8(namesv));
13493                 op_free(aop);
13494             }
13495             return opnum == OP_RUNCV
13496                 ? newPVOP(OP_RUNCV,0,NULL)
13497                 : newOP(opnum,0);
13498         default:
13499             return op_convert_list(opnum,0,aop);
13500         }
13501     }
13502     NOT_REACHED; /* NOTREACHED */
13503     return entersubop;
13504 }
13505
13506 /*
13507 =for apidoc Am|void|cv_get_call_checker_flags|CV *cv|U32 gflags|Perl_call_checker *ckfun_p|SV **ckobj_p|U32 *ckflags_p
13508
13509 Retrieves the function that will be used to fix up a call to C<cv>.
13510 Specifically, the function is applied to an C<entersub> op tree for a
13511 subroutine call, not marked with C<&>, where the callee can be identified
13512 at compile time as C<cv>.
13513
13514 The C-level function pointer is returned in C<*ckfun_p>, an SV argument
13515 for it is returned in C<*ckobj_p>, and control flags are returned in
13516 C<*ckflags_p>.  The function is intended to be called in this manner:
13517
13518  entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
13519
13520 In this call, C<entersubop> is a pointer to the C<entersub> op,
13521 which may be replaced by the check function, and C<namegv> supplies
13522 the name that should be used by the check function to refer
13523 to the callee of the C<entersub> op if it needs to emit any diagnostics.
13524 It is permitted to apply the check function in non-standard situations,
13525 such as to a call to a different subroutine or to a method call.
13526
13527 C<namegv> may not actually be a GV.  If the C<CALL_CHECKER_REQUIRE_GV>
13528 bit is clear in C<*ckflags_p>, it is permitted to pass a CV or other SV
13529 instead, anything that can be used as the first argument to L</cv_name>.
13530 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<*ckflags_p> then the
13531 check function requires C<namegv> to be a genuine GV.
13532
13533 By default, the check function is
13534 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
13535 the SV parameter is C<cv> itself, and the C<CALL_CHECKER_REQUIRE_GV>
13536 flag is clear.  This implements standard prototype processing.  It can
13537 be changed, for a particular subroutine, by L</cv_set_call_checker_flags>.
13538
13539 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<gflags> then it
13540 indicates that the caller only knows about the genuine GV version of
13541 C<namegv>, and accordingly the corresponding bit will always be set in
13542 C<*ckflags_p>, regardless of the check function's recorded requirements.
13543 If the C<CALL_CHECKER_REQUIRE_GV> bit is clear in C<gflags> then it
13544 indicates the caller knows about the possibility of passing something
13545 other than a GV as C<namegv>, and accordingly the corresponding bit may
13546 be either set or clear in C<*ckflags_p>, indicating the check function's
13547 recorded requirements.
13548
13549 C<gflags> is a bitset passed into C<cv_get_call_checker_flags>, in which
13550 only the C<CALL_CHECKER_REQUIRE_GV> bit currently has a defined meaning
13551 (for which see above).  All other bits should be clear.
13552
13553 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
13554
13555 The original form of L</cv_get_call_checker_flags>, which does not return
13556 checker flags.  When using a checker function returned by this function,
13557 it is only safe to call it with a genuine GV as its C<namegv> argument.
13558
13559 =cut
13560 */
13561
13562 void
13563 Perl_cv_get_call_checker_flags(pTHX_ CV *cv, U32 gflags,
13564         Perl_call_checker *ckfun_p, SV **ckobj_p, U32 *ckflags_p)
13565 {
13566     MAGIC *callmg;
13567     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER_FLAGS;
13568     PERL_UNUSED_CONTEXT;
13569     callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
13570     if (callmg) {
13571         *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
13572         *ckobj_p = callmg->mg_obj;
13573         *ckflags_p = (callmg->mg_flags | gflags) & MGf_REQUIRE_GV;
13574     } else {
13575         *ckfun_p = Perl_ck_entersub_args_proto_or_list;
13576         *ckobj_p = (SV*)cv;
13577         *ckflags_p = gflags & MGf_REQUIRE_GV;
13578     }
13579 }
13580
13581 void
13582 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
13583 {
13584     U32 ckflags;
13585     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
13586     PERL_UNUSED_CONTEXT;
13587     cv_get_call_checker_flags(cv, CALL_CHECKER_REQUIRE_GV, ckfun_p, ckobj_p,
13588         &ckflags);
13589 }
13590
13591 /*
13592 =for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 ckflags
13593
13594 Sets the function that will be used to fix up a call to C<cv>.
13595 Specifically, the function is applied to an C<entersub> op tree for a
13596 subroutine call, not marked with C<&>, where the callee can be identified
13597 at compile time as C<cv>.
13598
13599 The C-level function pointer is supplied in C<ckfun>, an SV argument for
13600 it is supplied in C<ckobj>, and control flags are supplied in C<ckflags>.
13601 The function should be defined like this:
13602
13603     STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
13604
13605 It is intended to be called in this manner:
13606
13607     entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
13608
13609 In this call, C<entersubop> is a pointer to the C<entersub> op,
13610 which may be replaced by the check function, and C<namegv> supplies
13611 the name that should be used by the check function to refer
13612 to the callee of the C<entersub> op if it needs to emit any diagnostics.
13613 It is permitted to apply the check function in non-standard situations,
13614 such as to a call to a different subroutine or to a method call.
13615
13616 C<namegv> may not actually be a GV.  For efficiency, perl may pass a
13617 CV or other SV instead.  Whatever is passed can be used as the first
13618 argument to L</cv_name>.  You can force perl to pass a GV by including
13619 C<CALL_CHECKER_REQUIRE_GV> in the C<ckflags>.
13620
13621 C<ckflags> is a bitset, in which only the C<CALL_CHECKER_REQUIRE_GV>
13622 bit currently has a defined meaning (for which see above).  All other
13623 bits should be clear.
13624
13625 The current setting for a particular CV can be retrieved by
13626 L</cv_get_call_checker_flags>.
13627
13628 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
13629
13630 The original form of L</cv_set_call_checker_flags>, which passes it the
13631 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.  The effect
13632 of that flag setting is that the check function is guaranteed to get a
13633 genuine GV as its C<namegv> argument.
13634
13635 =cut
13636 */
13637
13638 void
13639 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
13640 {
13641     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
13642     cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
13643 }
13644
13645 void
13646 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
13647                                      SV *ckobj, U32 ckflags)
13648 {
13649     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
13650     if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
13651         if (SvMAGICAL((SV*)cv))
13652             mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
13653     } else {
13654         MAGIC *callmg;
13655         sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
13656         callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
13657         assert(callmg);
13658         if (callmg->mg_flags & MGf_REFCOUNTED) {
13659             SvREFCNT_dec(callmg->mg_obj);
13660             callmg->mg_flags &= ~MGf_REFCOUNTED;
13661         }
13662         callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
13663         callmg->mg_obj = ckobj;
13664         if (ckobj != (SV*)cv) {
13665             SvREFCNT_inc_simple_void_NN(ckobj);
13666             callmg->mg_flags |= MGf_REFCOUNTED;
13667         }
13668         callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
13669                          | (U8)(ckflags & MGf_REQUIRE_GV) | MGf_COPY;
13670     }
13671 }
13672
13673 static void
13674 S_entersub_alloc_targ(pTHX_ OP * const o)
13675 {
13676     o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
13677     o->op_private |= OPpENTERSUB_HASTARG;
13678 }
13679
13680 OP *
13681 Perl_ck_subr(pTHX_ OP *o)
13682 {
13683     OP *aop, *cvop;
13684     CV *cv;
13685     GV *namegv;
13686     SV **const_class = NULL;
13687
13688     PERL_ARGS_ASSERT_CK_SUBR;
13689
13690     aop = cUNOPx(o)->op_first;
13691     if (!OpHAS_SIBLING(aop))
13692         aop = cUNOPx(aop)->op_first;
13693     aop = OpSIBLING(aop);
13694     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13695     cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
13696     namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
13697
13698     o->op_private &= ~1;
13699     o->op_private |= (PL_hints & HINT_STRICT_REFS);
13700     if (PERLDB_SUB && PL_curstash != PL_debstash)
13701         o->op_private |= OPpENTERSUB_DB;
13702     switch (cvop->op_type) {
13703         case OP_RV2CV:
13704             o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
13705             op_null(cvop);
13706             break;
13707         case OP_METHOD:
13708         case OP_METHOD_NAMED:
13709         case OP_METHOD_SUPER:
13710         case OP_METHOD_REDIR:
13711         case OP_METHOD_REDIR_SUPER:
13712             o->op_flags |= OPf_REF;
13713             if (aop->op_type == OP_CONST) {
13714                 aop->op_private &= ~OPpCONST_STRICT;
13715                 const_class = &cSVOPx(aop)->op_sv;
13716             }
13717             else if (aop->op_type == OP_LIST) {
13718                 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
13719                 if (sib && sib->op_type == OP_CONST) {
13720                     sib->op_private &= ~OPpCONST_STRICT;
13721                     const_class = &cSVOPx(sib)->op_sv;
13722                 }
13723             }
13724             /* make class name a shared cow string to speedup method calls */
13725             /* constant string might be replaced with object, f.e. bigint */
13726             if (const_class && SvPOK(*const_class)) {
13727                 STRLEN len;
13728                 const char* str = SvPV(*const_class, len);
13729                 if (len) {
13730                     SV* const shared = newSVpvn_share(
13731                         str, SvUTF8(*const_class)
13732                                     ? -(SSize_t)len : (SSize_t)len,
13733                         0
13734                     );
13735                     if (SvREADONLY(*const_class))
13736                         SvREADONLY_on(shared);
13737                     SvREFCNT_dec(*const_class);
13738                     *const_class = shared;
13739                 }
13740             }
13741             break;
13742     }
13743
13744     if (!cv) {
13745         S_entersub_alloc_targ(aTHX_ o);
13746         return ck_entersub_args_list(o);
13747     } else {
13748         Perl_call_checker ckfun;
13749         SV *ckobj;
13750         U32 ckflags;
13751         cv_get_call_checker_flags(cv, 0, &ckfun, &ckobj, &ckflags);
13752         if (CvISXSUB(cv) || !CvROOT(cv))
13753             S_entersub_alloc_targ(aTHX_ o);
13754         if (!namegv) {
13755             /* The original call checker API guarantees that a GV will be
13756                be provided with the right name.  So, if the old API was
13757                used (or the REQUIRE_GV flag was passed), we have to reify
13758                the CV’s GV, unless this is an anonymous sub.  This is not
13759                ideal for lexical subs, as its stringification will include
13760                the package.  But it is the best we can do.  */
13761             if (ckflags & CALL_CHECKER_REQUIRE_GV) {
13762                 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
13763                     namegv = CvGV(cv);
13764             }
13765             else namegv = MUTABLE_GV(cv);
13766             /* After a syntax error in a lexical sub, the cv that
13767                rv2cv_op_cv returns may be a nameless stub. */
13768             if (!namegv) return ck_entersub_args_list(o);
13769
13770         }
13771         return ckfun(aTHX_ o, namegv, ckobj);
13772     }
13773 }
13774
13775 OP *
13776 Perl_ck_svconst(pTHX_ OP *o)
13777 {
13778     SV * const sv = cSVOPo->op_sv;
13779     PERL_ARGS_ASSERT_CK_SVCONST;
13780     PERL_UNUSED_CONTEXT;
13781 #ifdef PERL_COPY_ON_WRITE
13782     /* Since the read-only flag may be used to protect a string buffer, we
13783        cannot do copy-on-write with existing read-only scalars that are not
13784        already copy-on-write scalars.  To allow $_ = "hello" to do COW with
13785        that constant, mark the constant as COWable here, if it is not
13786        already read-only. */
13787     if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
13788         SvIsCOW_on(sv);
13789         CowREFCNT(sv) = 0;
13790 # ifdef PERL_DEBUG_READONLY_COW
13791         sv_buf_to_ro(sv);
13792 # endif
13793     }
13794 #endif
13795     SvREADONLY_on(sv);
13796     return o;
13797 }
13798
13799 OP *
13800 Perl_ck_trunc(pTHX_ OP *o)
13801 {
13802     PERL_ARGS_ASSERT_CK_TRUNC;
13803
13804     if (o->op_flags & OPf_KIDS) {
13805         SVOP *kid = (SVOP*)cUNOPo->op_first;
13806
13807         if (kid->op_type == OP_NULL)
13808             kid = (SVOP*)OpSIBLING(kid);
13809         if (kid && kid->op_type == OP_CONST &&
13810             (kid->op_private & OPpCONST_BARE) &&
13811             !kid->op_folded)
13812         {
13813             o->op_flags |= OPf_SPECIAL;
13814             kid->op_private &= ~OPpCONST_STRICT;
13815         }
13816     }
13817     return ck_fun(o);
13818 }
13819
13820 OP *
13821 Perl_ck_substr(pTHX_ OP *o)
13822 {
13823     PERL_ARGS_ASSERT_CK_SUBSTR;
13824
13825     o = ck_fun(o);
13826     if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
13827         OP *kid = cLISTOPo->op_first;
13828
13829         if (kid->op_type == OP_NULL)
13830             kid = OpSIBLING(kid);
13831         if (kid)
13832             /* Historically, substr(delete $foo{bar},...) has been allowed
13833                with 4-arg substr.  Keep it working by applying entersub
13834                lvalue context.  */
13835             op_lvalue(kid, OP_ENTERSUB);
13836
13837     }
13838     return o;
13839 }
13840
13841 OP *
13842 Perl_ck_tell(pTHX_ OP *o)
13843 {
13844     PERL_ARGS_ASSERT_CK_TELL;
13845     o = ck_fun(o);
13846     if (o->op_flags & OPf_KIDS) {
13847      OP *kid = cLISTOPo->op_first;
13848      if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
13849      if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
13850     }
13851     return o;
13852 }
13853
13854 OP *
13855 Perl_ck_each(pTHX_ OP *o)
13856 {
13857     dVAR;
13858     OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
13859     const unsigned orig_type  = o->op_type;
13860
13861     PERL_ARGS_ASSERT_CK_EACH;
13862
13863     if (kid) {
13864         switch (kid->op_type) {
13865             case OP_PADHV:
13866             case OP_RV2HV:
13867                 break;
13868             case OP_PADAV:
13869             case OP_RV2AV:
13870                 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
13871                             : orig_type == OP_KEYS ? OP_AKEYS
13872                             :                        OP_AVALUES);
13873                 break;
13874             case OP_CONST:
13875                 if (kid->op_private == OPpCONST_BARE
13876                  || !SvROK(cSVOPx_sv(kid))
13877                  || (  SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
13878                     && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV  )
13879                    )
13880                     goto bad;
13881                 /* FALLTHROUGH */
13882             default:
13883                 qerror(Perl_mess(aTHX_
13884                     "Experimental %s on scalar is now forbidden",
13885                      PL_op_desc[orig_type]));
13886                bad:
13887                 bad_type_pv(1, "hash or array", o, kid);
13888                 return o;
13889         }
13890     }
13891     return ck_fun(o);
13892 }
13893
13894 OP *
13895 Perl_ck_length(pTHX_ OP *o)
13896 {
13897     PERL_ARGS_ASSERT_CK_LENGTH;
13898
13899     o = ck_fun(o);
13900
13901     if (ckWARN(WARN_SYNTAX)) {
13902         const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
13903
13904         if (kid) {
13905             SV *name = NULL;
13906             const bool hash = kid->op_type == OP_PADHV
13907                            || kid->op_type == OP_RV2HV;
13908             switch (kid->op_type) {
13909                 case OP_PADHV:
13910                 case OP_PADAV:
13911                 case OP_RV2HV:
13912                 case OP_RV2AV:
13913                     name = S_op_varname(aTHX_ kid);
13914                     break;
13915                 default:
13916                     return o;
13917             }
13918             if (name)
13919                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13920                     "length() used on %" SVf " (did you mean \"scalar(%s%" SVf
13921                     ")\"?)",
13922                     SVfARG(name), hash ? "keys " : "", SVfARG(name)
13923                 );
13924             else if (hash)
13925      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
13926                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13927                     "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
13928             else
13929      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
13930                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13931                     "length() used on @array (did you mean \"scalar(@array)\"?)");
13932         }
13933     }
13934
13935     return o;
13936 }
13937
13938
13939
13940 /*
13941    ---------------------------------------------------------
13942
13943    Common vars in list assignment
13944
13945    There now follows some enums and static functions for detecting
13946    common variables in list assignments. Here is a little essay I wrote
13947    for myself when trying to get my head around this. DAPM.
13948
13949    ----
13950
13951    First some random observations:
13952
13953    * If a lexical var is an alias of something else, e.g.
13954        for my $x ($lex, $pkg, $a[0]) {...}
13955      then the act of aliasing will increase the reference count of the SV
13956
13957    * If a package var is an alias of something else, it may still have a
13958      reference count of 1, depending on how the alias was created, e.g.
13959      in *a = *b, $a may have a refcount of 1 since the GP is shared
13960      with a single GvSV pointer to the SV. So If it's an alias of another
13961      package var, then RC may be 1; if it's an alias of another scalar, e.g.
13962      a lexical var or an array element, then it will have RC > 1.
13963
13964    * There are many ways to create a package alias; ultimately, XS code
13965      may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
13966      run-time tracing mechanisms are unlikely to be able to catch all cases.
13967
13968    * When the LHS is all my declarations, the same vars can't appear directly
13969      on the RHS, but they can indirectly via closures, aliasing and lvalue
13970      subs. But those techniques all involve an increase in the lexical
13971      scalar's ref count.
13972
13973    * When the LHS is all lexical vars (but not necessarily my declarations),
13974      it is possible for the same lexicals to appear directly on the RHS, and
13975      without an increased ref count, since the stack isn't refcounted.
13976      This case can be detected at compile time by scanning for common lex
13977      vars with PL_generation.
13978
13979    * lvalue subs defeat common var detection, but they do at least
13980      return vars with a temporary ref count increment. Also, you can't
13981      tell at compile time whether a sub call is lvalue.
13982
13983
13984    So...
13985
13986    A: There are a few circumstances where there definitely can't be any
13987      commonality:
13988
13989        LHS empty:  () = (...);
13990        RHS empty:  (....) = ();
13991        RHS contains only constants or other 'can't possibly be shared'
13992            elements (e.g. ops that return PADTMPs):  (...) = (1,2, length)
13993            i.e. they only contain ops not marked as dangerous, whose children
13994            are also not dangerous;
13995        LHS ditto;
13996        LHS contains a single scalar element: e.g. ($x) = (....); because
13997            after $x has been modified, it won't be used again on the RHS;
13998        RHS contains a single element with no aggregate on LHS: e.g.
13999            ($a,$b,$c)  = ($x); again, once $a has been modified, its value
14000            won't be used again.
14001
14002    B: If LHS are all 'my' lexical var declarations (or safe ops, which
14003      we can ignore):
14004
14005        my ($a, $b, @c) = ...;
14006
14007        Due to closure and goto tricks, these vars may already have content.
14008        For the same reason, an element on the RHS may be a lexical or package
14009        alias of one of the vars on the left, or share common elements, for
14010        example:
14011
14012            my ($x,$y) = f(); # $x and $y on both sides
14013            sub f : lvalue { ($x,$y) = (1,2); $y, $x }
14014
14015        and
14016
14017            my $ra = f();
14018            my @a = @$ra;  # elements of @a on both sides
14019            sub f { @a = 1..4; \@a }
14020
14021
14022        First, just consider scalar vars on LHS:
14023
14024            RHS is safe only if (A), or in addition,
14025                * contains only lexical *scalar* vars, where neither side's
14026                  lexicals have been flagged as aliases
14027
14028            If RHS is not safe, then it's always legal to check LHS vars for
14029            RC==1, since the only RHS aliases will always be associated
14030            with an RC bump.
14031
14032            Note that in particular, RHS is not safe if:
14033
14034                * it contains package scalar vars; e.g.:
14035
14036                    f();
14037                    my ($x, $y) = (2, $x_alias);
14038                    sub f { $x = 1; *x_alias = \$x; }
14039
14040                * It contains other general elements, such as flattened or
14041                * spliced or single array or hash elements, e.g.
14042
14043                    f();
14044                    my ($x,$y) = @a; # or $a[0] or @a{@b} etc
14045
14046                    sub f {
14047                        ($x, $y) = (1,2);
14048                        use feature 'refaliasing';
14049                        \($a[0], $a[1]) = \($y,$x);
14050                    }
14051
14052                  It doesn't matter if the array/hash is lexical or package.
14053
14054                * it contains a function call that happens to be an lvalue
14055                  sub which returns one or more of the above, e.g.
14056
14057                    f();
14058                    my ($x,$y) = f();
14059
14060                    sub f : lvalue {
14061                        ($x, $y) = (1,2);
14062                        *x1 = \$x;
14063                        $y, $x1;
14064                    }
14065
14066                    (so a sub call on the RHS should be treated the same
14067                    as having a package var on the RHS).
14068
14069                * any other "dangerous" thing, such an op or built-in that
14070                  returns one of the above, e.g. pp_preinc
14071
14072
14073            If RHS is not safe, what we can do however is at compile time flag
14074            that the LHS are all my declarations, and at run time check whether
14075            all the LHS have RC == 1, and if so skip the full scan.
14076
14077        Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
14078
14079            Here the issue is whether there can be elements of @a on the RHS
14080            which will get prematurely freed when @a is cleared prior to
14081            assignment. This is only a problem if the aliasing mechanism
14082            is one which doesn't increase the refcount - only if RC == 1
14083            will the RHS element be prematurely freed.
14084
14085            Because the array/hash is being INTROed, it or its elements
14086            can't directly appear on the RHS:
14087
14088                my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
14089
14090            but can indirectly, e.g.:
14091
14092                my $r = f();
14093                my (@a) = @$r;
14094                sub f { @a = 1..3; \@a }
14095
14096            So if the RHS isn't safe as defined by (A), we must always
14097            mortalise and bump the ref count of any remaining RHS elements
14098            when assigning to a non-empty LHS aggregate.
14099
14100            Lexical scalars on the RHS aren't safe if they've been involved in
14101            aliasing, e.g.
14102
14103                use feature 'refaliasing';
14104
14105                f();
14106                \(my $lex) = \$pkg;
14107                my @a = ($lex,3); # equivalent to ($a[0],3)
14108
14109                sub f {
14110                    @a = (1,2);
14111                    \$pkg = \$a[0];
14112                }
14113
14114            Similarly with lexical arrays and hashes on the RHS:
14115
14116                f();
14117                my @b;
14118                my @a = (@b);
14119
14120                sub f {
14121                    @a = (1,2);
14122                    \$b[0] = \$a[1];
14123                    \$b[1] = \$a[0];
14124                }
14125
14126
14127
14128    C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
14129        my $a; ($a, my $b) = (....);
14130
14131        The difference between (B) and (C) is that it is now physically
14132        possible for the LHS vars to appear on the RHS too, where they
14133        are not reference counted; but in this case, the compile-time
14134        PL_generation sweep will detect such common vars.
14135
14136        So the rules for (C) differ from (B) in that if common vars are
14137        detected, the runtime "test RC==1" optimisation can no longer be used,
14138        and a full mark and sweep is required
14139
14140    D: As (C), but in addition the LHS may contain package vars.
14141
14142        Since package vars can be aliased without a corresponding refcount
14143        increase, all bets are off. It's only safe if (A). E.g.
14144
14145            my ($x, $y) = (1,2);
14146
14147            for $x_alias ($x) {
14148                ($x_alias, $y) = (3, $x); # whoops
14149            }
14150
14151        Ditto for LHS aggregate package vars.
14152
14153    E: Any other dangerous ops on LHS, e.g.
14154            (f(), $a[0], @$r) = (...);
14155
14156        this is similar to (E) in that all bets are off. In addition, it's
14157        impossible to determine at compile time whether the LHS
14158        contains a scalar or an aggregate, e.g.
14159
14160            sub f : lvalue { @a }
14161            (f()) = 1..3;
14162
14163 * ---------------------------------------------------------
14164 */
14165
14166
14167 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates
14168  * that at least one of the things flagged was seen.
14169  */
14170
14171 enum {
14172     AAS_MY_SCALAR       = 0x001, /* my $scalar */
14173     AAS_MY_AGG          = 0x002, /* aggregate: my @array or my %hash */
14174     AAS_LEX_SCALAR      = 0x004, /* $lexical */
14175     AAS_LEX_AGG         = 0x008, /* @lexical or %lexical aggregate */
14176     AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
14177     AAS_PKG_SCALAR      = 0x020, /* $scalar (where $scalar is pkg var) */
14178     AAS_PKG_AGG         = 0x040, /* package @array or %hash aggregate */
14179     AAS_DANGEROUS       = 0x080, /* an op (other than the above)
14180                                          that's flagged OA_DANGEROUS */
14181     AAS_SAFE_SCALAR     = 0x100, /* produces at least one scalar SV that's
14182                                         not in any of the categories above */
14183     AAS_DEFAV           = 0x200  /* contains just a single '@_' on RHS */
14184 };
14185
14186
14187
14188 /* helper function for S_aassign_scan().
14189  * check a PAD-related op for commonality and/or set its generation number.
14190  * Returns a boolean indicating whether its shared */
14191
14192 static bool
14193 S_aassign_padcheck(pTHX_ OP* o, bool rhs)
14194 {
14195     if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
14196         /* lexical used in aliasing */
14197         return TRUE;
14198
14199     if (rhs)
14200         return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
14201     else
14202         PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
14203
14204     return FALSE;
14205 }
14206
14207
14208 /*
14209   Helper function for OPpASSIGN_COMMON* detection in rpeep().
14210   It scans the left or right hand subtree of the aassign op, and returns a
14211   set of flags indicating what sorts of things it found there.
14212   'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
14213   set PL_generation on lexical vars; if the latter, we see if
14214   PL_generation matches.
14215   'top' indicates whether we're recursing or at the top level.
14216   'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
14217   This fn will increment it by the number seen. It's not intended to
14218   be an accurate count (especially as many ops can push a variable
14219   number of SVs onto the stack); rather it's used as to test whether there
14220   can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
14221 */
14222
14223 static int
14224 S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *scalars_p)
14225 {
14226     int flags = 0;
14227     bool kid_top = FALSE;
14228
14229     /* first, look for a solitary @_ on the RHS */
14230     if (   rhs
14231         && top
14232         && (o->op_flags & OPf_KIDS)
14233         && OP_TYPE_IS_OR_WAS(o, OP_LIST)
14234     ) {
14235         OP *kid = cUNOPo->op_first;
14236         if (   (   kid->op_type == OP_PUSHMARK
14237                 || kid->op_type == OP_PADRANGE) /* ex-pushmark */
14238             && ((kid = OpSIBLING(kid)))
14239             && !OpHAS_SIBLING(kid)
14240             && kid->op_type == OP_RV2AV
14241             && !(kid->op_flags & OPf_REF)
14242             && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
14243             && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
14244             && ((kid = cUNOPx(kid)->op_first))
14245             && kid->op_type == OP_GV
14246             && cGVOPx_gv(kid) == PL_defgv
14247         )
14248             flags |= AAS_DEFAV;
14249     }
14250
14251     switch (o->op_type) {
14252     case OP_GVSV:
14253         (*scalars_p)++;
14254         return AAS_PKG_SCALAR;
14255
14256     case OP_PADAV:
14257     case OP_PADHV:
14258         (*scalars_p) += 2;
14259         /* if !top, could be e.g. @a[0,1] */
14260         if (top && (o->op_flags & OPf_REF))
14261             return (o->op_private & OPpLVAL_INTRO)
14262                 ? AAS_MY_AGG : AAS_LEX_AGG;
14263         return AAS_DANGEROUS;
14264
14265     case OP_PADSV:
14266         {
14267             int comm = S_aassign_padcheck(aTHX_ o, rhs)
14268                         ?  AAS_LEX_SCALAR_COMM : 0;
14269             (*scalars_p)++;
14270             return (o->op_private & OPpLVAL_INTRO)
14271                 ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
14272         }
14273
14274     case OP_RV2AV:
14275     case OP_RV2HV:
14276         (*scalars_p) += 2;
14277         if (cUNOPx(o)->op_first->op_type != OP_GV)
14278             return AAS_DANGEROUS; /* @{expr}, %{expr} */
14279         /* @pkg, %pkg */
14280         /* if !top, could be e.g. @a[0,1] */
14281         if (top && (o->op_flags & OPf_REF))
14282             return AAS_PKG_AGG;
14283         return AAS_DANGEROUS;
14284
14285     case OP_RV2SV:
14286         (*scalars_p)++;
14287         if (cUNOPx(o)->op_first->op_type != OP_GV) {
14288             (*scalars_p) += 2;
14289             return AAS_DANGEROUS; /* ${expr} */
14290         }
14291         return AAS_PKG_SCALAR; /* $pkg */
14292
14293     case OP_SPLIT:
14294         if (o->op_private & OPpSPLIT_ASSIGN) {
14295             /* the assign in @a = split() has been optimised away
14296              * and the @a attached directly to the split op
14297              * Treat the array as appearing on the RHS, i.e.
14298              *    ... = (@a = split)
14299              * is treated like
14300              *    ... = @a;
14301              */
14302
14303             if (o->op_flags & OPf_STACKED)
14304                 /* @{expr} = split() - the array expression is tacked
14305                  * on as an extra child to split - process kid */
14306                 return S_aassign_scan(aTHX_ cLISTOPo->op_last, rhs,
14307                                         top, scalars_p);
14308
14309             /* ... else array is directly attached to split op */
14310             (*scalars_p) += 2;
14311             if (PL_op->op_private & OPpSPLIT_LEX)
14312                 return (o->op_private & OPpLVAL_INTRO)
14313                     ? AAS_MY_AGG : AAS_LEX_AGG;
14314             else
14315                 return AAS_PKG_AGG;
14316         }
14317         (*scalars_p)++;
14318         /* other args of split can't be returned */
14319         return AAS_SAFE_SCALAR;
14320
14321     case OP_UNDEF:
14322         /* undef counts as a scalar on the RHS:
14323          *   (undef, $x) = ...;         # only 1 scalar on LHS: always safe
14324          *   ($x, $y)    = (undef, $x); # 2 scalars on RHS: unsafe
14325          */
14326         if (rhs)
14327             (*scalars_p)++;
14328         flags = AAS_SAFE_SCALAR;
14329         break;
14330
14331     case OP_PUSHMARK:
14332     case OP_STUB:
14333         /* these are all no-ops; they don't push a potentially common SV
14334          * onto the stack, so they are neither AAS_DANGEROUS nor
14335          * AAS_SAFE_SCALAR */
14336         return 0;
14337
14338     case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
14339         break;
14340
14341     case OP_NULL:
14342     case OP_LIST:
14343         /* these do nothing but may have children; but their children
14344          * should also be treated as top-level */
14345         kid_top = top;
14346         break;
14347
14348     default:
14349         if (PL_opargs[o->op_type] & OA_DANGEROUS) {
14350             (*scalars_p) += 2;
14351             flags = AAS_DANGEROUS;
14352             break;
14353         }
14354
14355         if (   (PL_opargs[o->op_type] & OA_TARGLEX)
14356             && (o->op_private & OPpTARGET_MY))
14357         {
14358             (*scalars_p)++;
14359             return S_aassign_padcheck(aTHX_ o, rhs)
14360                 ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
14361         }
14362
14363         /* if its an unrecognised, non-dangerous op, assume that it
14364          * it the cause of at least one safe scalar */
14365         (*scalars_p)++;
14366         flags = AAS_SAFE_SCALAR;
14367         break;
14368     }
14369
14370     /* XXX this assumes that all other ops are "transparent" - i.e. that
14371      * they can return some of their children. While this true for e.g.
14372      * sort and grep, it's not true for e.g. map. We really need a
14373      * 'transparent' flag added to regen/opcodes
14374      */
14375     if (o->op_flags & OPf_KIDS) {
14376         OP *kid;
14377         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
14378             flags |= S_aassign_scan(aTHX_ kid, rhs, kid_top, scalars_p);
14379     }
14380     return flags;
14381 }
14382
14383
14384 /* Check for in place reverse and sort assignments like "@a = reverse @a"
14385    and modify the optree to make them work inplace */
14386
14387 STATIC void
14388 S_inplace_aassign(pTHX_ OP *o) {
14389
14390     OP *modop, *modop_pushmark;
14391     OP *oright;
14392     OP *oleft, *oleft_pushmark;
14393
14394     PERL_ARGS_ASSERT_INPLACE_AASSIGN;
14395
14396     assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
14397
14398     assert(cUNOPo->op_first->op_type == OP_NULL);
14399     modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
14400     assert(modop_pushmark->op_type == OP_PUSHMARK);
14401     modop = OpSIBLING(modop_pushmark);
14402
14403     if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
14404         return;
14405
14406     /* no other operation except sort/reverse */
14407     if (OpHAS_SIBLING(modop))
14408         return;
14409
14410     assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
14411     if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
14412
14413     if (modop->op_flags & OPf_STACKED) {
14414         /* skip sort subroutine/block */
14415         assert(oright->op_type == OP_NULL);
14416         oright = OpSIBLING(oright);
14417     }
14418
14419     assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
14420     oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
14421     assert(oleft_pushmark->op_type == OP_PUSHMARK);
14422     oleft = OpSIBLING(oleft_pushmark);
14423
14424     /* Check the lhs is an array */
14425     if (!oleft ||
14426         (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
14427         || OpHAS_SIBLING(oleft)
14428         || (oleft->op_private & OPpLVAL_INTRO)
14429     )
14430         return;
14431
14432     /* Only one thing on the rhs */
14433     if (OpHAS_SIBLING(oright))
14434         return;
14435
14436     /* check the array is the same on both sides */
14437     if (oleft->op_type == OP_RV2AV) {
14438         if (oright->op_type != OP_RV2AV
14439             || !cUNOPx(oright)->op_first
14440             || cUNOPx(oright)->op_first->op_type != OP_GV
14441             || cUNOPx(oleft )->op_first->op_type != OP_GV
14442             || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
14443                cGVOPx_gv(cUNOPx(oright)->op_first)
14444         )
14445             return;
14446     }
14447     else if (oright->op_type != OP_PADAV
14448         || oright->op_targ != oleft->op_targ
14449     )
14450         return;
14451
14452     /* This actually is an inplace assignment */
14453
14454     modop->op_private |= OPpSORT_INPLACE;
14455
14456     /* transfer MODishness etc from LHS arg to RHS arg */
14457     oright->op_flags = oleft->op_flags;
14458
14459     /* remove the aassign op and the lhs */
14460     op_null(o);
14461     op_null(oleft_pushmark);
14462     if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
14463         op_null(cUNOPx(oleft)->op_first);
14464     op_null(oleft);
14465 }
14466
14467
14468
14469 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
14470  * that potentially represent a series of one or more aggregate derefs
14471  * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
14472  * the whole chain to a single OP_MULTIDEREF op (maybe with a few
14473  * additional ops left in too).
14474  *
14475  * The caller will have already verified that the first few ops in the
14476  * chain following 'start' indicate a multideref candidate, and will have
14477  * set 'orig_o' to the point further on in the chain where the first index
14478  * expression (if any) begins.  'orig_action' specifies what type of
14479  * beginning has already been determined by the ops between start..orig_o
14480  * (e.g.  $lex_ary[], $pkg_ary->{}, expr->[], etc).
14481  *
14482  * 'hints' contains any hints flags that need adding (currently just
14483  * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
14484  */
14485
14486 STATIC void
14487 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
14488 {
14489     dVAR;
14490     int pass;
14491     UNOP_AUX_item *arg_buf = NULL;
14492     bool reset_start_targ  = FALSE; /* start->op_targ needs zeroing */
14493     int index_skip         = -1;    /* don't output index arg on this action */
14494
14495     /* similar to regex compiling, do two passes; the first pass
14496      * determines whether the op chain is convertible and calculates the
14497      * buffer size; the second pass populates the buffer and makes any
14498      * changes necessary to ops (such as moving consts to the pad on
14499      * threaded builds).
14500      *
14501      * NB: for things like Coverity, note that both passes take the same
14502      * path through the logic tree (except for 'if (pass)' bits), since
14503      * both passes are following the same op_next chain; and in
14504      * particular, if it would return early on the second pass, it would
14505      * already have returned early on the first pass.
14506      */
14507     for (pass = 0; pass < 2; pass++) {
14508         OP *o                = orig_o;
14509         UV action            = orig_action;
14510         OP *first_elem_op    = NULL;  /* first seen aelem/helem */
14511         OP *top_op           = NULL;  /* highest [ah]elem/exists/del/rv2[ah]v */
14512         int action_count     = 0;     /* number of actions seen so far */
14513         int action_ix        = 0;     /* action_count % (actions per IV) */
14514         bool next_is_hash    = FALSE; /* is the next lookup to be a hash? */
14515         bool is_last         = FALSE; /* no more derefs to follow */
14516         bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
14517         UNOP_AUX_item *arg     = arg_buf;
14518         UNOP_AUX_item *action_ptr = arg_buf;
14519
14520         if (pass)
14521             action_ptr->uv = 0;
14522         arg++;
14523
14524         switch (action) {
14525         case MDEREF_HV_gvsv_vivify_rv2hv_helem:
14526         case MDEREF_HV_gvhv_helem:
14527             next_is_hash = TRUE;
14528             /* FALLTHROUGH */
14529         case MDEREF_AV_gvsv_vivify_rv2av_aelem:
14530         case MDEREF_AV_gvav_aelem:
14531             if (pass) {
14532 #ifdef USE_ITHREADS
14533                 arg->pad_offset = cPADOPx(start)->op_padix;
14534                 /* stop it being swiped when nulled */
14535                 cPADOPx(start)->op_padix = 0;
14536 #else
14537                 arg->sv = cSVOPx(start)->op_sv;
14538                 cSVOPx(start)->op_sv = NULL;
14539 #endif
14540             }
14541             arg++;
14542             break;
14543
14544         case MDEREF_HV_padhv_helem:
14545         case MDEREF_HV_padsv_vivify_rv2hv_helem:
14546             next_is_hash = TRUE;
14547             /* FALLTHROUGH */
14548         case MDEREF_AV_padav_aelem:
14549         case MDEREF_AV_padsv_vivify_rv2av_aelem:
14550             if (pass) {
14551                 arg->pad_offset = start->op_targ;
14552                 /* we skip setting op_targ = 0 for now, since the intact
14553                  * OP_PADXV is needed by S_check_hash_fields_and_hekify */
14554                 reset_start_targ = TRUE;
14555             }
14556             arg++;
14557             break;
14558
14559         case MDEREF_HV_pop_rv2hv_helem:
14560             next_is_hash = TRUE;
14561             /* FALLTHROUGH */
14562         case MDEREF_AV_pop_rv2av_aelem:
14563             break;
14564
14565         default:
14566             NOT_REACHED; /* NOTREACHED */
14567             return;
14568         }
14569
14570         while (!is_last) {
14571             /* look for another (rv2av/hv; get index;
14572              * aelem/helem/exists/delele) sequence */
14573
14574             OP *kid;
14575             bool is_deref;
14576             bool ok;
14577             UV index_type = MDEREF_INDEX_none;
14578
14579             if (action_count) {
14580                 /* if this is not the first lookup, consume the rv2av/hv  */
14581
14582                 /* for N levels of aggregate lookup, we normally expect
14583                  * that the first N-1 [ah]elem ops will be flagged as
14584                  * /DEREF (so they autovivifiy if necessary), and the last
14585                  * lookup op not to be.
14586                  * For other things (like @{$h{k1}{k2}}) extra scope or
14587                  * leave ops can appear, so abandon the effort in that
14588                  * case */
14589                 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
14590                     return;
14591
14592                 /* rv2av or rv2hv sKR/1 */
14593
14594                 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14595                                             |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14596                 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
14597                     return;
14598
14599                 /* at this point, we wouldn't expect any of these
14600                  * possible private flags:
14601                  * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
14602                  * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
14603                  */
14604                 ASSUME(!(o->op_private &
14605                     ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
14606
14607                 hints = (o->op_private & OPpHINT_STRICT_REFS);
14608
14609                 /* make sure the type of the previous /DEREF matches the
14610                  * type of the next lookup */
14611                 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
14612                 top_op = o;
14613
14614                 action = next_is_hash
14615                             ? MDEREF_HV_vivify_rv2hv_helem
14616                             : MDEREF_AV_vivify_rv2av_aelem;
14617                 o = o->op_next;
14618             }
14619
14620             /* if this is the second pass, and we're at the depth where
14621              * previously we encountered a non-simple index expression,
14622              * stop processing the index at this point */
14623             if (action_count != index_skip) {
14624
14625                 /* look for one or more simple ops that return an array
14626                  * index or hash key */
14627
14628                 switch (o->op_type) {
14629                 case OP_PADSV:
14630                     /* it may be a lexical var index */
14631                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
14632                                             |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14633                     ASSUME(!(o->op_private &
14634                             ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
14635
14636                     if (   OP_GIMME(o,0) == G_SCALAR
14637                         && !(o->op_flags & (OPf_REF|OPf_MOD))
14638                         && o->op_private == 0)
14639                     {
14640                         if (pass)
14641                             arg->pad_offset = o->op_targ;
14642                         arg++;
14643                         index_type = MDEREF_INDEX_padsv;
14644                         o = o->op_next;
14645                     }
14646                     break;
14647
14648                 case OP_CONST:
14649                     if (next_is_hash) {
14650                         /* it's a constant hash index */
14651                         if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
14652                             /* "use constant foo => FOO; $h{+foo}" for
14653                              * some weird FOO, can leave you with constants
14654                              * that aren't simple strings. It's not worth
14655                              * the extra hassle for those edge cases */
14656                             break;
14657
14658                         if (pass) {
14659                             UNOP *rop = NULL;
14660                             OP * helem_op = o->op_next;
14661
14662                             ASSUME(   helem_op->op_type == OP_HELEM
14663                                    || helem_op->op_type == OP_NULL);
14664                             if (helem_op->op_type == OP_HELEM) {
14665                                 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
14666                                 if (   helem_op->op_private & OPpLVAL_INTRO
14667                                     || rop->op_type != OP_RV2HV
14668                                 )
14669                                     rop = NULL;
14670                             }
14671                             S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo);
14672
14673 #ifdef USE_ITHREADS
14674                             /* Relocate sv to the pad for thread safety */
14675                             op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
14676                             arg->pad_offset = o->op_targ;
14677                             o->op_targ = 0;
14678 #else
14679                             arg->sv = cSVOPx_sv(o);
14680 #endif
14681                         }
14682                     }
14683                     else {
14684                         /* it's a constant array index */
14685                         IV iv;
14686                         SV *ix_sv = cSVOPo->op_sv;
14687                         if (!SvIOK(ix_sv))
14688                             break;
14689                         iv = SvIV(ix_sv);
14690
14691                         if (   action_count == 0
14692                             && iv >= -128
14693                             && iv <= 127
14694                             && (   action == MDEREF_AV_padav_aelem
14695                                 || action == MDEREF_AV_gvav_aelem)
14696                         )
14697                             maybe_aelemfast = TRUE;
14698
14699                         if (pass) {
14700                             arg->iv = iv;
14701                             SvREFCNT_dec_NN(cSVOPo->op_sv);
14702                         }
14703                     }
14704                     if (pass)
14705                         /* we've taken ownership of the SV */
14706                         cSVOPo->op_sv = NULL;
14707                     arg++;
14708                     index_type = MDEREF_INDEX_const;
14709                     o = o->op_next;
14710                     break;
14711
14712                 case OP_GV:
14713                     /* it may be a package var index */
14714
14715                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS|OPf_SPECIAL)));
14716                     ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
14717                     if (  (o->op_flags & ~(OPf_PARENS|OPf_SPECIAL)) != OPf_WANT_SCALAR
14718                         || o->op_private != 0
14719                     )
14720                         break;
14721
14722                     kid = o->op_next;
14723                     if (kid->op_type != OP_RV2SV)
14724                         break;
14725
14726                     ASSUME(!(kid->op_flags &
14727                             ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
14728                              |OPf_SPECIAL|OPf_PARENS)));
14729                     ASSUME(!(kid->op_private &
14730                                     ~(OPpARG1_MASK
14731                                      |OPpHINT_STRICT_REFS|OPpOUR_INTRO
14732                                      |OPpDEREF|OPpLVAL_INTRO)));
14733                     if(   (kid->op_flags &~ OPf_PARENS)
14734                             != (OPf_WANT_SCALAR|OPf_KIDS)
14735                        || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
14736                     )
14737                         break;
14738
14739                     if (pass) {
14740 #ifdef USE_ITHREADS
14741                         arg->pad_offset = cPADOPx(o)->op_padix;
14742                         /* stop it being swiped when nulled */
14743                         cPADOPx(o)->op_padix = 0;
14744 #else
14745                         arg->sv = cSVOPx(o)->op_sv;
14746                         cSVOPo->op_sv = NULL;
14747 #endif
14748                     }
14749                     arg++;
14750                     index_type = MDEREF_INDEX_gvsv;
14751                     o = kid->op_next;
14752                     break;
14753
14754                 } /* switch */
14755             } /* action_count != index_skip */
14756
14757             action |= index_type;
14758
14759
14760             /* at this point we have either:
14761              *   * detected what looks like a simple index expression,
14762              *     and expect the next op to be an [ah]elem, or
14763              *     an nulled  [ah]elem followed by a delete or exists;
14764              *  * found a more complex expression, so something other
14765              *    than the above follows.
14766              */
14767
14768             /* possibly an optimised away [ah]elem (where op_next is
14769              * exists or delete) */
14770             if (o->op_type == OP_NULL)
14771                 o = o->op_next;
14772
14773             /* at this point we're looking for an OP_AELEM, OP_HELEM,
14774              * OP_EXISTS or OP_DELETE */
14775
14776             /* if a custom array/hash access checker is in scope,
14777              * abandon optimisation attempt */
14778             if (  (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
14779                && PL_check[o->op_type] != Perl_ck_null)
14780                 return;
14781             /* similarly for customised exists and delete */
14782             if (  (o->op_type == OP_EXISTS)
14783                && PL_check[o->op_type] != Perl_ck_exists)
14784                 return;
14785             if (  (o->op_type == OP_DELETE)
14786                && PL_check[o->op_type] != Perl_ck_delete)
14787                 return;
14788
14789             if (   o->op_type != OP_AELEM
14790                 || (o->op_private &
14791                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
14792                 )
14793                 maybe_aelemfast = FALSE;
14794
14795             /* look for aelem/helem/exists/delete. If it's not the last elem
14796              * lookup, it *must* have OPpDEREF_AV/HV, but not many other
14797              * flags; if it's the last, then it mustn't have
14798              * OPpDEREF_AV/HV, but may have lots of other flags, like
14799              * OPpLVAL_INTRO etc
14800              */
14801
14802             if (   index_type == MDEREF_INDEX_none
14803                 || (   o->op_type != OP_AELEM  && o->op_type != OP_HELEM
14804                     && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
14805             )
14806                 ok = FALSE;
14807             else {
14808                 /* we have aelem/helem/exists/delete with valid simple index */
14809
14810                 is_deref =    (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
14811                            && (   (o->op_private & OPpDEREF) == OPpDEREF_AV
14812                                || (o->op_private & OPpDEREF) == OPpDEREF_HV);
14813
14814                 /* This doesn't make much sense but is legal:
14815                  *    @{ local $x[0][0] } = 1
14816                  * Since scope exit will undo the autovivification,
14817                  * don't bother in the first place. The OP_LEAVE
14818                  * assertion is in case there are other cases of both
14819                  * OPpLVAL_INTRO and OPpDEREF which don't include a scope
14820                  * exit that would undo the local - in which case this
14821                  * block of code would need rethinking.
14822                  */
14823                 if (is_deref && (o->op_private & OPpLVAL_INTRO)) {
14824 #ifdef DEBUGGING
14825                     OP *n = o->op_next;
14826                     while (n && (  n->op_type == OP_NULL
14827                                 || n->op_type == OP_LIST))
14828                         n = n->op_next;
14829                     assert(n && n->op_type == OP_LEAVE);
14830 #endif
14831                     o->op_private &= ~OPpDEREF;
14832                     is_deref = FALSE;
14833                 }
14834
14835                 if (is_deref) {
14836                     ASSUME(!(o->op_flags &
14837                                  ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
14838                     ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
14839
14840                     ok =    (o->op_flags &~ OPf_PARENS)
14841                                == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
14842                          && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
14843                 }
14844                 else if (o->op_type == OP_EXISTS) {
14845                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14846                                 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14847                     ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
14848                     ok =  !(o->op_private & ~OPpARG1_MASK);
14849                 }
14850                 else if (o->op_type == OP_DELETE) {
14851                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14852                                 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14853                     ASSUME(!(o->op_private &
14854                                     ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
14855                     /* don't handle slices or 'local delete'; the latter
14856                      * is fairly rare, and has a complex runtime */
14857                     ok =  !(o->op_private & ~OPpARG1_MASK);
14858                     if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
14859                         /* skip handling run-tome error */
14860                         ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
14861                 }
14862                 else {
14863                     ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
14864                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
14865                                             |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
14866                     ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
14867                                     |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
14868                     ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
14869                 }
14870             }
14871
14872             if (ok) {
14873                 if (!first_elem_op)
14874                     first_elem_op = o;
14875                 top_op = o;
14876                 if (is_deref) {
14877                     next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
14878                     o = o->op_next;
14879                 }
14880                 else {
14881                     is_last = TRUE;
14882                     action |= MDEREF_FLAG_last;
14883                 }
14884             }
14885             else {
14886                 /* at this point we have something that started
14887                  * promisingly enough (with rv2av or whatever), but failed
14888                  * to find a simple index followed by an
14889                  * aelem/helem/exists/delete. If this is the first action,
14890                  * give up; but if we've already seen at least one
14891                  * aelem/helem, then keep them and add a new action with
14892                  * MDEREF_INDEX_none, which causes it to do the vivify
14893                  * from the end of the previous lookup, and do the deref,
14894                  * but stop at that point. So $a[0][expr] will do one
14895                  * av_fetch, vivify and deref, then continue executing at
14896                  * expr */
14897                 if (!action_count)
14898                     return;
14899                 is_last = TRUE;
14900                 index_skip = action_count;
14901                 action |= MDEREF_FLAG_last;
14902                 if (index_type != MDEREF_INDEX_none)
14903                     arg--;
14904             }
14905
14906             if (pass)
14907                 action_ptr->uv |= (action << (action_ix * MDEREF_SHIFT));
14908             action_ix++;
14909             action_count++;
14910             /* if there's no space for the next action, create a new slot
14911              * for it *before* we start adding args for that action */
14912             if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
14913                 action_ptr = arg;
14914                 if (pass)
14915                     arg->uv = 0;
14916                 arg++;
14917                 action_ix = 0;
14918             }
14919         } /* while !is_last */
14920
14921         /* success! */
14922
14923         if (pass) {
14924             OP *mderef;
14925             OP *p, *q;
14926
14927             mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
14928             if (index_skip == -1) {
14929                 mderef->op_flags = o->op_flags
14930                         & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
14931                 if (o->op_type == OP_EXISTS)
14932                     mderef->op_private = OPpMULTIDEREF_EXISTS;
14933                 else if (o->op_type == OP_DELETE)
14934                     mderef->op_private = OPpMULTIDEREF_DELETE;
14935                 else
14936                     mderef->op_private = o->op_private
14937                         & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
14938             }
14939             /* accumulate strictness from every level (although I don't think
14940              * they can actually vary) */
14941             mderef->op_private |= hints;
14942
14943             /* integrate the new multideref op into the optree and the
14944              * op_next chain.
14945              *
14946              * In general an op like aelem or helem has two child
14947              * sub-trees: the aggregate expression (a_expr) and the
14948              * index expression (i_expr):
14949              *
14950              *     aelem
14951              *       |
14952              *     a_expr - i_expr
14953              *
14954              * The a_expr returns an AV or HV, while the i-expr returns an
14955              * index. In general a multideref replaces most or all of a
14956              * multi-level tree, e.g.
14957              *
14958              *     exists
14959              *       |
14960              *     ex-aelem
14961              *       |
14962              *     rv2av  - i_expr1
14963              *       |
14964              *     helem
14965              *       |
14966              *     rv2hv  - i_expr2
14967              *       |
14968              *     aelem
14969              *       |
14970              *     a_expr - i_expr3
14971              *
14972              * With multideref, all the i_exprs will be simple vars or
14973              * constants, except that i_expr1 may be arbitrary in the case
14974              * of MDEREF_INDEX_none.
14975              *
14976              * The bottom-most a_expr will be either:
14977              *   1) a simple var (so padXv or gv+rv2Xv);
14978              *   2) a simple scalar var dereferenced (e.g. $r->[0]):
14979              *      so a simple var with an extra rv2Xv;
14980              *   3) or an arbitrary expression.
14981              *
14982              * 'start', the first op in the execution chain, will point to
14983              *   1),2): the padXv or gv op;
14984              *   3):    the rv2Xv which forms the last op in the a_expr
14985              *          execution chain, and the top-most op in the a_expr
14986              *          subtree.
14987              *
14988              * For all cases, the 'start' node is no longer required,
14989              * but we can't free it since one or more external nodes
14990              * may point to it. E.g. consider
14991              *     $h{foo} = $a ? $b : $c
14992              * Here, both the op_next and op_other branches of the
14993              * cond_expr point to the gv[*h] of the hash expression, so
14994              * we can't free the 'start' op.
14995              *
14996              * For expr->[...], we need to save the subtree containing the
14997              * expression; for the other cases, we just need to save the
14998              * start node.
14999              * So in all cases, we null the start op and keep it around by
15000              * making it the child of the multideref op; for the expr->
15001              * case, the expr will be a subtree of the start node.
15002              *
15003              * So in the simple 1,2 case the  optree above changes to
15004              *
15005              *     ex-exists
15006              *       |
15007              *     multideref
15008              *       |
15009              *     ex-gv (or ex-padxv)
15010              *
15011              *  with the op_next chain being
15012              *
15013              *  -> ex-gv -> multideref -> op-following-ex-exists ->
15014              *
15015              *  In the 3 case, we have
15016              *
15017              *     ex-exists
15018              *       |
15019              *     multideref
15020              *       |
15021              *     ex-rv2xv
15022              *       |
15023              *    rest-of-a_expr
15024              *      subtree
15025              *
15026              *  and
15027              *
15028              *  -> rest-of-a_expr subtree ->
15029              *    ex-rv2xv -> multideref -> op-following-ex-exists ->
15030              *
15031              *
15032              * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
15033              * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
15034              * multideref attached as the child, e.g.
15035              *
15036              *     exists
15037              *       |
15038              *     ex-aelem
15039              *       |
15040              *     ex-rv2av  - i_expr1
15041              *       |
15042              *     multideref
15043              *       |
15044              *     ex-whatever
15045              *
15046              */
15047
15048             /* if we free this op, don't free the pad entry */
15049             if (reset_start_targ)
15050                 start->op_targ = 0;
15051
15052
15053             /* Cut the bit we need to save out of the tree and attach to
15054              * the multideref op, then free the rest of the tree */
15055
15056             /* find parent of node to be detached (for use by splice) */
15057             p = first_elem_op;
15058             if (   orig_action == MDEREF_AV_pop_rv2av_aelem
15059                 || orig_action == MDEREF_HV_pop_rv2hv_helem)
15060             {
15061                 /* there is an arbitrary expression preceding us, e.g.
15062                  * expr->[..]? so we need to save the 'expr' subtree */
15063                 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
15064                     p = cUNOPx(p)->op_first;
15065                 ASSUME(   start->op_type == OP_RV2AV
15066                        || start->op_type == OP_RV2HV);
15067             }
15068             else {
15069                 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
15070                  * above for exists/delete. */
15071                 while (   (p->op_flags & OPf_KIDS)
15072                        && cUNOPx(p)->op_first != start
15073                 )
15074                     p = cUNOPx(p)->op_first;
15075             }
15076             ASSUME(cUNOPx(p)->op_first == start);
15077
15078             /* detach from main tree, and re-attach under the multideref */
15079             op_sibling_splice(mderef, NULL, 0,
15080                     op_sibling_splice(p, NULL, 1, NULL));
15081             op_null(start);
15082
15083             start->op_next = mderef;
15084
15085             mderef->op_next = index_skip == -1 ? o->op_next : o;
15086
15087             /* excise and free the original tree, and replace with
15088              * the multideref op */
15089             p = op_sibling_splice(top_op, NULL, -1, mderef);
15090             while (p) {
15091                 q = OpSIBLING(p);
15092                 op_free(p);
15093                 p = q;
15094             }
15095             op_null(top_op);
15096         }
15097         else {
15098             Size_t size = arg - arg_buf;
15099
15100             if (maybe_aelemfast && action_count == 1)
15101                 return;
15102
15103             arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
15104                                 sizeof(UNOP_AUX_item) * (size + 1));
15105             /* for dumping etc: store the length in a hidden first slot;
15106              * we set the op_aux pointer to the second slot */
15107             arg_buf->uv = size;
15108             arg_buf++;
15109         }
15110     } /* for (pass = ...) */
15111 }
15112
15113 /* See if the ops following o are such that o will always be executed in
15114  * boolean context: that is, the SV which o pushes onto the stack will
15115  * only ever be consumed by later ops via SvTRUE(sv) or similar.
15116  * If so, set a suitable private flag on o. Normally this will be
15117  * bool_flag; but see below why maybe_flag is needed too.
15118  *
15119  * Typically the two flags you pass will be the generic OPpTRUEBOOL and
15120  * OPpMAYBE_TRUEBOOL, buts it's possible that for some ops those bits may
15121  * already be taken, so you'll have to give that op two different flags.
15122  *
15123  * More explanation of 'maybe_flag' and 'safe_and' parameters.
15124  * The binary logical ops &&, ||, // (plus 'if' and 'unless' which use
15125  * those underlying ops) short-circuit, which means that rather than
15126  * necessarily returning a truth value, they may return the LH argument,
15127  * which may not be boolean. For example in $x = (keys %h || -1), keys
15128  * should return a key count rather than a boolean, even though its
15129  * sort-of being used in boolean context.
15130  *
15131  * So we only consider such logical ops to provide boolean context to
15132  * their LH argument if they themselves are in void or boolean context.
15133  * However, sometimes the context isn't known until run-time. In this
15134  * case the op is marked with the maybe_flag flag it.
15135  *
15136  * Consider the following.
15137  *
15138  *     sub f { ....;  if (%h) { .... } }
15139  *
15140  * This is actually compiled as
15141  *
15142  *     sub f { ....;  %h && do { .... } }
15143  *
15144  * Here we won't know until runtime whether the final statement (and hence
15145  * the &&) is in void context and so is safe to return a boolean value.
15146  * So mark o with maybe_flag rather than the bool_flag.
15147  * Note that there is cost associated with determining context at runtime
15148  * (e.g. a call to block_gimme()), so it may not be worth setting (at
15149  * compile time) and testing (at runtime) maybe_flag if the scalar verses
15150  * boolean costs savings are marginal.
15151  *
15152  * However, we can do slightly better with && (compared to || and //):
15153  * this op only returns its LH argument when that argument is false. In
15154  * this case, as long as the op promises to return a false value which is
15155  * valid in both boolean and scalar contexts, we can mark an op consumed
15156  * by && with bool_flag rather than maybe_flag.
15157  * For example as long as pp_padhv and pp_rv2hv return &PL_sv_zero rather
15158  * than &PL_sv_no for a false result in boolean context, then it's safe. An
15159  * op which promises to handle this case is indicated by setting safe_and
15160  * to true.
15161  */
15162
15163 static void
15164 S_check_for_bool_cxt(OP*o, bool safe_and, U8 bool_flag, U8 maybe_flag)
15165 {
15166     OP *lop;
15167     U8 flag = 0;
15168
15169     assert((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR);
15170
15171     /* OPpTARGET_MY and boolean context probably don't mix well.
15172      * If someone finds a valid use case, maybe add an extra flag to this
15173      * function which indicates its safe to do so for this op? */
15174     assert(!(   (PL_opargs[o->op_type] & OA_TARGLEX)
15175              && (o->op_private & OPpTARGET_MY)));
15176
15177     lop = o->op_next;
15178
15179     while (lop) {
15180         switch (lop->op_type) {
15181         case OP_NULL:
15182         case OP_SCALAR:
15183             break;
15184
15185         /* these two consume the stack argument in the scalar case,
15186          * and treat it as a boolean in the non linenumber case */
15187         case OP_FLIP:
15188         case OP_FLOP:
15189             if (   ((lop->op_flags & OPf_WANT) == OPf_WANT_LIST)
15190                 || (lop->op_private & OPpFLIP_LINENUM))
15191             {
15192                 lop = NULL;
15193                 break;
15194             }
15195             /* FALLTHROUGH */
15196         /* these never leave the original value on the stack */
15197         case OP_NOT:
15198         case OP_XOR:
15199         case OP_COND_EXPR:
15200         case OP_GREPWHILE:
15201             flag = bool_flag;
15202             lop = NULL;
15203             break;
15204
15205         /* OR DOR and AND evaluate their arg as a boolean, but then may
15206          * leave the original scalar value on the stack when following the
15207          * op_next route. If not in void context, we need to ensure
15208          * that whatever follows consumes the arg only in boolean context
15209          * too.
15210          */
15211         case OP_AND:
15212             if (safe_and) {
15213                 flag = bool_flag;
15214                 lop = NULL;
15215                 break;
15216             }
15217             /* FALLTHROUGH */
15218         case OP_OR:
15219         case OP_DOR:
15220             if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
15221                 flag = bool_flag;
15222                 lop = NULL;
15223             }
15224             else if (!(lop->op_flags & OPf_WANT)) {
15225                 /* unknown context - decide at runtime */
15226                 flag = maybe_flag;
15227                 lop = NULL;
15228             }
15229             break;
15230
15231         default:
15232             lop = NULL;
15233             break;
15234         }
15235
15236         if (lop)
15237             lop = lop->op_next;
15238     }
15239
15240     o->op_private |= flag;
15241 }
15242
15243
15244
15245 /* mechanism for deferring recursion in rpeep() */
15246
15247 #define MAX_DEFERRED 4
15248
15249 #define DEFER(o) \
15250   STMT_START { \
15251     if (defer_ix == (MAX_DEFERRED-1)) { \
15252         OP **defer = defer_queue[defer_base]; \
15253         CALL_RPEEP(*defer); \
15254         S_prune_chain_head(defer); \
15255         defer_base = (defer_base + 1) % MAX_DEFERRED; \
15256         defer_ix--; \
15257     } \
15258     defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
15259   } STMT_END
15260
15261 #define IS_AND_OP(o)   (o->op_type == OP_AND)
15262 #define IS_OR_OP(o)    (o->op_type == OP_OR)
15263
15264
15265 /* A peephole optimizer.  We visit the ops in the order they're to execute.
15266  * See the comments at the top of this file for more details about when
15267  * peep() is called */
15268
15269 void
15270 Perl_rpeep(pTHX_ OP *o)
15271 {
15272     dVAR;
15273     OP* oldop = NULL;
15274     OP* oldoldop = NULL;
15275     OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
15276     int defer_base = 0;
15277     int defer_ix = -1;
15278
15279     if (!o || o->op_opt)
15280         return;
15281
15282     assert(o->op_type != OP_FREED);
15283
15284     ENTER;
15285     SAVEOP();
15286     SAVEVPTR(PL_curcop);
15287     for (;; o = o->op_next) {
15288         if (o && o->op_opt)
15289             o = NULL;
15290         if (!o) {
15291             while (defer_ix >= 0) {
15292                 OP **defer =
15293                         defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
15294                 CALL_RPEEP(*defer);
15295                 S_prune_chain_head(defer);
15296             }
15297             break;
15298         }
15299
15300       redo:
15301
15302         /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */
15303         assert(!oldoldop || oldoldop->op_next == oldop);
15304         assert(!oldop    || oldop->op_next    == o);
15305
15306         /* By default, this op has now been optimised. A couple of cases below
15307            clear this again.  */
15308         o->op_opt = 1;
15309         PL_op = o;
15310
15311         /* look for a series of 1 or more aggregate derefs, e.g.
15312          *   $a[1]{foo}[$i]{$k}
15313          * and replace with a single OP_MULTIDEREF op.
15314          * Each index must be either a const, or a simple variable,
15315          *
15316          * First, look for likely combinations of starting ops,
15317          * corresponding to (global and lexical variants of)
15318          *     $a[...]   $h{...}
15319          *     $r->[...] $r->{...}
15320          *     (preceding expression)->[...]
15321          *     (preceding expression)->{...}
15322          * and if so, call maybe_multideref() to do a full inspection
15323          * of the op chain and if appropriate, replace with an
15324          * OP_MULTIDEREF
15325          */
15326         {
15327             UV action;
15328             OP *o2 = o;
15329             U8 hints = 0;
15330
15331             switch (o2->op_type) {
15332             case OP_GV:
15333                 /* $pkg[..]   :   gv[*pkg]
15334                  * $pkg->[...]:   gv[*pkg]; rv2sv sKM/DREFAV */
15335
15336                 /* Fail if there are new op flag combinations that we're
15337                  * not aware of, rather than:
15338                  *  * silently failing to optimise, or
15339                  *  * silently optimising the flag away.
15340                  * If this ASSUME starts failing, examine what new flag
15341                  * has been added to the op, and decide whether the
15342                  * optimisation should still occur with that flag, then
15343                  * update the code accordingly. This applies to all the
15344                  * other ASSUMEs in the block of code too.
15345                  */
15346                 ASSUME(!(o2->op_flags &
15347                             ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
15348                 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
15349
15350                 o2 = o2->op_next;
15351
15352                 if (o2->op_type == OP_RV2AV) {
15353                     action = MDEREF_AV_gvav_aelem;
15354                     goto do_deref;
15355                 }
15356
15357                 if (o2->op_type == OP_RV2HV) {
15358                     action = MDEREF_HV_gvhv_helem;
15359                     goto do_deref;
15360                 }
15361
15362                 if (o2->op_type != OP_RV2SV)
15363                     break;
15364
15365                 /* at this point we've seen gv,rv2sv, so the only valid
15366                  * construct left is $pkg->[] or $pkg->{} */
15367
15368                 ASSUME(!(o2->op_flags & OPf_STACKED));
15369                 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15370                             != (OPf_WANT_SCALAR|OPf_MOD))
15371                     break;
15372
15373                 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
15374                                     |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
15375                 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
15376                     break;
15377                 if (   (o2->op_private & OPpDEREF) != OPpDEREF_AV
15378                     && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
15379                     break;
15380
15381                 o2 = o2->op_next;
15382                 if (o2->op_type == OP_RV2AV) {
15383                     action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
15384                     goto do_deref;
15385                 }
15386                 if (o2->op_type == OP_RV2HV) {
15387                     action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
15388                     goto do_deref;
15389                 }
15390                 break;
15391
15392             case OP_PADSV:
15393                 /* $lex->[...]: padsv[$lex] sM/DREFAV */
15394
15395                 ASSUME(!(o2->op_flags &
15396                     ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
15397                 if ((o2->op_flags &
15398                         (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15399                      != (OPf_WANT_SCALAR|OPf_MOD))
15400                     break;
15401
15402                 ASSUME(!(o2->op_private &
15403                                 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
15404                 /* skip if state or intro, or not a deref */
15405                 if (      o2->op_private != OPpDEREF_AV
15406                        && o2->op_private != OPpDEREF_HV)
15407                     break;
15408
15409                 o2 = o2->op_next;
15410                 if (o2->op_type == OP_RV2AV) {
15411                     action = MDEREF_AV_padsv_vivify_rv2av_aelem;
15412                     goto do_deref;
15413                 }
15414                 if (o2->op_type == OP_RV2HV) {
15415                     action = MDEREF_HV_padsv_vivify_rv2hv_helem;
15416                     goto do_deref;
15417                 }
15418                 break;
15419
15420             case OP_PADAV:
15421             case OP_PADHV:
15422                 /*    $lex[..]:  padav[@lex:1,2] sR *
15423                  * or $lex{..}:  padhv[%lex:1,2] sR */
15424                 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
15425                                             OPf_REF|OPf_SPECIAL)));
15426                 if ((o2->op_flags &
15427                         (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15428                      != (OPf_WANT_SCALAR|OPf_REF))
15429                     break;
15430                 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
15431                     break;
15432                 /* OPf_PARENS isn't currently used in this case;
15433                  * if that changes, let us know! */
15434                 ASSUME(!(o2->op_flags & OPf_PARENS));
15435
15436                 /* at this point, we wouldn't expect any of the remaining
15437                  * possible private flags:
15438                  * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
15439                  * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
15440                  *
15441                  * OPpSLICEWARNING shouldn't affect runtime
15442                  */
15443                 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
15444
15445                 action = o2->op_type == OP_PADAV
15446                             ? MDEREF_AV_padav_aelem
15447                             : MDEREF_HV_padhv_helem;
15448                 o2 = o2->op_next;
15449                 S_maybe_multideref(aTHX_ o, o2, action, 0);
15450                 break;
15451
15452
15453             case OP_RV2AV:
15454             case OP_RV2HV:
15455                 action = o2->op_type == OP_RV2AV
15456                             ? MDEREF_AV_pop_rv2av_aelem
15457                             : MDEREF_HV_pop_rv2hv_helem;
15458                 /* FALLTHROUGH */
15459             do_deref:
15460                 /* (expr)->[...]:  rv2av sKR/1;
15461                  * (expr)->{...}:  rv2hv sKR/1; */
15462
15463                 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
15464
15465                 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
15466                                 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
15467                 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
15468                     break;
15469
15470                 /* at this point, we wouldn't expect any of these
15471                  * possible private flags:
15472                  * OPpMAYBE_LVSUB, OPpLVAL_INTRO
15473                  * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
15474                  */
15475                 ASSUME(!(o2->op_private &
15476                     ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
15477                      |OPpOUR_INTRO)));
15478                 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
15479
15480                 o2 = o2->op_next;
15481
15482                 S_maybe_multideref(aTHX_ o, o2, action, hints);
15483                 break;
15484
15485             default:
15486                 break;
15487             }
15488         }
15489
15490
15491         switch (o->op_type) {
15492         case OP_DBSTATE:
15493             PL_curcop = ((COP*)o);              /* for warnings */
15494             break;
15495         case OP_NEXTSTATE:
15496             PL_curcop = ((COP*)o);              /* for warnings */
15497
15498             /* Optimise a "return ..." at the end of a sub to just be "...".
15499              * This saves 2 ops. Before:
15500              * 1  <;> nextstate(main 1 -e:1) v ->2
15501              * 4  <@> return K ->5
15502              * 2    <0> pushmark s ->3
15503              * -    <1> ex-rv2sv sK/1 ->4
15504              * 3      <#> gvsv[*cat] s ->4
15505              *
15506              * After:
15507              * -  <@> return K ->-
15508              * -    <0> pushmark s ->2
15509              * -    <1> ex-rv2sv sK/1 ->-
15510              * 2      <$> gvsv(*cat) s ->3
15511              */
15512             {
15513                 OP *next = o->op_next;
15514                 OP *sibling = OpSIBLING(o);
15515                 if (   OP_TYPE_IS(next, OP_PUSHMARK)
15516                     && OP_TYPE_IS(sibling, OP_RETURN)
15517                     && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
15518                     && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
15519                        ||OP_TYPE_IS(sibling->op_next->op_next,
15520                                     OP_LEAVESUBLV))
15521                     && cUNOPx(sibling)->op_first == next
15522                     && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
15523                     && next->op_next
15524                 ) {
15525                     /* Look through the PUSHMARK's siblings for one that
15526                      * points to the RETURN */
15527                     OP *top = OpSIBLING(next);
15528                     while (top && top->op_next) {
15529                         if (top->op_next == sibling) {
15530                             top->op_next = sibling->op_next;
15531                             o->op_next = next->op_next;
15532                             break;
15533                         }
15534                         top = OpSIBLING(top);
15535                     }
15536                 }
15537             }
15538
15539             /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
15540              *
15541              * This latter form is then suitable for conversion into padrange
15542              * later on. Convert:
15543              *
15544              *   nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
15545              *
15546              * into:
15547              *
15548              *   nextstate1 ->     listop     -> nextstate3
15549              *                 /            \
15550              *         pushmark -> padop1 -> padop2
15551              */
15552             if (o->op_next && (
15553                     o->op_next->op_type == OP_PADSV
15554                  || o->op_next->op_type == OP_PADAV
15555                  || o->op_next->op_type == OP_PADHV
15556                 )
15557                 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
15558                 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
15559                 && o->op_next->op_next->op_next && (
15560                     o->op_next->op_next->op_next->op_type == OP_PADSV
15561                  || o->op_next->op_next->op_next->op_type == OP_PADAV
15562                  || o->op_next->op_next->op_next->op_type == OP_PADHV
15563                 )
15564                 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
15565                 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
15566                 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
15567                 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
15568             ) {
15569                 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
15570
15571                 pad1 =    o->op_next;
15572                 ns2  = pad1->op_next;
15573                 pad2 =  ns2->op_next;
15574                 ns3  = pad2->op_next;
15575
15576                 /* we assume here that the op_next chain is the same as
15577                  * the op_sibling chain */
15578                 assert(OpSIBLING(o)    == pad1);
15579                 assert(OpSIBLING(pad1) == ns2);
15580                 assert(OpSIBLING(ns2)  == pad2);
15581                 assert(OpSIBLING(pad2) == ns3);
15582
15583                 /* excise and delete ns2 */
15584                 op_sibling_splice(NULL, pad1, 1, NULL);
15585                 op_free(ns2);
15586
15587                 /* excise pad1 and pad2 */
15588                 op_sibling_splice(NULL, o, 2, NULL);
15589
15590                 /* create new listop, with children consisting of:
15591                  * a new pushmark, pad1, pad2. */
15592                 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
15593                 newop->op_flags |= OPf_PARENS;
15594                 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
15595
15596                 /* insert newop between o and ns3 */
15597                 op_sibling_splice(NULL, o, 0, newop);
15598
15599                 /*fixup op_next chain */
15600                 newpm = cUNOPx(newop)->op_first; /* pushmark */
15601                 o    ->op_next = newpm;
15602                 newpm->op_next = pad1;
15603                 pad1 ->op_next = pad2;
15604                 pad2 ->op_next = newop; /* listop */
15605                 newop->op_next = ns3;
15606
15607                 /* Ensure pushmark has this flag if padops do */
15608                 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
15609                     newpm->op_flags |= OPf_MOD;
15610                 }
15611
15612                 break;
15613             }
15614
15615             /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
15616                to carry two labels. For now, take the easier option, and skip
15617                this optimisation if the first NEXTSTATE has a label.  */
15618             if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
15619                 OP *nextop = o->op_next;
15620                 while (nextop && nextop->op_type == OP_NULL)
15621                     nextop = nextop->op_next;
15622
15623                 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
15624                     op_null(o);
15625                     if (oldop)
15626                         oldop->op_next = nextop;
15627                     o = nextop;
15628                     /* Skip (old)oldop assignment since the current oldop's
15629                        op_next already points to the next op.  */
15630                     goto redo;
15631                 }
15632             }
15633             break;
15634
15635         case OP_CONCAT:
15636             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
15637                 if (o->op_next->op_private & OPpTARGET_MY) {
15638                     if (o->op_flags & OPf_STACKED) /* chained concats */
15639                         break; /* ignore_optimization */
15640                     else {
15641                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
15642                         o->op_targ = o->op_next->op_targ;
15643                         o->op_next->op_targ = 0;
15644                         o->op_private |= OPpTARGET_MY;
15645                     }
15646                 }
15647                 op_null(o->op_next);
15648             }
15649             break;
15650         case OP_STUB:
15651             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
15652                 break; /* Scalar stub must produce undef.  List stub is noop */
15653             }
15654             goto nothin;
15655         case OP_NULL:
15656             if (o->op_targ == OP_NEXTSTATE
15657                 || o->op_targ == OP_DBSTATE)
15658             {
15659                 PL_curcop = ((COP*)o);
15660             }
15661             /* XXX: We avoid setting op_seq here to prevent later calls
15662                to rpeep() from mistakenly concluding that optimisation
15663                has already occurred. This doesn't fix the real problem,
15664                though (See 20010220.007 (#5874)). AMS 20010719 */
15665             /* op_seq functionality is now replaced by op_opt */
15666             o->op_opt = 0;
15667             /* FALLTHROUGH */
15668         case OP_SCALAR:
15669         case OP_LINESEQ:
15670         case OP_SCOPE:
15671         nothin:
15672             if (oldop) {
15673                 oldop->op_next = o->op_next;
15674                 o->op_opt = 0;
15675                 continue;
15676             }
15677             break;
15678
15679         case OP_PUSHMARK:
15680
15681             /* Given
15682                  5 repeat/DOLIST
15683                  3   ex-list
15684                  1     pushmark
15685                  2     scalar or const
15686                  4   const[0]
15687                convert repeat into a stub with no kids.
15688              */
15689             if (o->op_next->op_type == OP_CONST
15690              || (  o->op_next->op_type == OP_PADSV
15691                 && !(o->op_next->op_private & OPpLVAL_INTRO))
15692              || (  o->op_next->op_type == OP_GV
15693                 && o->op_next->op_next->op_type == OP_RV2SV
15694                 && !(o->op_next->op_next->op_private
15695                         & (OPpLVAL_INTRO|OPpOUR_INTRO))))
15696             {
15697                 const OP *kid = o->op_next->op_next;
15698                 if (o->op_next->op_type == OP_GV)
15699                    kid = kid->op_next;
15700                 /* kid is now the ex-list.  */
15701                 if (kid->op_type == OP_NULL
15702                  && (kid = kid->op_next)->op_type == OP_CONST
15703                     /* kid is now the repeat count.  */
15704                  && kid->op_next->op_type == OP_REPEAT
15705                  && kid->op_next->op_private & OPpREPEAT_DOLIST
15706                  && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
15707                  && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0
15708                  && oldop)
15709                 {
15710                     o = kid->op_next; /* repeat */
15711                     oldop->op_next = o;
15712                     op_free(cBINOPo->op_first);
15713                     op_free(cBINOPo->op_last );
15714                     o->op_flags &=~ OPf_KIDS;
15715                     /* stub is a baseop; repeat is a binop */
15716                     STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
15717                     OpTYPE_set(o, OP_STUB);
15718                     o->op_private = 0;
15719                     break;
15720                 }
15721             }
15722
15723             /* Convert a series of PAD ops for my vars plus support into a
15724              * single padrange op. Basically
15725              *
15726              *    pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
15727              *
15728              * becomes, depending on circumstances, one of
15729              *
15730              *    padrange  ----------------------------------> (list) -> rest
15731              *    padrange  --------------------------------------------> rest
15732              *
15733              * where all the pad indexes are sequential and of the same type
15734              * (INTRO or not).
15735              * We convert the pushmark into a padrange op, then skip
15736              * any other pad ops, and possibly some trailing ops.
15737              * Note that we don't null() the skipped ops, to make it
15738              * easier for Deparse to undo this optimisation (and none of
15739              * the skipped ops are holding any resourses). It also makes
15740              * it easier for find_uninit_var(), as it can just ignore
15741              * padrange, and examine the original pad ops.
15742              */
15743         {
15744             OP *p;
15745             OP *followop = NULL; /* the op that will follow the padrange op */
15746             U8 count = 0;
15747             U8 intro = 0;
15748             PADOFFSET base = 0; /* init only to stop compiler whining */
15749             bool gvoid = 0;     /* init only to stop compiler whining */
15750             bool defav = 0;  /* seen (...) = @_ */
15751             bool reuse = 0;  /* reuse an existing padrange op */
15752
15753             /* look for a pushmark -> gv[_] -> rv2av */
15754
15755             {
15756                 OP *rv2av, *q;
15757                 p = o->op_next;
15758                 if (   p->op_type == OP_GV
15759                     && cGVOPx_gv(p) == PL_defgv
15760                     && (rv2av = p->op_next)
15761                     && rv2av->op_type == OP_RV2AV
15762                     && !(rv2av->op_flags & OPf_REF)
15763                     && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
15764                     && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
15765                 ) {
15766                     q = rv2av->op_next;
15767                     if (q->op_type == OP_NULL)
15768                         q = q->op_next;
15769                     if (q->op_type == OP_PUSHMARK) {
15770                         defav = 1;
15771                         p = q;
15772                     }
15773                 }
15774             }
15775             if (!defav) {
15776                 p = o;
15777             }
15778
15779             /* scan for PAD ops */
15780
15781             for (p = p->op_next; p; p = p->op_next) {
15782                 if (p->op_type == OP_NULL)
15783                     continue;
15784
15785                 if ((     p->op_type != OP_PADSV
15786                        && p->op_type != OP_PADAV
15787                        && p->op_type != OP_PADHV
15788                     )
15789                       /* any private flag other than INTRO? e.g. STATE */
15790                    || (p->op_private & ~OPpLVAL_INTRO)
15791                 )
15792                     break;
15793
15794                 /* let $a[N] potentially be optimised into AELEMFAST_LEX
15795                  * instead */
15796                 if (   p->op_type == OP_PADAV
15797                     && p->op_next
15798                     && p->op_next->op_type == OP_CONST
15799                     && p->op_next->op_next
15800                     && p->op_next->op_next->op_type == OP_AELEM
15801                 )
15802                     break;
15803
15804                 /* for 1st padop, note what type it is and the range
15805                  * start; for the others, check that it's the same type
15806                  * and that the targs are contiguous */
15807                 if (count == 0) {
15808                     intro = (p->op_private & OPpLVAL_INTRO);
15809                     base = p->op_targ;
15810                     gvoid = OP_GIMME(p,0) == G_VOID;
15811                 }
15812                 else {
15813                     if ((p->op_private & OPpLVAL_INTRO) != intro)
15814                         break;
15815                     /* Note that you'd normally  expect targs to be
15816                      * contiguous in my($a,$b,$c), but that's not the case
15817                      * when external modules start doing things, e.g.
15818                      * Function::Parameters */
15819                     if (p->op_targ != base + count)
15820                         break;
15821                     assert(p->op_targ == base + count);
15822                     /* Either all the padops or none of the padops should
15823                        be in void context.  Since we only do the optimisa-
15824                        tion for av/hv when the aggregate itself is pushed
15825                        on to the stack (one item), there is no need to dis-
15826                        tinguish list from scalar context.  */
15827                     if (gvoid != (OP_GIMME(p,0) == G_VOID))
15828                         break;
15829                 }
15830
15831                 /* for AV, HV, only when we're not flattening */
15832                 if (   p->op_type != OP_PADSV
15833                     && !gvoid
15834                     && !(p->op_flags & OPf_REF)
15835                 )
15836                     break;
15837
15838                 if (count >= OPpPADRANGE_COUNTMASK)
15839                     break;
15840
15841                 /* there's a biggest base we can fit into a
15842                  * SAVEt_CLEARPADRANGE in pp_padrange.
15843                  * (The sizeof() stuff will be constant-folded, and is
15844                  * intended to avoid getting "comparison is always false"
15845                  * compiler warnings. See the comments above
15846                  * MEM_WRAP_CHECK for more explanation on why we do this
15847                  * in a weird way to avoid compiler warnings.)
15848                  */
15849                 if (   intro
15850                     && (8*sizeof(base) >
15851                         8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
15852                         ? (Size_t)base
15853                         : (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
15854                         ) >
15855                         (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
15856                 )
15857                     break;
15858
15859                 /* Success! We've got another valid pad op to optimise away */
15860                 count++;
15861                 followop = p->op_next;
15862             }
15863
15864             if (count < 1 || (count == 1 && !defav))
15865                 break;
15866
15867             /* pp_padrange in specifically compile-time void context
15868              * skips pushing a mark and lexicals; in all other contexts
15869              * (including unknown till runtime) it pushes a mark and the
15870              * lexicals. We must be very careful then, that the ops we
15871              * optimise away would have exactly the same effect as the
15872              * padrange.
15873              * In particular in void context, we can only optimise to
15874              * a padrange if we see the complete sequence
15875              *     pushmark, pad*v, ...., list
15876              * which has the net effect of leaving the markstack as it
15877              * was.  Not pushing onto the stack (whereas padsv does touch
15878              * the stack) makes no difference in void context.
15879              */
15880             assert(followop);
15881             if (gvoid) {
15882                 if (followop->op_type == OP_LIST
15883                         && OP_GIMME(followop,0) == G_VOID
15884                    )
15885                 {
15886                     followop = followop->op_next; /* skip OP_LIST */
15887
15888                     /* consolidate two successive my(...);'s */
15889
15890                     if (   oldoldop
15891                         && oldoldop->op_type == OP_PADRANGE
15892                         && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
15893                         && (oldoldop->op_private & OPpLVAL_INTRO) == intro
15894                         && !(oldoldop->op_flags & OPf_SPECIAL)
15895                     ) {
15896                         U8 old_count;
15897                         assert(oldoldop->op_next == oldop);
15898                         assert(   oldop->op_type == OP_NEXTSTATE
15899                                || oldop->op_type == OP_DBSTATE);
15900                         assert(oldop->op_next == o);
15901
15902                         old_count
15903                             = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
15904
15905                        /* Do not assume pad offsets for $c and $d are con-
15906                           tiguous in
15907                             my ($a,$b,$c);
15908                             my ($d,$e,$f);
15909                         */
15910                         if (  oldoldop->op_targ + old_count == base
15911                            && old_count < OPpPADRANGE_COUNTMASK - count) {
15912                             base = oldoldop->op_targ;
15913                             count += old_count;
15914                             reuse = 1;
15915                         }
15916                     }
15917
15918                     /* if there's any immediately following singleton
15919                      * my var's; then swallow them and the associated
15920                      * nextstates; i.e.
15921                      *    my ($a,$b); my $c; my $d;
15922                      * is treated as
15923                      *    my ($a,$b,$c,$d);
15924                      */
15925
15926                     while (    ((p = followop->op_next))
15927                             && (  p->op_type == OP_PADSV
15928                                || p->op_type == OP_PADAV
15929                                || p->op_type == OP_PADHV)
15930                             && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
15931                             && (p->op_private & OPpLVAL_INTRO) == intro
15932                             && !(p->op_private & ~OPpLVAL_INTRO)
15933                             && p->op_next
15934                             && (   p->op_next->op_type == OP_NEXTSTATE
15935                                 || p->op_next->op_type == OP_DBSTATE)
15936                             && count < OPpPADRANGE_COUNTMASK
15937                             && base + count == p->op_targ
15938                     ) {
15939                         count++;
15940                         followop = p->op_next;
15941                     }
15942                 }
15943                 else
15944                     break;
15945             }
15946
15947             if (reuse) {
15948                 assert(oldoldop->op_type == OP_PADRANGE);
15949                 oldoldop->op_next = followop;
15950                 oldoldop->op_private = (intro | count);
15951                 o = oldoldop;
15952                 oldop = NULL;
15953                 oldoldop = NULL;
15954             }
15955             else {
15956                 /* Convert the pushmark into a padrange.
15957                  * To make Deparse easier, we guarantee that a padrange was
15958                  * *always* formerly a pushmark */
15959                 assert(o->op_type == OP_PUSHMARK);
15960                 o->op_next = followop;
15961                 OpTYPE_set(o, OP_PADRANGE);
15962                 o->op_targ = base;
15963                 /* bit 7: INTRO; bit 6..0: count */
15964                 o->op_private = (intro | count);
15965                 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
15966                               | gvoid * OPf_WANT_VOID
15967                               | (defav ? OPf_SPECIAL : 0));
15968             }
15969             break;
15970         }
15971
15972         case OP_RV2AV:
15973             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
15974                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
15975             break;
15976
15977         case OP_RV2HV:
15978         case OP_PADHV:
15979             /*'keys %h' in void or scalar context: skip the OP_KEYS
15980              * and perform the functionality directly in the RV2HV/PADHV
15981              * op
15982              */
15983             if (o->op_flags & OPf_REF) {
15984                 OP *k = o->op_next;
15985                 U8 want = (k->op_flags & OPf_WANT);
15986                 if (   k
15987                     && k->op_type == OP_KEYS
15988                     && (   want == OPf_WANT_VOID
15989                         || want == OPf_WANT_SCALAR)
15990                     && !(k->op_private & OPpMAYBE_LVSUB)
15991                     && !(k->op_flags & OPf_MOD)
15992                 ) {
15993                     o->op_next     = k->op_next;
15994                     o->op_flags   &= ~(OPf_REF|OPf_WANT);
15995                     o->op_flags   |= want;
15996                     o->op_private |= (o->op_type == OP_PADHV ?
15997                                       OPpPADHV_ISKEYS : OPpRV2HV_ISKEYS);
15998                     /* for keys(%lex), hold onto the OP_KEYS's targ
15999                      * since padhv doesn't have its own targ to return
16000                      * an int with */
16001                     if (!(o->op_type ==OP_PADHV && want == OPf_WANT_SCALAR))
16002                         op_null(k);
16003                 }
16004             }
16005
16006             /* see if %h is used in boolean context */
16007             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16008                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
16009
16010
16011             if (o->op_type != OP_PADHV)
16012                 break;
16013             /* FALLTHROUGH */
16014         case OP_PADAV:
16015             if (   o->op_type == OP_PADAV
16016                 && (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
16017             )
16018                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16019             /* FALLTHROUGH */
16020         case OP_PADSV:
16021             /* Skip over state($x) in void context.  */
16022             if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
16023              && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
16024             {
16025                 oldop->op_next = o->op_next;
16026                 goto redo_nextstate;
16027             }
16028             if (o->op_type != OP_PADAV)
16029                 break;
16030             /* FALLTHROUGH */
16031         case OP_GV:
16032             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
16033                 OP* const pop = (o->op_type == OP_PADAV) ?
16034                             o->op_next : o->op_next->op_next;
16035                 IV i;
16036                 if (pop && pop->op_type == OP_CONST &&
16037                     ((PL_op = pop->op_next)) &&
16038                     pop->op_next->op_type == OP_AELEM &&
16039                     !(pop->op_next->op_private &
16040                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
16041                     (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
16042                 {
16043                     GV *gv;
16044                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
16045                         no_bareword_allowed(pop);
16046                     if (o->op_type == OP_GV)
16047                         op_null(o->op_next);
16048                     op_null(pop->op_next);
16049                     op_null(pop);
16050                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
16051                     o->op_next = pop->op_next->op_next;
16052                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
16053                     o->op_private = (U8)i;
16054                     if (o->op_type == OP_GV) {
16055                         gv = cGVOPo_gv;
16056                         GvAVn(gv);
16057                         o->op_type = OP_AELEMFAST;
16058                     }
16059                     else
16060                         o->op_type = OP_AELEMFAST_LEX;
16061                 }
16062                 if (o->op_type != OP_GV)
16063                     break;
16064             }
16065
16066             /* Remove $foo from the op_next chain in void context.  */
16067             if (oldop
16068              && (  o->op_next->op_type == OP_RV2SV
16069                 || o->op_next->op_type == OP_RV2AV
16070                 || o->op_next->op_type == OP_RV2HV  )
16071              && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
16072              && !(o->op_next->op_private & OPpLVAL_INTRO))
16073             {
16074                 oldop->op_next = o->op_next->op_next;
16075                 /* Reprocess the previous op if it is a nextstate, to
16076                    allow double-nextstate optimisation.  */
16077               redo_nextstate:
16078                 if (oldop->op_type == OP_NEXTSTATE) {
16079                     oldop->op_opt = 0;
16080                     o = oldop;
16081                     oldop = oldoldop;
16082                     oldoldop = NULL;
16083                     goto redo;
16084                 }
16085                 o = oldop->op_next;
16086                 goto redo;
16087             }
16088             else if (o->op_next->op_type == OP_RV2SV) {
16089                 if (!(o->op_next->op_private & OPpDEREF)) {
16090                     op_null(o->op_next);
16091                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
16092                                                                | OPpOUR_INTRO);
16093                     o->op_next = o->op_next->op_next;
16094                     OpTYPE_set(o, OP_GVSV);
16095                 }
16096             }
16097             else if (o->op_next->op_type == OP_READLINE
16098                     && o->op_next->op_next->op_type == OP_CONCAT
16099                     && (o->op_next->op_next->op_flags & OPf_STACKED))
16100             {
16101                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
16102                 OpTYPE_set(o, OP_RCATLINE);
16103                 o->op_flags |= OPf_STACKED;
16104                 op_null(o->op_next->op_next);
16105                 op_null(o->op_next);
16106             }
16107
16108             break;
16109
16110         case OP_NOT:
16111             break;
16112
16113         case OP_AND:
16114         case OP_OR:
16115         case OP_DOR:
16116             while (cLOGOP->op_other->op_type == OP_NULL)
16117                 cLOGOP->op_other = cLOGOP->op_other->op_next;
16118             while (o->op_next && (   o->op_type == o->op_next->op_type
16119                                   || o->op_next->op_type == OP_NULL))
16120                 o->op_next = o->op_next->op_next;
16121
16122             /* If we're an OR and our next is an AND in void context, we'll
16123                follow its op_other on short circuit, same for reverse.
16124                We can't do this with OP_DOR since if it's true, its return
16125                value is the underlying value which must be evaluated
16126                by the next op. */
16127             if (o->op_next &&
16128                 (
16129                     (IS_AND_OP(o) && IS_OR_OP(o->op_next))
16130                  || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
16131                 )
16132                 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
16133             ) {
16134                 o->op_next = ((LOGOP*)o->op_next)->op_other;
16135             }
16136             DEFER(cLOGOP->op_other);
16137             o->op_opt = 1;
16138             break;
16139
16140         case OP_GREPWHILE:
16141             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16142                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16143             /* FALLTHROUGH */
16144         case OP_COND_EXPR:
16145         case OP_MAPWHILE:
16146         case OP_ANDASSIGN:
16147         case OP_ORASSIGN:
16148         case OP_DORASSIGN:
16149         case OP_RANGE:
16150         case OP_ONCE:
16151         case OP_ARGDEFELEM:
16152             while (cLOGOP->op_other->op_type == OP_NULL)
16153                 cLOGOP->op_other = cLOGOP->op_other->op_next;
16154             DEFER(cLOGOP->op_other);
16155             break;
16156
16157         case OP_ENTERLOOP:
16158         case OP_ENTERITER:
16159             while (cLOOP->op_redoop->op_type == OP_NULL)
16160                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
16161             while (cLOOP->op_nextop->op_type == OP_NULL)
16162                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
16163             while (cLOOP->op_lastop->op_type == OP_NULL)
16164                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
16165             /* a while(1) loop doesn't have an op_next that escapes the
16166              * loop, so we have to explicitly follow the op_lastop to
16167              * process the rest of the code */
16168             DEFER(cLOOP->op_lastop);
16169             break;
16170
16171         case OP_ENTERTRY:
16172             assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
16173             DEFER(cLOGOPo->op_other);
16174             break;
16175
16176         case OP_SUBST:
16177             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16178                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16179             assert(!(cPMOP->op_pmflags & PMf_ONCE));
16180             while (cPMOP->op_pmstashstartu.op_pmreplstart &&
16181                    cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
16182                 cPMOP->op_pmstashstartu.op_pmreplstart
16183                     = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
16184             DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
16185             break;
16186
16187         case OP_SORT: {
16188             OP *oright;
16189
16190             if (o->op_flags & OPf_SPECIAL) {
16191                 /* first arg is a code block */
16192                 OP * const nullop = OpSIBLING(cLISTOP->op_first);
16193                 OP * kid          = cUNOPx(nullop)->op_first;
16194
16195                 assert(nullop->op_type == OP_NULL);
16196                 assert(kid->op_type == OP_SCOPE
16197                  || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
16198                 /* since OP_SORT doesn't have a handy op_other-style
16199                  * field that can point directly to the start of the code
16200                  * block, store it in the otherwise-unused op_next field
16201                  * of the top-level OP_NULL. This will be quicker at
16202                  * run-time, and it will also allow us to remove leading
16203                  * OP_NULLs by just messing with op_nexts without
16204                  * altering the basic op_first/op_sibling layout. */
16205                 kid = kLISTOP->op_first;
16206                 assert(
16207                       (kid->op_type == OP_NULL
16208                       && (  kid->op_targ == OP_NEXTSTATE
16209                          || kid->op_targ == OP_DBSTATE  ))
16210                     || kid->op_type == OP_STUB
16211                     || kid->op_type == OP_ENTER
16212                     || (PL_parser && PL_parser->error_count));
16213                 nullop->op_next = kid->op_next;
16214                 DEFER(nullop->op_next);
16215             }
16216
16217             /* check that RHS of sort is a single plain array */
16218             oright = cUNOPo->op_first;
16219             if (!oright || oright->op_type != OP_PUSHMARK)
16220                 break;
16221
16222             if (o->op_private & OPpSORT_INPLACE)
16223                 break;
16224
16225             /* reverse sort ... can be optimised.  */
16226             if (!OpHAS_SIBLING(cUNOPo)) {
16227                 /* Nothing follows us on the list. */
16228                 OP * const reverse = o->op_next;
16229
16230                 if (reverse->op_type == OP_REVERSE &&
16231                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
16232                     OP * const pushmark = cUNOPx(reverse)->op_first;
16233                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
16234                         && (OpSIBLING(cUNOPx(pushmark)) == o)) {
16235                         /* reverse -> pushmark -> sort */
16236                         o->op_private |= OPpSORT_REVERSE;
16237                         op_null(reverse);
16238                         pushmark->op_next = oright->op_next;
16239                         op_null(oright);
16240                     }
16241                 }
16242             }
16243
16244             break;
16245         }
16246
16247         case OP_REVERSE: {
16248             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
16249             OP *gvop = NULL;
16250             LISTOP *enter, *exlist;
16251
16252             if (o->op_private & OPpSORT_INPLACE)
16253                 break;
16254
16255             enter = (LISTOP *) o->op_next;
16256             if (!enter)
16257                 break;
16258             if (enter->op_type == OP_NULL) {
16259                 enter = (LISTOP *) enter->op_next;
16260                 if (!enter)
16261                     break;
16262             }
16263             /* for $a (...) will have OP_GV then OP_RV2GV here.
16264                for (...) just has an OP_GV.  */
16265             if (enter->op_type == OP_GV) {
16266                 gvop = (OP *) enter;
16267                 enter = (LISTOP *) enter->op_next;
16268                 if (!enter)
16269                     break;
16270                 if (enter->op_type == OP_RV2GV) {
16271                   enter = (LISTOP *) enter->op_next;
16272                   if (!enter)
16273                     break;
16274                 }
16275             }
16276
16277             if (enter->op_type != OP_ENTERITER)
16278                 break;
16279
16280             iter = enter->op_next;
16281             if (!iter || iter->op_type != OP_ITER)
16282                 break;
16283
16284             expushmark = enter->op_first;
16285             if (!expushmark || expushmark->op_type != OP_NULL
16286                 || expushmark->op_targ != OP_PUSHMARK)
16287                 break;
16288
16289             exlist = (LISTOP *) OpSIBLING(expushmark);
16290             if (!exlist || exlist->op_type != OP_NULL
16291                 || exlist->op_targ != OP_LIST)
16292                 break;
16293
16294             if (exlist->op_last != o) {
16295                 /* Mmm. Was expecting to point back to this op.  */
16296                 break;
16297             }
16298             theirmark = exlist->op_first;
16299             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
16300                 break;
16301
16302             if (OpSIBLING(theirmark) != o) {
16303                 /* There's something between the mark and the reverse, eg
16304                    for (1, reverse (...))
16305                    so no go.  */
16306                 break;
16307             }
16308
16309             ourmark = ((LISTOP *)o)->op_first;
16310             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
16311                 break;
16312
16313             ourlast = ((LISTOP *)o)->op_last;
16314             if (!ourlast || ourlast->op_next != o)
16315                 break;
16316
16317             rv2av = OpSIBLING(ourmark);
16318             if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
16319                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
16320                 /* We're just reversing a single array.  */
16321                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
16322                 enter->op_flags |= OPf_STACKED;
16323             }
16324
16325             /* We don't have control over who points to theirmark, so sacrifice
16326                ours.  */
16327             theirmark->op_next = ourmark->op_next;
16328             theirmark->op_flags = ourmark->op_flags;
16329             ourlast->op_next = gvop ? gvop : (OP *) enter;
16330             op_null(ourmark);
16331             op_null(o);
16332             enter->op_private |= OPpITER_REVERSED;
16333             iter->op_private |= OPpITER_REVERSED;
16334
16335             oldoldop = NULL;
16336             oldop    = ourlast;
16337             o        = oldop->op_next;
16338             goto redo;
16339             NOT_REACHED; /* NOTREACHED */
16340             break;
16341         }
16342
16343         case OP_QR:
16344         case OP_MATCH:
16345             if (!(cPMOP->op_pmflags & PMf_ONCE)) {
16346                 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
16347             }
16348             break;
16349
16350         case OP_RUNCV:
16351             if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
16352              && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
16353             {
16354                 SV *sv;
16355                 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
16356                 else {
16357                     sv = newRV((SV *)PL_compcv);
16358                     sv_rvweaken(sv);
16359                     SvREADONLY_on(sv);
16360                 }
16361                 OpTYPE_set(o, OP_CONST);
16362                 o->op_flags |= OPf_SPECIAL;
16363                 cSVOPo->op_sv = sv;
16364             }
16365             break;
16366
16367         case OP_SASSIGN:
16368             if (OP_GIMME(o,0) == G_VOID
16369              || (  o->op_next->op_type == OP_LINESEQ
16370                 && (  o->op_next->op_next->op_type == OP_LEAVESUB
16371                    || (  o->op_next->op_next->op_type == OP_RETURN
16372                       && !CvLVALUE(PL_compcv)))))
16373             {
16374                 OP *right = cBINOP->op_first;
16375                 if (right) {
16376                     /*   sassign
16377                     *      RIGHT
16378                     *      substr
16379                     *         pushmark
16380                     *         arg1
16381                     *         arg2
16382                     *         ...
16383                     * becomes
16384                     *
16385                     *  ex-sassign
16386                     *     substr
16387                     *        pushmark
16388                     *        RIGHT
16389                     *        arg1
16390                     *        arg2
16391                     *        ...
16392                     */
16393                     OP *left = OpSIBLING(right);
16394                     if (left->op_type == OP_SUBSTR
16395                          && (left->op_private & 7) < 4) {
16396                         op_null(o);
16397                         /* cut out right */
16398                         op_sibling_splice(o, NULL, 1, NULL);
16399                         /* and insert it as second child of OP_SUBSTR */
16400                         op_sibling_splice(left, cBINOPx(left)->op_first, 0,
16401                                     right);
16402                         left->op_private |= OPpSUBSTR_REPL_FIRST;
16403                         left->op_flags =
16404                             (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
16405                     }
16406                 }
16407             }
16408             break;
16409
16410         case OP_AASSIGN: {
16411             int l, r, lr, lscalars, rscalars;
16412
16413             /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
16414                Note that we do this now rather than in newASSIGNOP(),
16415                since only by now are aliased lexicals flagged as such
16416
16417                See the essay "Common vars in list assignment" above for
16418                the full details of the rationale behind all the conditions
16419                below.
16420
16421                PL_generation sorcery:
16422                To detect whether there are common vars, the global var
16423                PL_generation is incremented for each assign op we scan.
16424                Then we run through all the lexical variables on the LHS,
16425                of the assignment, setting a spare slot in each of them to
16426                PL_generation.  Then we scan the RHS, and if any lexicals
16427                already have that value, we know we've got commonality.
16428                Also, if the generation number is already set to
16429                PERL_INT_MAX, then the variable is involved in aliasing, so
16430                we also have potential commonality in that case.
16431              */
16432
16433             PL_generation++;
16434             /* scan LHS */
16435             lscalars = 0;
16436             l = S_aassign_scan(aTHX_ cLISTOPo->op_last,  FALSE, 1, &lscalars);
16437             /* scan RHS */
16438             rscalars = 0;
16439             r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, 1, &rscalars);
16440             lr = (l|r);
16441
16442
16443             /* After looking for things which are *always* safe, this main
16444              * if/else chain selects primarily based on the type of the
16445              * LHS, gradually working its way down from the more dangerous
16446              * to the more restrictive and thus safer cases */
16447
16448             if (   !l                      /* () = ....; */
16449                 || !r                      /* .... = (); */
16450                 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
16451                 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
16452                 || (lscalars < 2)          /* ($x, undef) = ... */
16453             ) {
16454                 NOOP; /* always safe */
16455             }
16456             else if (l & AAS_DANGEROUS) {
16457                 /* always dangerous */
16458                 o->op_private |= OPpASSIGN_COMMON_SCALAR;
16459                 o->op_private |= OPpASSIGN_COMMON_AGG;
16460             }
16461             else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
16462                 /* package vars are always dangerous - too many
16463                  * aliasing possibilities */
16464                 if (l & AAS_PKG_SCALAR)
16465                     o->op_private |= OPpASSIGN_COMMON_SCALAR;
16466                 if (l & AAS_PKG_AGG)
16467                     o->op_private |= OPpASSIGN_COMMON_AGG;
16468             }
16469             else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
16470                           |AAS_LEX_SCALAR|AAS_LEX_AGG))
16471             {
16472                 /* LHS contains only lexicals and safe ops */
16473
16474                 if (l & (AAS_MY_AGG|AAS_LEX_AGG))
16475                     o->op_private |= OPpASSIGN_COMMON_AGG;
16476
16477                 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
16478                     if (lr & AAS_LEX_SCALAR_COMM)
16479                         o->op_private |= OPpASSIGN_COMMON_SCALAR;
16480                     else if (   !(l & AAS_LEX_SCALAR)
16481                              && (r & AAS_DEFAV))
16482                     {
16483                         /* falsely mark
16484                          *    my (...) = @_
16485                          * as scalar-safe for performance reasons.
16486                          * (it will still have been marked _AGG if necessary */
16487                         NOOP;
16488                     }
16489                     else if (r  & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
16490                         /* if there are only lexicals on the LHS and no
16491                          * common ones on the RHS, then we assume that the
16492                          * only way those lexicals could also get
16493                          * on the RHS is via some sort of dereffing or
16494                          * closure, e.g.
16495                          *    $r = \$lex;
16496                          *    ($lex, $x) = (1, $$r)
16497                          * and in this case we assume the var must have
16498                          *  a bumped ref count. So if its ref count is 1,
16499                          *  it must only be on the LHS.
16500                          */
16501                         o->op_private |= OPpASSIGN_COMMON_RC1;
16502                 }
16503             }
16504
16505             /* ... = ($x)
16506              * may have to handle aggregate on LHS, but we can't
16507              * have common scalars. */
16508             if (rscalars < 2)
16509                 o->op_private &=
16510                         ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
16511
16512             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16513                 S_check_for_bool_cxt(o, 1, OPpASSIGN_TRUEBOOL, 0);
16514             break;
16515         }
16516
16517         case OP_REF:
16518             /* see if ref() is used in boolean context */
16519             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16520                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
16521             break;
16522
16523         case OP_LENGTH:
16524             /* see if the op is used in known boolean context,
16525              * but not if OA_TARGLEX optimisation is enabled */
16526             if (   (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
16527                 && !(o->op_private & OPpTARGET_MY)
16528             )
16529                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16530             break;
16531
16532         case OP_POS:
16533             /* see if the op is used in known boolean context */
16534             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16535                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16536             break;
16537
16538         case OP_CUSTOM: {
16539             Perl_cpeep_t cpeep =
16540                 XopENTRYCUSTOM(o, xop_peep);
16541             if (cpeep)
16542                 cpeep(aTHX_ o, oldop);
16543             break;
16544         }
16545
16546         }
16547         /* did we just null the current op? If so, re-process it to handle
16548          * eliding "empty" ops from the chain */
16549         if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
16550             o->op_opt = 0;
16551             o = oldop;
16552         }
16553         else {
16554             oldoldop = oldop;
16555             oldop = o;
16556         }
16557     }
16558     LEAVE;
16559 }
16560
16561 void
16562 Perl_peep(pTHX_ OP *o)
16563 {
16564     CALL_RPEEP(o);
16565 }
16566
16567 /*
16568 =head1 Custom Operators
16569
16570 =for apidoc Ao||custom_op_xop
16571 Return the XOP structure for a given custom op.  This macro should be
16572 considered internal to C<OP_NAME> and the other access macros: use them instead.
16573 This macro does call a function.  Prior
16574 to 5.19.6, this was implemented as a
16575 function.
16576
16577 =cut
16578 */
16579
16580 XOPRETANY
16581 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
16582 {
16583     SV *keysv;
16584     HE *he = NULL;
16585     XOP *xop;
16586
16587     static const XOP xop_null = { 0, 0, 0, 0, 0 };
16588
16589     PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
16590     assert(o->op_type == OP_CUSTOM);
16591
16592     /* This is wrong. It assumes a function pointer can be cast to IV,
16593      * which isn't guaranteed, but this is what the old custom OP code
16594      * did. In principle it should be safer to Copy the bytes of the
16595      * pointer into a PV: since the new interface is hidden behind
16596      * functions, this can be changed later if necessary.  */
16597     /* Change custom_op_xop if this ever happens */
16598     keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
16599
16600     if (PL_custom_ops)
16601         he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
16602
16603     /* assume noone will have just registered a desc */
16604     if (!he && PL_custom_op_names &&
16605         (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
16606     ) {
16607         const char *pv;
16608         STRLEN l;
16609
16610         /* XXX does all this need to be shared mem? */
16611         Newxz(xop, 1, XOP);
16612         pv = SvPV(HeVAL(he), l);
16613         XopENTRY_set(xop, xop_name, savepvn(pv, l));
16614         if (PL_custom_op_descs &&
16615             (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
16616         ) {
16617             pv = SvPV(HeVAL(he), l);
16618             XopENTRY_set(xop, xop_desc, savepvn(pv, l));
16619         }
16620         Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
16621     }
16622     else {
16623         if (!he)
16624             xop = (XOP *)&xop_null;
16625         else
16626             xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
16627     }
16628     {
16629         XOPRETANY any;
16630         if(field == XOPe_xop_ptr) {
16631             any.xop_ptr = xop;
16632         } else {
16633             const U32 flags = XopFLAGS(xop);
16634             if(flags & field) {
16635                 switch(field) {
16636                 case XOPe_xop_name:
16637                     any.xop_name = xop->xop_name;
16638                     break;
16639                 case XOPe_xop_desc:
16640                     any.xop_desc = xop->xop_desc;
16641                     break;
16642                 case XOPe_xop_class:
16643                     any.xop_class = xop->xop_class;
16644                     break;
16645                 case XOPe_xop_peep:
16646                     any.xop_peep = xop->xop_peep;
16647                     break;
16648                 default:
16649                     NOT_REACHED; /* NOTREACHED */
16650                     break;
16651                 }
16652             } else {
16653                 switch(field) {
16654                 case XOPe_xop_name:
16655                     any.xop_name = XOPd_xop_name;
16656                     break;
16657                 case XOPe_xop_desc:
16658                     any.xop_desc = XOPd_xop_desc;
16659                     break;
16660                 case XOPe_xop_class:
16661                     any.xop_class = XOPd_xop_class;
16662                     break;
16663                 case XOPe_xop_peep:
16664                     any.xop_peep = XOPd_xop_peep;
16665                     break;
16666                 default:
16667                     NOT_REACHED; /* NOTREACHED */
16668                     break;
16669                 }
16670             }
16671         }
16672         /* On some platforms (HP-UX, IA64) gcc emits a warning for this function:
16673          * op.c: In function 'Perl_custom_op_get_field':
16674          * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
16675          * This is because on those platforms (with -DEBUGGING) NOT_REACHED
16676          * expands to assert(0), which expands to ((0) ? (void)0 :
16677          * __assert(...)), and gcc doesn't know that __assert can never return. */
16678         return any;
16679     }
16680 }
16681
16682 /*
16683 =for apidoc Ao||custom_op_register
16684 Register a custom op.  See L<perlguts/"Custom Operators">.
16685
16686 =cut
16687 */
16688
16689 void
16690 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
16691 {
16692     SV *keysv;
16693
16694     PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
16695
16696     /* see the comment in custom_op_xop */
16697     keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
16698
16699     if (!PL_custom_ops)
16700         PL_custom_ops = newHV();
16701
16702     if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
16703         Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
16704 }
16705
16706 /*
16707
16708 =for apidoc core_prototype
16709
16710 This function assigns the prototype of the named core function to C<sv>, or
16711 to a new mortal SV if C<sv> is C<NULL>.  It returns the modified C<sv>, or
16712 C<NULL> if the core function has no prototype.  C<code> is a code as returned
16713 by C<keyword()>.  It must not be equal to 0.
16714
16715 =cut
16716 */
16717
16718 SV *
16719 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
16720                           int * const opnum)
16721 {
16722     int i = 0, n = 0, seen_question = 0, defgv = 0;
16723     I32 oa;
16724 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
16725     char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
16726     bool nullret = FALSE;
16727
16728     PERL_ARGS_ASSERT_CORE_PROTOTYPE;
16729
16730     assert (code);
16731
16732     if (!sv) sv = sv_newmortal();
16733
16734 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
16735
16736     switch (code < 0 ? -code : code) {
16737     case KEY_and   : case KEY_chop: case KEY_chomp:
16738     case KEY_cmp   : case KEY_defined: case KEY_delete: case KEY_exec  :
16739     case KEY_exists: case KEY_eq     : case KEY_ge    : case KEY_goto  :
16740     case KEY_grep  : case KEY_gt     : case KEY_last  : case KEY_le    :
16741     case KEY_lt    : case KEY_map    : case KEY_ne    : case KEY_next  :
16742     case KEY_or    : case KEY_print  : case KEY_printf: case KEY_qr    :
16743     case KEY_redo  : case KEY_require: case KEY_return: case KEY_say   :
16744     case KEY_select: case KEY_sort   : case KEY_split : case KEY_system:
16745     case KEY_x     : case KEY_xor    :
16746         if (!opnum) return NULL; nullret = TRUE; goto findopnum;
16747     case KEY_glob:    retsetpvs("_;", OP_GLOB);
16748     case KEY_keys:    retsetpvs("\\[%@]", OP_KEYS);
16749     case KEY_values:  retsetpvs("\\[%@]", OP_VALUES);
16750     case KEY_each:    retsetpvs("\\[%@]", OP_EACH);
16751     case KEY_pos:     retsetpvs(";\\[$*]", OP_POS);
16752     case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
16753         retsetpvs("", 0);
16754     case KEY_evalbytes:
16755         name = "entereval"; break;
16756     case KEY_readpipe:
16757         name = "backtick";
16758     }
16759
16760 #undef retsetpvs
16761
16762   findopnum:
16763     while (i < MAXO) {  /* The slow way. */
16764         if (strEQ(name, PL_op_name[i])
16765             || strEQ(name, PL_op_desc[i]))
16766         {
16767             if (nullret) { assert(opnum); *opnum = i; return NULL; }
16768             goto found;
16769         }
16770         i++;
16771     }
16772     return NULL;
16773   found:
16774     defgv = PL_opargs[i] & OA_DEFGV;
16775     oa = PL_opargs[i] >> OASHIFT;
16776     while (oa) {
16777         if (oa & OA_OPTIONAL && !seen_question && (
16778               !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
16779         )) {
16780             seen_question = 1;
16781             str[n++] = ';';
16782         }
16783         if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
16784             && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
16785             /* But globs are already references (kinda) */
16786             && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
16787         ) {
16788             str[n++] = '\\';
16789         }
16790         if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
16791          && !scalar_mod_type(NULL, i)) {
16792             str[n++] = '[';
16793             str[n++] = '$';
16794             str[n++] = '@';
16795             str[n++] = '%';
16796             if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
16797             str[n++] = '*';
16798             str[n++] = ']';
16799         }
16800         else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
16801         if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
16802             str[n-1] = '_'; defgv = 0;
16803         }
16804         oa = oa >> 4;
16805     }
16806     if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
16807     str[n++] = '\0';
16808     sv_setpvn(sv, str, n - 1);
16809     if (opnum) *opnum = i;
16810     return sv;
16811 }
16812
16813 OP *
16814 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
16815                       const int opnum)
16816 {
16817     OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
16818     OP *o;
16819
16820     PERL_ARGS_ASSERT_CORESUB_OP;
16821
16822     switch(opnum) {
16823     case 0:
16824         return op_append_elem(OP_LINESEQ,
16825                        argop,
16826                        newSLICEOP(0,
16827                                   newSVOP(OP_CONST, 0, newSViv(-code % 3)),
16828                                   newOP(OP_CALLER,0)
16829                        )
16830                );
16831     case OP_EACH:
16832     case OP_KEYS:
16833     case OP_VALUES:
16834         o = newUNOP(OP_AVHVSWITCH,0,argop);
16835         o->op_private = opnum-OP_EACH;
16836         return o;
16837     case OP_SELECT: /* which represents OP_SSELECT as well */
16838         if (code)
16839             return newCONDOP(
16840                          0,
16841                          newBINOP(OP_GT, 0,
16842                                   newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
16843                                   newSVOP(OP_CONST, 0, newSVuv(1))
16844                                  ),
16845                          coresub_op(newSVuv((UV)OP_SSELECT), 0,
16846                                     OP_SSELECT),
16847                          coresub_op(coreargssv, 0, OP_SELECT)
16848                    );
16849         /* FALLTHROUGH */
16850     default:
16851         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
16852         case OA_BASEOP:
16853             return op_append_elem(
16854                         OP_LINESEQ, argop,
16855                         newOP(opnum,
16856                               opnum == OP_WANTARRAY || opnum == OP_RUNCV
16857                                 ? OPpOFFBYONE << 8 : 0)
16858                    );
16859         case OA_BASEOP_OR_UNOP:
16860             if (opnum == OP_ENTEREVAL) {
16861                 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
16862                 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
16863             }
16864             else o = newUNOP(opnum,0,argop);
16865             if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
16866             else {
16867           onearg:
16868               if (is_handle_constructor(o, 1))
16869                 argop->op_private |= OPpCOREARGS_DEREF1;
16870               if (scalar_mod_type(NULL, opnum))
16871                 argop->op_private |= OPpCOREARGS_SCALARMOD;
16872             }
16873             return o;
16874         default:
16875             o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
16876             if (is_handle_constructor(o, 2))
16877                 argop->op_private |= OPpCOREARGS_DEREF2;
16878             if (opnum == OP_SUBSTR) {
16879                 o->op_private |= OPpMAYBE_LVSUB;
16880                 return o;
16881             }
16882             else goto onearg;
16883         }
16884     }
16885 }
16886
16887 void
16888 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
16889                                SV * const *new_const_svp)
16890 {
16891     const char *hvname;
16892     bool is_const = !!CvCONST(old_cv);
16893     SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
16894
16895     PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
16896
16897     if (is_const && new_const_svp && old_const_sv == *new_const_svp)
16898         return;
16899         /* They are 2 constant subroutines generated from
16900            the same constant. This probably means that
16901            they are really the "same" proxy subroutine
16902            instantiated in 2 places. Most likely this is
16903            when a constant is exported twice.  Don't warn.
16904         */
16905     if (
16906         (ckWARN(WARN_REDEFINE)
16907          && !(
16908                 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
16909              && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
16910              && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
16911                  strEQ(hvname, "autouse"))
16912              )
16913         )
16914      || (is_const
16915          && ckWARN_d(WARN_REDEFINE)
16916          && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
16917         )
16918     )
16919         Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
16920                           is_const
16921                             ? "Constant subroutine %" SVf " redefined"
16922                             : "Subroutine %" SVf " redefined",
16923                           SVfARG(name));
16924 }
16925
16926 /*
16927 =head1 Hook manipulation
16928
16929 These functions provide convenient and thread-safe means of manipulating
16930 hook variables.
16931
16932 =cut
16933 */
16934
16935 /*
16936 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
16937
16938 Puts a C function into the chain of check functions for a specified op
16939 type.  This is the preferred way to manipulate the L</PL_check> array.
16940 C<opcode> specifies which type of op is to be affected.  C<new_checker>
16941 is a pointer to the C function that is to be added to that opcode's
16942 check chain, and C<old_checker_p> points to the storage location where a
16943 pointer to the next function in the chain will be stored.  The value of
16944 C<new_checker> is written into the L</PL_check> array, while the value
16945 previously stored there is written to C<*old_checker_p>.
16946
16947 L</PL_check> is global to an entire process, and a module wishing to
16948 hook op checking may find itself invoked more than once per process,
16949 typically in different threads.  To handle that situation, this function
16950 is idempotent.  The location C<*old_checker_p> must initially (once
16951 per process) contain a null pointer.  A C variable of static duration
16952 (declared at file scope, typically also marked C<static> to give
16953 it internal linkage) will be implicitly initialised appropriately,
16954 if it does not have an explicit initialiser.  This function will only
16955 actually modify the check chain if it finds C<*old_checker_p> to be null.
16956 This function is also thread safe on the small scale.  It uses appropriate
16957 locking to avoid race conditions in accessing L</PL_check>.
16958
16959 When this function is called, the function referenced by C<new_checker>
16960 must be ready to be called, except for C<*old_checker_p> being unfilled.
16961 In a threading situation, C<new_checker> may be called immediately,
16962 even before this function has returned.  C<*old_checker_p> will always
16963 be appropriately set before C<new_checker> is called.  If C<new_checker>
16964 decides not to do anything special with an op that it is given (which
16965 is the usual case for most uses of op check hooking), it must chain the
16966 check function referenced by C<*old_checker_p>.
16967
16968 Taken all together, XS code to hook an op checker should typically look
16969 something like this:
16970
16971     static Perl_check_t nxck_frob;
16972     static OP *myck_frob(pTHX_ OP *op) {
16973         ...
16974         op = nxck_frob(aTHX_ op);
16975         ...
16976         return op;
16977     }
16978     BOOT:
16979         wrap_op_checker(OP_FROB, myck_frob, &nxck_frob);
16980
16981 If you want to influence compilation of calls to a specific subroutine,
16982 then use L</cv_set_call_checker_flags> rather than hooking checking of
16983 all C<entersub> ops.
16984
16985 =cut
16986 */
16987
16988 void
16989 Perl_wrap_op_checker(pTHX_ Optype opcode,
16990     Perl_check_t new_checker, Perl_check_t *old_checker_p)
16991 {
16992     dVAR;
16993
16994     PERL_UNUSED_CONTEXT;
16995     PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
16996     if (*old_checker_p) return;
16997     OP_CHECK_MUTEX_LOCK;
16998     if (!*old_checker_p) {
16999         *old_checker_p = PL_check[opcode];
17000         PL_check[opcode] = new_checker;
17001     }
17002     OP_CHECK_MUTEX_UNLOCK;
17003 }
17004
17005 #include "XSUB.h"
17006
17007 /* Efficient sub that returns a constant scalar value. */
17008 static void
17009 const_sv_xsub(pTHX_ CV* cv)
17010 {
17011     dXSARGS;
17012     SV *const sv = MUTABLE_SV(XSANY.any_ptr);
17013     PERL_UNUSED_ARG(items);
17014     if (!sv) {
17015         XSRETURN(0);
17016     }
17017     EXTEND(sp, 1);
17018     ST(0) = sv;
17019     XSRETURN(1);
17020 }
17021
17022 static void
17023 const_av_xsub(pTHX_ CV* cv)
17024 {
17025     dXSARGS;
17026     AV * const av = MUTABLE_AV(XSANY.any_ptr);
17027     SP -= items;
17028     assert(av);
17029 #ifndef DEBUGGING
17030     if (!av) {
17031         XSRETURN(0);
17032     }
17033 #endif
17034     if (SvRMAGICAL(av))
17035         Perl_croak(aTHX_ "Magical list constants are not supported");
17036     if (GIMME_V != G_ARRAY) {
17037         EXTEND(SP, 1);
17038         ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
17039         XSRETURN(1);
17040     }
17041     EXTEND(SP, AvFILLp(av)+1);
17042     Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
17043     XSRETURN(AvFILLp(av)+1);
17044 }
17045
17046
17047 /*
17048  * ex: set ts=8 sts=4 sw=4 et:
17049  */