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 and manipulate the OP
  23  * 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 #include "invlist_inline.h"
 168
 169 #define CALL_PEEP(o) PL_peepp(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 /* remove any leading "empty" ops from the op_next chain whose first
 175  * node's address is stored in op_p. Store the updated address of the
 176  * first node in op_p.
 177  */
 178
 179 void
 180 Perl_op_prune_chain_head(OP** op_p)
 181 {
 182     PERL_ARGS_ASSERT_OP_PRUNE_CHAIN_HEAD;
 183
 184     while (*op_p
 185         && (   (*op_p)->op_type == OP_NULL
 186             || (*op_p)->op_type == OP_SCOPE
 187             || (*op_p)->op_type == OP_SCALAR
 188             || (*op_p)->op_type == OP_LINESEQ)
 189     )
 190         *op_p = (*op_p)->op_next;
 191 }
 192
 193
 194 /* See the explanatory comments above struct opslab in op.h. */
 195
 196 #ifdef PERL_DEBUG_READONLY_OPS
 197 #  define PERL_SLAB_SIZE 128
 198 #  define PERL_MAX_SLAB_SIZE 4096
 199 #  include <sys/mman.h>
 200 #endif
 201
 202 #ifndef PERL_SLAB_SIZE
 203 #  define PERL_SLAB_SIZE 64
 204 #endif
 205 #ifndef PERL_MAX_SLAB_SIZE
 206 #  define PERL_MAX_SLAB_SIZE 2048
 207 #endif
 208
 209 /* rounds up to nearest pointer */
 210 #define SIZE_TO_PSIZE(x)        (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
 211
 212 #define DIFF(o,p)       \
 213     (assert(((char *)(p) - (char *)(o)) % sizeof(I32**) == 0), \
 214       ((size_t)((I32 **)(p) - (I32**)(o))))
 215
 216 /* requires double parens and aTHX_ */
 217 #define DEBUG_S_warn(args)                                             \
 218     DEBUG_S(                                                            \
 219         PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
 220     )
 221
 222 /* opslot_size includes the size of the slot header, and an op can't be smaller than BASEOP */
 223 #define OPSLOT_SIZE_BASE (SIZE_TO_PSIZE(sizeof(OPSLOT)))
 224
 225 /* the number of bytes to allocate for a slab with sz * sizeof(I32 **) space for op */
 226 #define OpSLABSizeBytes(sz) \
 227     ((sz) * sizeof(I32 *) + STRUCT_OFFSET(OPSLAB, opslab_slots))
 228
 229 /* malloc a new op slab (suitable for attaching to PL_compcv).
 230  * sz is in units of pointers from the beginning of opslab_opslots */
 231
 232 static OPSLAB *
 233 S_new_slab(pTHX_ OPSLAB *head, size_t sz)
 234 {
 235     OPSLAB *slab;
 236     size_t sz_bytes = OpSLABSizeBytes(sz);
 237
 238     /* opslot_offset is only U16 */
 239     assert(sz < U16_MAX);
 240     /* room for at least one op */
 241     assert(sz >= OPSLOT_SIZE_BASE);
 242
 243 #ifdef PERL_DEBUG_READONLY_OPS
 244     slab = (OPSLAB *) mmap(0, sz_bytes,
 245                                    PROT_READ|PROT_WRITE,
 246                                    MAP_ANON|MAP_PRIVATE, -1, 0);
 247     DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
 248                           (unsigned long) sz, slab));
 249     if (slab == MAP_FAILED) {
 250         perror("mmap failed");
 251         abort();
 252     }
 253 #else
 254     slab = (OPSLAB *)PerlMemShared_malloc(sz_bytes);
 255     Zero(slab, sz_bytes, char);
 256 #endif
 257     slab->opslab_size = (U16)sz;
 258
 259 #ifndef WIN32
 260     /* The context is unused in non-Windows */
 261     PERL_UNUSED_CONTEXT;
 262 #endif
 263     slab->opslab_free_space = sz;
 264     slab->opslab_head = head ? head : slab;
 265     DEBUG_S_warn((aTHX_ "allocated new op slab sz 0x%x, %p, head slab %p",
 266         (unsigned int)slab->opslab_size, (void*)slab,
 267         (void*)(slab->opslab_head)));
 268     return slab;
 269 }
 270
 271 #define OPSLOT_SIZE_TO_INDEX(sz) ((sz) - OPSLOT_SIZE_BASE)
 272
 273 #define link_freed_op(slab, o) S_link_freed_op(aTHX_ slab, o)
 274 static void
 275 S_link_freed_op(pTHX_ OPSLAB *slab, OP *o) {
 276     U16 sz = OpSLOT(o)->opslot_size;
 277     U16 index = OPSLOT_SIZE_TO_INDEX(sz);
 278
 279     assert(sz >= OPSLOT_SIZE_BASE);
 280     /* make sure the array is large enough to include ops this large */
 281     if (!slab->opslab_freed) {
 282         /* we don't have a free list array yet, make a new one */
 283         slab->opslab_freed_size = index+1;
 284         slab->opslab_freed = (OP**)PerlMemShared_calloc((slab->opslab_freed_size), sizeof(OP*));
 285
 286         if (!slab->opslab_freed)
 287             croak_no_mem();
 288     }
 289     else if (index >= slab->opslab_freed_size) {
 290         /* It's probably not worth doing exponential expansion here, the number of op sizes
 291            is small.
 292         */
 293         /* We already have a list that isn't large enough, expand it */
 294         size_t newsize = index+1;
 295         OP **p = (OP **)PerlMemShared_realloc(slab->opslab_freed, newsize * sizeof(OP*));
 296
 297         if (!p)
 298             croak_no_mem();
 299
 300         Zero(p+slab->opslab_freed_size, newsize - slab->opslab_freed_size, OP *);
 301
 302         slab->opslab_freed = p;
 303         slab->opslab_freed_size = newsize;
 304     }
 305
 306     o->op_next = slab->opslab_freed[index];
 307     slab->opslab_freed[index] = o;
 308 }
 309
 310 /* Returns a sz-sized block of memory (suitable for holding an op) from
 311  * a free slot in the chain of op slabs attached to PL_compcv.
 312  * Allocates a new slab if necessary.
 313  * if PL_compcv isn't compiling, malloc() instead.
 314  */
 315
 316 void *
 317 Perl_Slab_Alloc(pTHX_ size_t sz)
 318 {
 319     OPSLAB *head_slab; /* first slab in the chain */
 320     OPSLAB *slab2;
 321     OPSLOT *slot;
 322     OP *o;
 323     size_t sz_in_p; /* size in pointer units, including the OPSLOT header */
 324
 325     /* We only allocate ops from the slab during subroutine compilation.
 326        We find the slab via PL_compcv, hence that must be non-NULL. It could
 327        also be pointing to a subroutine which is now fully set up (CvROOT()
 328        pointing to the top of the optree for that sub), or a subroutine
 329        which isn't using the slab allocator. If our sanity checks aren't met,
 330        don't use a slab, but allocate the OP directly from the heap.  */
 331     if (!PL_compcv || CvROOT(PL_compcv)
 332      || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
 333     {
 334         o = (OP*)PerlMemShared_calloc(1, sz);
 335         goto gotit;
 336     }
 337
 338     /* While the subroutine is under construction, the slabs are accessed via
 339        CvSTART(), to avoid needing to expand PVCV by one pointer for something
 340        unneeded at runtime. Once a subroutine is constructed, the slabs are
 341        accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
 342        allocated yet.  See the commit message for 8be227ab5eaa23f2 for more
 343        details.  */
 344     if (!CvSTART(PL_compcv)) {
 345         CvSTART(PL_compcv) =
 346             (OP *)(head_slab = S_new_slab(aTHX_ NULL, PERL_SLAB_SIZE));
 347         CvSLABBED_on(PL_compcv);
 348         head_slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
 349     }
 350     else ++(head_slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
 351
 352     sz_in_p = SIZE_TO_PSIZE(sz + OPSLOT_HEADER);
 353
 354     /* The head slab for each CV maintains a free list of OPs. In particular, constant folding
 355        will free up OPs, so it makes sense to re-use them where possible. A
 356        freed up slot is used in preference to a new allocation.  */
 357     if (head_slab->opslab_freed &&
 358         OPSLOT_SIZE_TO_INDEX(sz_in_p) < head_slab->opslab_freed_size) {
 359         U16 base_index;
 360
 361         /* look for a large enough size with any freed ops */
 362         for (base_index = OPSLOT_SIZE_TO_INDEX(sz_in_p);
 363              base_index < head_slab->opslab_freed_size && !head_slab->opslab_freed[base_index];
 364              ++base_index) {
 365         }
 366
 367         if (base_index < head_slab->opslab_freed_size) {
 368             /* found a freed op */
 369             o = head_slab->opslab_freed[base_index];
 370
 371             DEBUG_S_warn((aTHX_ "realloced  op at %p, slab %p, head slab %p",
 372                           (void *)o, (void *)OpMySLAB(o), (void *)head_slab));
 373             head_slab->opslab_freed[base_index] = o->op_next;
 374             Zero(o, sz, char);
 375             o->op_slabbed = 1;
 376             goto gotit;
 377         }
 378     }
 379
 380 #define INIT_OPSLOT(s) \
 381             slot->opslot_offset = DIFF(&slab2->opslab_slots, slot) ;    \
 382             slot->opslot_size = s;                      \
 383             slab2->opslab_free_space -= s;              \
 384             o = &slot->opslot_op;                       \
 385             o->op_slabbed = 1
 386
 387     /* The partially-filled slab is next in the chain. */
 388     slab2 = head_slab->opslab_next ? head_slab->opslab_next : head_slab;
 389     if (slab2->opslab_free_space < sz_in_p) {
 390         /* Remaining space is too small. */
 391         /* If we can fit a BASEOP, add it to the free chain, so as not
 392            to waste it. */
 393         if (slab2->opslab_free_space >= OPSLOT_SIZE_BASE) {
 394             slot = &slab2->opslab_slots;
 395             INIT_OPSLOT(slab2->opslab_free_space);
 396             o->op_type = OP_FREED;
 397             DEBUG_S_warn((aTHX_ "linked unused op space at %p, slab %p, head slab %p",
 398                           (void *)o, (void *)slab2, (void *)head_slab));
 399             link_freed_op(head_slab, o);
 400         }
 401
 402         /* Create a new slab.  Make this one twice as big. */
 403         slab2 = S_new_slab(aTHX_ head_slab,
 404                             slab2->opslab_size  > PERL_MAX_SLAB_SIZE / 2
 405                                 ? PERL_MAX_SLAB_SIZE
 406                                 : slab2->opslab_size * 2);
 407         slab2->opslab_next = head_slab->opslab_next;
 408         head_slab->opslab_next = slab2;
 409     }
 410     assert(slab2->opslab_size >= sz_in_p);
 411
 412     /* Create a new op slot */
 413     slot = OpSLOToff(slab2, slab2->opslab_free_space - sz_in_p);
 414     assert(slot >= &slab2->opslab_slots);
 415     INIT_OPSLOT(sz_in_p);
 416     DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p, head slab %p",
 417         (void*)o, (void*)slab2, (void*)head_slab));
 418
 419   gotit:
 420     /* moresib == 0, op_sibling == 0 implies a solitary unattached op */
 421     assert(!o->op_moresib);
 422     assert(!o->op_sibparent);
 423
 424     return (void *)o;
 425 }
 426
 427 #undef INIT_OPSLOT
 428
 429 #ifdef PERL_DEBUG_READONLY_OPS
 430 void
 431 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
 432 {
 433     PERL_ARGS_ASSERT_SLAB_TO_RO;
 434
 435     if (slab->opslab_readonly) return;
 436     slab->opslab_readonly = 1;
 437     for (; slab; slab = slab->opslab_next) {
 438         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
 439                               (unsigned long) slab->opslab_size, (void *)slab));*/
 440         if (mprotect(slab, OpSLABSizeBytes(slab->opslab_size), PROT_READ))
 441             Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", (void *)slab,
 442                              (unsigned long)slab->opslab_size, errno);
 443     }
 444 }
 445
 446 void
 447 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
 448 {
 449     OPSLAB *slab2;
 450
 451     PERL_ARGS_ASSERT_SLAB_TO_RW;
 452
 453     if (!slab->opslab_readonly) return;
 454     slab2 = slab;
 455     for (; slab2; slab2 = slab2->opslab_next) {
 456         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
 457                               (unsigned long) size, (void *)slab2));*/
 458         if (mprotect((void *)slab2, OpSLABSizeBytes(slab2->opslab_size),
 459                      PROT_READ|PROT_WRITE)) {
 460             Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", (void *)slab,
 461                              (unsigned long)slab2->opslab_size, errno);
 462         }
 463     }
 464     slab->opslab_readonly = 0;
 465 }
 466
 467 #else
 468 #  define Slab_to_rw(op)    NOOP
 469 #endif
 470
 471 /* make freed ops die if they're inadvertently executed */
 472 #ifdef DEBUGGING
 473 static OP *
 474 S_pp_freed(pTHX)
 475 {
 476     DIE(aTHX_ "panic: freed op 0x%p called\n", PL_op);
 477 }
 478 #endif
 479
 480
 481 /* Return the block of memory used by an op to the free list of
 482  * the OP slab associated with that op.
 483  */
 484
 485 void
 486 Perl_Slab_Free(pTHX_ void *op)
 487 {
 488     OP * const o = (OP *)op;
 489     OPSLAB *slab;
 490
 491     PERL_ARGS_ASSERT_SLAB_FREE;
 492
 493 #ifdef DEBUGGING
 494     o->op_ppaddr = S_pp_freed;
 495 #endif
 496
 497     if (!o->op_slabbed) {
 498         if (!o->op_static)
 499             PerlMemShared_free(op);
 500         return;
 501     }
 502
 503     slab = OpSLAB(o);
 504     /* If this op is already freed, our refcount will get screwy. */
 505     assert(o->op_type != OP_FREED);
 506     o->op_type = OP_FREED;
 507     link_freed_op(slab, o);
 508     DEBUG_S_warn((aTHX_ "freeing    op at %p, slab %p, head slab %p",
 509         (void*)o, (void *)OpMySLAB(o), (void*)slab));
 510     OpslabREFCNT_dec_padok(slab);
 511 }
 512
 513 void
 514 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
 515 {
 516     const bool havepad = cBOOL(PL_comppad);
 517     PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
 518     if (havepad) {
 519         ENTER;
 520         PAD_SAVE_SETNULLPAD();
 521     }
 522     opslab_free(slab);
 523     if (havepad) LEAVE;
 524 }
 525
 526 /* Free a chain of OP slabs. Should only be called after all ops contained
 527  * in it have been freed. At this point, its reference count should be 1,
 528  * because OpslabREFCNT_dec() skips doing rc-- when it detects that rc == 1,
 529  * and just directly calls opslab_free().
 530  * (Note that the reference count which PL_compcv held on the slab should
 531  * have been removed once compilation of the sub was complete).
 532  *
 533  *
 534  */
 535
 536 void
 537 Perl_opslab_free(pTHX_ OPSLAB *slab)
 538 {
 539     OPSLAB *slab2;
 540     PERL_ARGS_ASSERT_OPSLAB_FREE;
 541     PERL_UNUSED_CONTEXT;
 542     DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
 543     assert(slab->opslab_refcnt == 1);
 544     PerlMemShared_free(slab->opslab_freed);
 545     do {
 546         slab2 = slab->opslab_next;
 547 #ifdef DEBUGGING
 548         slab->opslab_refcnt = ~(size_t)0;
 549 #endif
 550 #ifdef PERL_DEBUG_READONLY_OPS
 551         DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
 552                                                (void*)slab));
 553         if (munmap(slab, OpSLABSizeBytes(slab->opslab_size))) {
 554             perror("munmap failed");
 555             abort();
 556         }
 557 #else
 558         PerlMemShared_free(slab);
 559 #endif
 560         slab = slab2;
 561     } while (slab);
 562 }
 563
 564 /* like opslab_free(), but first calls op_free() on any ops in the slab
 565  * not marked as OP_FREED
 566  */
 567
 568 void
 569 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
 570 {
 571     OPSLAB *slab2;
 572 #ifdef DEBUGGING
 573     size_t savestack_count = 0;
 574 #endif
 575     PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
 576     slab2 = slab;
 577     do {
 578         OPSLOT *slot = OpSLOToff(slab2, slab2->opslab_free_space);
 579         OPSLOT *end  = OpSLOToff(slab2, slab2->opslab_size);
 580         for (; slot < end;
 581                 slot = (OPSLOT*) ((I32**)slot + slot->opslot_size) )
 582         {
 583             if (slot->opslot_op.op_type != OP_FREED
 584              && !(slot->opslot_op.op_savefree
 585 #ifdef DEBUGGING
 586                   && ++savestack_count
 587 #endif
 588                  )
 589             ) {
 590                 assert(slot->opslot_op.op_slabbed);
 591                 op_free(&slot->opslot_op);
 592                 if (slab->opslab_refcnt == 1) goto free;
 593             }
 594         }
 595     } while ((slab2 = slab2->opslab_next));
 596     /* > 1 because the CV still holds a reference count. */
 597     if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
 598 #ifdef DEBUGGING
 599         assert(savestack_count == slab->opslab_refcnt-1);
 600 #endif
 601         /* Remove the CV’s reference count. */
 602         slab->opslab_refcnt--;
 603         return;
 604     }
 605    free:
 606     opslab_free(slab);
 607 }
 608
 609 #ifdef PERL_DEBUG_READONLY_OPS
 610 OP *
 611 Perl_op_refcnt_inc(pTHX_ OP *o)
 612 {
 613     if(o) {
 614         OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
 615         if (slab && slab->opslab_readonly) {
 616             Slab_to_rw(slab);
 617             ++o->op_targ;
 618             Slab_to_ro(slab);
 619         } else {
 620             ++o->op_targ;
 621         }
 622     }
 623     return o;
 624
 625 }
 626
 627 PADOFFSET
 628 Perl_op_refcnt_dec(pTHX_ OP *o)
 629 {
 630     PADOFFSET result;
 631     OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
 632
 633     PERL_ARGS_ASSERT_OP_REFCNT_DEC;
 634
 635     if (slab && slab->opslab_readonly) {
 636         Slab_to_rw(slab);
 637         result = --o->op_targ;
 638         Slab_to_ro(slab);
 639     } else {
 640         result = --o->op_targ;
 641     }
 642     return result;
 643 }
 644 #endif
 645 /*
 646  * In the following definition, the ", (OP*)0" is just to make the compiler
 647  * think the expression is of the right type: croak actually does a Siglongjmp.
 648  */
 649 #define CHECKOP(type,o) \
 650     ((PL_op_mask && PL_op_mask[type])                           \
 651      ? ( op_free((OP*)o),                                       \
 652          Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]),  \
 653          (OP*)0 )                                               \
 654      : PL_check[type](aTHX_ (OP*)o))
 655
 656 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
 657
 658 STATIC OP *
 659 S_no_fh_allowed(pTHX_ OP *o)
 660 {
 661     PERL_ARGS_ASSERT_NO_FH_ALLOWED;
 662
 663     yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
 664                  OP_DESC(o)));
 665     return o;
 666 }
 667
 668 STATIC OP *
 669 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
 670 {
 671     PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
 672     yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
 673     return o;
 674 }
 675
 676 STATIC OP *
 677 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
 678 {
 679     PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
 680
 681     yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
 682     return o;
 683 }
 684
 685 STATIC void
 686 S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid)
 687 {
 688     PERL_ARGS_ASSERT_BAD_TYPE_PV;
 689
 690     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
 691                  (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);
 692 }
 693
 694 STATIC void
 695 S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)
 696 {
 697     SV * const namesv = cv_name((CV *)gv, NULL, 0);
 698     PERL_ARGS_ASSERT_BAD_TYPE_GV;
 699
 700     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %" SVf " must be %s (not %s)",
 701                  (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
 702 }
 703
 704 void
 705 Perl_no_bareword_allowed(pTHX_ OP *o)
 706 {
 707     PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
 708
 709     qerror(Perl_mess(aTHX_
 710                      "Bareword \"%" SVf "\" not allowed while \"strict subs\" in use",
 711                      SVfARG(cSVOPo_sv)));
 712     o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
 713 }
 714
 715 void
 716 Perl_no_bareword_filehandle(pTHX_ const char *fhname) {
 717     PERL_ARGS_ASSERT_NO_BAREWORD_FILEHANDLE;
 718
 719     if (strNE(fhname, "STDERR")
 720         && strNE(fhname, "STDOUT")
 721         && strNE(fhname, "STDIN")
 722         && strNE(fhname, "_")
 723         && strNE(fhname, "ARGV")
 724         && strNE(fhname, "ARGVOUT")
 725         && strNE(fhname, "DATA")) {
 726         qerror(Perl_mess(aTHX_ "Bareword filehandle \"%s\" not allowed under 'no feature \"bareword_filehandles\"'", fhname));
 727     }
 728 }
 729
 730 /* "register" allocation */
 731
 732 PADOFFSET
 733 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
 734 {
 735     PADOFFSET off;
 736     bool is_idfirst, is_default;
 737     const bool is_our = (PL_parser->in_my == KEY_our);
 738
 739     PERL_ARGS_ASSERT_ALLOCMY;
 740
 741     if (flags & ~SVf_UTF8)
 742         Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
 743                    (UV)flags);
 744
 745     is_idfirst = flags & SVf_UTF8
 746         ? isIDFIRST_utf8_safe((U8*)name + 1, name + len)
 747         : isIDFIRST_A(name[1]);
 748
 749     /* $_, @_, etc. */
 750     is_default = len == 2 && name[1] == '_';
 751
 752     /* complain about "my $<special_var>" etc etc */
 753     if (!is_our && (!is_idfirst || is_default)) {
 754         const char * const type =
 755               PL_parser->in_my == KEY_sigvar ? "subroutine signature" :
 756               PL_parser->in_my == KEY_state  ? "\"state\""     : "\"my\"";
 757
 758         if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
 759          && isASCII(name[1])
 760          && (!isPRINT(name[1]) || memCHRs("\t\n\r\f", name[1]))) {
 761             /* diag_listed_as: Can't use global %s in %s */
 762             yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in %s",
 763                               name[0], toCTRL(name[1]),
 764                               (int)(len - 2), name + 2,
 765                               type));
 766         } else {
 767             yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in %s",
 768                               (int) len, name,
 769                               type), flags & SVf_UTF8);
 770         }
 771     }
 772
 773     /* allocate a spare slot and store the name in that slot */
 774
 775     off = pad_add_name_pvn(name, len,
 776                        (is_our ? padadd_OUR :
 777                         PL_parser->in_my == KEY_state ? padadd_STATE : 0),
 778                     PL_parser->in_my_stash,
 779                     (is_our
 780                         /* $_ is always in main::, even with our */
 781                         ? (PL_curstash && !memEQs(name,len,"$_")
 782                             ? PL_curstash
 783                             : PL_defstash)
 784                         : NULL
 785                     )
 786     );
 787     /* anon sub prototypes contains state vars should always be cloned,
 788      * otherwise the state var would be shared between anon subs */
 789
 790     if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
 791         CvCLONE_on(PL_compcv);
 792
 793     return off;
 794 }
 795
 796 /*
 797 =for apidoc_section $optree_manipulation
 798
 799 =for apidoc alloccopstash
 800
 801 Available only under threaded builds, this function allocates an entry in
 802 C<PL_stashpad> for the stash passed to it.
 803
 804 =cut
 805 */
 806
 807 #ifdef USE_ITHREADS
 808 PADOFFSET
 809 Perl_alloccopstash(pTHX_ HV *hv)
 810 {
 811     PADOFFSET off = 0, o = 1;
 812     bool found_slot = FALSE;
 813
 814     PERL_ARGS_ASSERT_ALLOCCOPSTASH;
 815
 816     if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
 817
 818     for (; o < PL_stashpadmax; ++o) {
 819         if (PL_stashpad[o] == hv) return PL_stashpadix = o;
 820         if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
 821             found_slot = TRUE, off = o;
 822     }
 823     if (!found_slot) {
 824         Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
 825         Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
 826         off = PL_stashpadmax;
 827         PL_stashpadmax += 10;
 828     }
 829
 830     PL_stashpad[PL_stashpadix = off] = hv;
 831     return off;
 832 }
 833 #endif
 834
 835 /* free the body of an op without examining its contents.
 836  * Always use this rather than FreeOp directly */
 837
 838 static void
 839 S_op_destroy(pTHX_ OP *o)
 840 {
 841     FreeOp(o);
 842 }
 843
 844 /* Destructor */
 845
 846 /*
 847 =for apidoc op_free
 848
 849 Free an op and its children. Only use this when an op is no longer linked
 850 to from any optree.
 851
 852 =cut
 853 */
 854
 855 void
 856 Perl_op_free(pTHX_ OP *o)
 857 {
 858     OPCODE type;
 859     OP *top_op = o;
 860     OP *next_op = o;
 861     bool went_up = FALSE; /* whether we reached the current node by
 862                             following the parent pointer from a child, and
 863                             so have already seen this node */
 864
 865     if (!o || o->op_type == OP_FREED)
 866         return;
 867
 868     if (o->op_private & OPpREFCOUNTED) {
 869         /* if base of tree is refcounted, just decrement */
 870         switch (o->op_type) {
 871         case OP_LEAVESUB:
 872         case OP_LEAVESUBLV:
 873         case OP_LEAVEEVAL:
 874         case OP_LEAVE:
 875         case OP_SCOPE:
 876         case OP_LEAVEWRITE:
 877             {
 878                 PADOFFSET refcnt;
 879                 OP_REFCNT_LOCK;
 880                 refcnt = OpREFCNT_dec(o);
 881                 OP_REFCNT_UNLOCK;
 882                 if (refcnt) {
 883                     /* Need to find and remove any pattern match ops from
 884                      * the list we maintain for reset().  */
 885                     find_and_forget_pmops(o);
 886                     return;
 887                 }
 888             }
 889             break;
 890         default:
 891             break;
 892         }
 893     }
 894
 895     while (next_op) {
 896         o = next_op;
 897
 898         /* free child ops before ourself, (then free ourself "on the
 899          * way back up") */
 900
 901         if (!went_up && o->op_flags & OPf_KIDS) {
 902             next_op = cUNOPo->op_first;
 903             continue;
 904         }
 905
 906         /* find the next node to visit, *then* free the current node
 907          * (can't rely on o->op_* fields being valid after o has been
 908          * freed) */
 909
 910         /* The next node to visit will be either the sibling, or the
 911          * parent if no siblings left, or NULL if we've worked our way
 912          * back up to the top node in the tree */
 913         next_op = (o == top_op) ? NULL : o->op_sibparent;
 914         went_up = cBOOL(!OpHAS_SIBLING(o)); /* parents are already visited */
 915
 916         /* Now process the current node */
 917
 918         /* Though ops may be freed twice, freeing the op after its slab is a
 919            big no-no. */
 920         assert(!o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
 921         /* During the forced freeing of ops after compilation failure, kidops
 922            may be freed before their parents. */
 923         if (!o || o->op_type == OP_FREED)
 924             continue;
 925
 926         type = o->op_type;
 927
 928         /* an op should only ever acquire op_private flags that we know about.
 929          * If this fails, you may need to fix something in regen/op_private.
 930          * Don't bother testing if:
 931          *   * the op_ppaddr doesn't match the op; someone may have
 932          *     overridden the op and be doing strange things with it;
 933          *   * we've errored, as op flags are often left in an
 934          *     inconsistent state then. Note that an error when
 935          *     compiling the main program leaves PL_parser NULL, so
 936          *     we can't spot faults in the main code, only
 937          *     evaled/required code;
 938          *   * it's a banned op - we may be croaking before the op is
 939          *     fully formed. - see CHECKOP. */
 940 #ifdef DEBUGGING
 941         if (   o->op_ppaddr == PL_ppaddr[type]
 942             && PL_parser
 943             && !PL_parser->error_count
 944             && !(PL_op_mask && PL_op_mask[type])
 945         )
 946         {
 947             assert(!(o->op_private & ~PL_op_private_valid[type]));
 948         }
 949 #endif
 950
 951
 952         /* Call the op_free hook if it has been set. Do it now so that it's called
 953          * at the right time for refcounted ops, but still before all of the kids
 954          * are freed. */
 955         CALL_OPFREEHOOK(o);
 956
 957         if (type == OP_NULL)
 958             type = (OPCODE)o->op_targ;
 959
 960         if (o->op_slabbed)
 961             Slab_to_rw(OpSLAB(o));
 962
 963         /* COP* is not cleared by op_clear() so that we may track line
 964          * numbers etc even after null() */
 965         if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
 966             cop_free((COP*)o);
 967         }
 968
 969         op_clear(o);
 970         FreeOp(o);
 971         if (PL_op == o)
 972             PL_op = NULL;
 973     }
 974 }
 975
 976
 977 /* S_op_clear_gv(): free a GV attached to an OP */
 978
 979 STATIC
 980 #ifdef USE_ITHREADS
 981 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
 982 #else
 983 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
 984 #endif
 985 {
 986
 987     GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
 988             || o->op_type == OP_MULTIDEREF)
 989 #ifdef USE_ITHREADS
 990                 && PL_curpad
 991                 ? ((GV*)PAD_SVl(*ixp)) : NULL;
 992 #else
 993                 ? (GV*)(*svp) : NULL;
 994 #endif
 995     /* It's possible during global destruction that the GV is freed
 996        before the optree. Whilst the SvREFCNT_inc is happy to bump from
 997        0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
 998        will trigger an assertion failure, because the entry to sv_clear
 999        checks that the scalar is not already freed.  A check of for
1000        !SvIS_FREED(gv) turns out to be invalid, because during global
1001        destruction the reference count can be forced down to zero
1002        (with SVf_BREAK set).  In which case raising to 1 and then
1003        dropping to 0 triggers cleanup before it should happen.  I
1004        *think* that this might actually be a general, systematic,
1005        weakness of the whole idea of SVf_BREAK, in that code *is*
1006        allowed to raise and lower references during global destruction,
1007        so any *valid* code that happens to do this during global
1008        destruction might well trigger premature cleanup.  */
1009     bool still_valid = gv && SvREFCNT(gv);
1010
1011     if (still_valid)
1012         SvREFCNT_inc_simple_void(gv);
1013 #ifdef USE_ITHREADS
1014     if (*ixp > 0) {
1015         pad_swipe(*ixp, TRUE);
1016         *ixp = 0;
1017     }
1018 #else
1019     SvREFCNT_dec(*svp);
1020     *svp = NULL;
1021 #endif
1022     if (still_valid) {
1023         int try_downgrade = SvREFCNT(gv) == 2;
1024         SvREFCNT_dec_NN(gv);
1025         if (try_downgrade)
1026             gv_try_downgrade(gv);
1027     }
1028 }
1029
1030
1031 void
1032 Perl_op_clear(pTHX_ OP *o)
1033 {
1034
1035
1036     PERL_ARGS_ASSERT_OP_CLEAR;
1037
1038     switch (o->op_type) {
1039     case OP_NULL:       /* Was holding old type, if any. */
1040         /* FALLTHROUGH */
1041     case OP_ENTERTRY:
1042     case OP_ENTEREVAL:  /* Was holding hints. */
1043     case OP_ARGDEFELEM: /* Was holding signature index. */
1044         o->op_targ = 0;
1045         break;
1046     default:
1047         if (!(o->op_flags & OPf_REF) || !OP_IS_STAT(o->op_type))
1048             break;
1049         /* FALLTHROUGH */
1050     case OP_GVSV:
1051     case OP_GV:
1052     case OP_AELEMFAST:
1053 #ifdef USE_ITHREADS
1054             S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
1055 #else
1056             S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
1057 #endif
1058         break;
1059     case OP_METHOD_REDIR:
1060     case OP_METHOD_REDIR_SUPER:
1061 #ifdef USE_ITHREADS
1062         if (cMETHOPo->op_rclass_targ) {
1063             pad_swipe(cMETHOPo->op_rclass_targ, 1);
1064             cMETHOPo->op_rclass_targ = 0;
1065         }
1066 #else
1067         SvREFCNT_dec(cMETHOPo->op_rclass_sv);
1068         cMETHOPo->op_rclass_sv = NULL;
1069 #endif
1070         /* FALLTHROUGH */
1071     case OP_METHOD_NAMED:
1072     case OP_METHOD_SUPER:
1073         SvREFCNT_dec(cMETHOPo->op_u.op_meth_sv);
1074         cMETHOPo->op_u.op_meth_sv = NULL;
1075 #ifdef USE_ITHREADS
1076         if (o->op_targ) {
1077             pad_swipe(o->op_targ, 1);
1078             o->op_targ = 0;
1079         }
1080 #endif
1081         break;
1082     case OP_CONST:
1083     case OP_HINTSEVAL:
1084         SvREFCNT_dec(cSVOPo->op_sv);
1085         cSVOPo->op_sv = NULL;
1086 #ifdef USE_ITHREADS
1087         /** Bug #15654
1088           Even if op_clear does a pad_free for the target of the op,
1089           pad_free doesn't actually remove the sv that exists in the pad;
1090           instead it lives on. This results in that it could be reused as
1091           a target later on when the pad was reallocated.
1092         **/
1093         if(o->op_targ) {
1094           pad_swipe(o->op_targ,1);
1095           o->op_targ = 0;
1096         }
1097 #endif
1098         break;
1099     case OP_DUMP:
1100     case OP_GOTO:
1101     case OP_NEXT:
1102     case OP_LAST:
1103     case OP_REDO:
1104         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
1105             break;
1106         /* FALLTHROUGH */
1107     case OP_TRANS:
1108     case OP_TRANSR:
1109         if (   (o->op_type == OP_TRANS || o->op_type == OP_TRANSR)
1110             && (o->op_private & OPpTRANS_USE_SVOP))
1111         {
1112 #ifdef USE_ITHREADS
1113             if (cPADOPo->op_padix > 0) {
1114                 pad_swipe(cPADOPo->op_padix, TRUE);
1115                 cPADOPo->op_padix = 0;
1116             }
1117 #else
1118             SvREFCNT_dec(cSVOPo->op_sv);
1119             cSVOPo->op_sv = NULL;
1120 #endif
1121         }
1122         else {
1123             PerlMemShared_free(cPVOPo->op_pv);
1124             cPVOPo->op_pv = NULL;
1125         }
1126         break;
1127     case OP_SUBST:
1128         op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
1129         goto clear_pmop;
1130
1131     case OP_SPLIT:
1132         if (     (o->op_private & OPpSPLIT_ASSIGN) /* @array  = split */
1133             && !(o->op_flags & OPf_STACKED))       /* @{expr} = split */
1134         {
1135             if (o->op_private & OPpSPLIT_LEX)
1136                 pad_free(cPMOPo->op_pmreplrootu.op_pmtargetoff);
1137             else
1138 #ifdef USE_ITHREADS
1139                 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
1140 #else
1141                 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
1142 #endif
1143         }
1144         /* FALLTHROUGH */
1145     case OP_MATCH:
1146     case OP_QR:
1147     clear_pmop:
1148         if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
1149             op_free(cPMOPo->op_code_list);
1150         cPMOPo->op_code_list = NULL;
1151         forget_pmop(cPMOPo);
1152         cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
1153         /* we use the same protection as the "SAFE" version of the PM_ macros
1154          * here since sv_clean_all might release some PMOPs
1155          * after PL_regex_padav has been cleared
1156          * and the clearing of PL_regex_padav needs to
1157          * happen before sv_clean_all
1158          */
1159 #ifdef USE_ITHREADS
1160         if(PL_regex_pad) {        /* We could be in destruction */
1161             const IV offset = (cPMOPo)->op_pmoffset;
1162             ReREFCNT_dec(PM_GETRE(cPMOPo));
1163             PL_regex_pad[offset] = &PL_sv_undef;
1164             sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
1165                            sizeof(offset));
1166         }
1167 #else
1168         ReREFCNT_dec(PM_GETRE(cPMOPo));
1169         PM_SETRE(cPMOPo, NULL);
1170 #endif
1171
1172         break;
1173
1174     case OP_ARGCHECK:
1175         PerlMemShared_free(cUNOP_AUXo->op_aux);
1176         break;
1177
1178     case OP_MULTICONCAT:
1179         {
1180             UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
1181             /* aux[PERL_MULTICONCAT_IX_PLAIN_PV] and/or
1182              * aux[PERL_MULTICONCAT_IX_UTF8_PV] point to plain and/or
1183              * utf8 shared strings */
1184             char *p1 = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
1185             char *p2 = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
1186             if (p1)
1187                 PerlMemShared_free(p1);
1188             if (p2 && p1 != p2)
1189                 PerlMemShared_free(p2);
1190             PerlMemShared_free(aux);
1191         }
1192         break;
1193
1194     case OP_MULTIDEREF:
1195         {
1196             UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1197             UV actions = items->uv;
1198             bool last = 0;
1199             bool is_hash = FALSE;
1200
1201             while (!last) {
1202                 switch (actions & MDEREF_ACTION_MASK) {
1203
1204                 case MDEREF_reload:
1205                     actions = (++items)->uv;
1206                     continue;
1207
1208                 case MDEREF_HV_padhv_helem:
1209                     is_hash = TRUE;
1210                     /* FALLTHROUGH */
1211                 case MDEREF_AV_padav_aelem:
1212                     pad_free((++items)->pad_offset);
1213                     goto do_elem;
1214
1215                 case MDEREF_HV_gvhv_helem:
1216                     is_hash = TRUE;
1217                     /* FALLTHROUGH */
1218                 case MDEREF_AV_gvav_aelem:
1219 #ifdef USE_ITHREADS
1220                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1221 #else
1222                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1223 #endif
1224                     goto do_elem;
1225
1226                 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1227                     is_hash = TRUE;
1228                     /* FALLTHROUGH */
1229                 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1230 #ifdef USE_ITHREADS
1231                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1232 #else
1233                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1234 #endif
1235                     goto do_vivify_rv2xv_elem;
1236
1237                 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1238                     is_hash = TRUE;
1239                     /* FALLTHROUGH */
1240                 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1241                     pad_free((++items)->pad_offset);
1242                     goto do_vivify_rv2xv_elem;
1243
1244                 case MDEREF_HV_pop_rv2hv_helem:
1245                 case MDEREF_HV_vivify_rv2hv_helem:
1246                     is_hash = TRUE;
1247                     /* FALLTHROUGH */
1248                 do_vivify_rv2xv_elem:
1249                 case MDEREF_AV_pop_rv2av_aelem:
1250                 case MDEREF_AV_vivify_rv2av_aelem:
1251                 do_elem:
1252                     switch (actions & MDEREF_INDEX_MASK) {
1253                     case MDEREF_INDEX_none:
1254                         last = 1;
1255                         break;
1256                     case MDEREF_INDEX_const:
1257                         if (is_hash) {
1258 #ifdef USE_ITHREADS
1259                             /* see RT #15654 */
1260                             pad_swipe((++items)->pad_offset, 1);
1261 #else
1262                             SvREFCNT_dec((++items)->sv);
1263 #endif
1264                         }
1265                         else
1266                             items++;
1267                         break;
1268                     case MDEREF_INDEX_padsv:
1269                         pad_free((++items)->pad_offset);
1270                         break;
1271                     case MDEREF_INDEX_gvsv:
1272 #ifdef USE_ITHREADS
1273                         S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1274 #else
1275                         S_op_clear_gv(aTHX_ o, &((++items)->sv));
1276 #endif
1277                         break;
1278                     }
1279
1280                     if (actions & MDEREF_FLAG_last)
1281                         last = 1;
1282                     is_hash = FALSE;
1283
1284                     break;
1285
1286                 default:
1287                     assert(0);
1288                     last = 1;
1289                     break;
1290
1291                 } /* switch */
1292
1293                 actions >>= MDEREF_SHIFT;
1294             } /* while */
1295
1296             /* start of malloc is at op_aux[-1], where the length is
1297              * stored */
1298             PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1299         }
1300         break;
1301     }
1302
1303     if (o->op_targ > 0) {
1304         pad_free(o->op_targ);
1305         o->op_targ = 0;
1306     }
1307 }
1308
1309 STATIC void
1310 S_cop_free(pTHX_ COP* cop)
1311 {
1312     PERL_ARGS_ASSERT_COP_FREE;
1313
1314     /* If called during global destruction PL_defstash might be NULL and there
1315        shouldn't be any code running that will trip over the bad cop address.
1316        This also avoids uselessly creating the AV after it's been destroyed.
1317     */
1318     if (cop->op_type == OP_DBSTATE && PL_phase != PERL_PHASE_DESTRUCT) {
1319         /* Remove the now invalid op from the line number information.
1320            This could cause a freed memory overwrite if the debugger tried to
1321            set a breakpoint on this line.
1322         */
1323         AV *av = CopFILEAVn(cop);
1324         if (av) {
1325             SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
1326             if (svp && *svp != &PL_sv_undef && SvIVX(*svp) == PTR2IV(cop) ) {
1327                 (void)SvIOK_off(*svp);
1328                 SvIV_set(*svp, 0);
1329             }
1330         }
1331     }
1332     CopFILE_free(cop);
1333     if (! specialWARN(cop->cop_warnings))
1334         PerlMemShared_free(cop->cop_warnings);
1335     cophh_free(CopHINTHASH_get(cop));
1336     if (PL_curcop == cop)
1337        PL_curcop = NULL;
1338 }
1339
1340 STATIC void
1341 S_forget_pmop(pTHX_ PMOP *const o)
1342 {
1343     HV * const pmstash = PmopSTASH(o);
1344
1345     PERL_ARGS_ASSERT_FORGET_PMOP;
1346
1347     if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1348         MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1349         if (mg) {
1350             PMOP **const array = (PMOP**) mg->mg_ptr;
1351             U32 count = mg->mg_len / sizeof(PMOP**);
1352             U32 i = count;
1353
1354             while (i--) {
1355                 if (array[i] == o) {
1356                     /* Found it. Move the entry at the end to overwrite it.  */
1357                     array[i] = array[--count];
1358                     mg->mg_len = count * sizeof(PMOP**);
1359                     /* Could realloc smaller at this point always, but probably
1360                        not worth it. Probably worth free()ing if we're the
1361                        last.  */
1362                     if(!count) {
1363                         Safefree(mg->mg_ptr);
1364                         mg->mg_ptr = NULL;
1365                     }
1366                     break;
1367                 }
1368             }
1369         }
1370     }
1371     if (PL_curpm == o)
1372         PL_curpm = NULL;
1373 }
1374
1375
1376 STATIC void
1377 S_find_and_forget_pmops(pTHX_ OP *o)
1378 {
1379     OP* top_op = o;
1380
1381     PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1382
1383     while (1) {
1384         switch (o->op_type) {
1385         case OP_SUBST:
1386         case OP_SPLIT:
1387         case OP_MATCH:
1388         case OP_QR:
1389             forget_pmop(cPMOPo);
1390         }
1391
1392         if (o->op_flags & OPf_KIDS) {
1393             o = cUNOPo->op_first;
1394             continue;
1395         }
1396
1397         while (1) {
1398             if (o == top_op)
1399                 return; /* at top; no parents/siblings to try */
1400             if (OpHAS_SIBLING(o)) {
1401                 o = o->op_sibparent; /* process next sibling */
1402                 break;
1403             }
1404             o = o->op_sibparent; /*try parent's next sibling */
1405         }
1406     }
1407 }
1408
1409
1410 /*
1411 =for apidoc op_null
1412
1413 Neutralizes an op when it is no longer needed, but is still linked to from
1414 other ops.
1415
1416 =cut
1417 */
1418
1419 void
1420 Perl_op_null(pTHX_ OP *o)
1421 {
1422
1423     PERL_ARGS_ASSERT_OP_NULL;
1424
1425     if (o->op_type == OP_NULL)
1426         return;
1427     op_clear(o);
1428     o->op_targ = o->op_type;
1429     OpTYPE_set(o, OP_NULL);
1430 }
1431
1432 /*
1433 =for apidoc op_refcnt_lock
1434
1435 Implements the C<OP_REFCNT_LOCK> macro which you should use instead.
1436
1437 =cut
1438 */
1439
1440 void
1441 Perl_op_refcnt_lock(pTHX)
1442   PERL_TSA_ACQUIRE(PL_op_mutex)
1443 {
1444     PERL_UNUSED_CONTEXT;
1445     OP_REFCNT_LOCK;
1446 }
1447
1448 /*
1449 =for apidoc op_refcnt_unlock
1450
1451 Implements the C<OP_REFCNT_UNLOCK> macro which you should use instead.
1452
1453 =cut
1454 */
1455
1456 void
1457 Perl_op_refcnt_unlock(pTHX)
1458   PERL_TSA_RELEASE(PL_op_mutex)
1459 {
1460     PERL_UNUSED_CONTEXT;
1461     OP_REFCNT_UNLOCK;
1462 }
1463
1464
1465 /*
1466 =for apidoc op_sibling_splice
1467
1468 A general function for editing the structure of an existing chain of
1469 op_sibling nodes.  By analogy with the perl-level C<splice()> function, allows
1470 you to delete zero or more sequential nodes, replacing them with zero or
1471 more different nodes.  Performs the necessary op_first/op_last
1472 housekeeping on the parent node and op_sibling manipulation on the
1473 children.  The last deleted node will be marked as the last node by
1474 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1475
1476 Note that op_next is not manipulated, and nodes are not freed; that is the
1477 responsibility of the caller.  It also won't create a new list op for an
1478 empty list etc; use higher-level functions like op_append_elem() for that.
1479
1480 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1481 the splicing doesn't affect the first or last op in the chain.
1482
1483 C<start> is the node preceding the first node to be spliced.  Node(s)
1484 following it will be deleted, and ops will be inserted after it.  If it is
1485 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1486 beginning.
1487
1488 C<del_count> is the number of nodes to delete.  If zero, no nodes are deleted.
1489 If -1 or greater than or equal to the number of remaining kids, all
1490 remaining kids are deleted.
1491
1492 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1493 If C<NULL>, no nodes are inserted.
1494
1495 The head of the chain of deleted ops is returned, or C<NULL> if no ops were
1496 deleted.
1497
1498 For example:
1499
1500     action                    before      after         returns
1501     ------                    -----       -----         -------
1502
1503                               P           P
1504     splice(P, A, 2, X-Y-Z)    |           |             B-C
1505                               A-B-C-D     A-X-Y-Z-D
1506
1507                               P           P
1508     splice(P, NULL, 1, X-Y)   |           |             A
1509                               A-B-C-D     X-Y-B-C-D
1510
1511                               P           P
1512     splice(P, NULL, 3, NULL)  |           |             A-B-C
1513                               A-B-C-D     D
1514
1515                               P           P
1516     splice(P, B, 0, X-Y)      |           |             NULL
1517                               A-B-C-D     A-B-X-Y-C-D
1518
1519
1520 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1521 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
1522
1523 =cut
1524 */
1525
1526 OP *
1527 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1528 {
1529     OP *first;
1530     OP *rest;
1531     OP *last_del = NULL;
1532     OP *last_ins = NULL;
1533
1534     if (start)
1535         first = OpSIBLING(start);
1536     else if (!parent)
1537         goto no_parent;
1538     else
1539         first = cLISTOPx(parent)->op_first;
1540
1541     assert(del_count >= -1);
1542
1543     if (del_count && first) {
1544         last_del = first;
1545         while (--del_count && OpHAS_SIBLING(last_del))
1546             last_del = OpSIBLING(last_del);
1547         rest = OpSIBLING(last_del);
1548         OpLASTSIB_set(last_del, NULL);
1549     }
1550     else
1551         rest = first;
1552
1553     if (insert) {
1554         last_ins = insert;
1555         while (OpHAS_SIBLING(last_ins))
1556             last_ins = OpSIBLING(last_ins);
1557         OpMAYBESIB_set(last_ins, rest, NULL);
1558     }
1559     else
1560         insert = rest;
1561
1562     if (start) {
1563         OpMAYBESIB_set(start, insert, NULL);
1564     }
1565     else {
1566         assert(parent);
1567         cLISTOPx(parent)->op_first = insert;
1568         if (insert)
1569             parent->op_flags |= OPf_KIDS;
1570         else
1571             parent->op_flags &= ~OPf_KIDS;
1572     }
1573
1574     if (!rest) {
1575         /* update op_last etc */
1576         U32 type;
1577         OP *lastop;
1578
1579         if (!parent)
1580             goto no_parent;
1581
1582         /* ought to use OP_CLASS(parent) here, but that can't handle
1583          * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1584          * either */
1585         type = parent->op_type;
1586         if (type == OP_CUSTOM) {
1587             dTHX;
1588             type = XopENTRYCUSTOM(parent, xop_class);
1589         }
1590         else {
1591             if (type == OP_NULL)
1592                 type = parent->op_targ;
1593             type = PL_opargs[type] & OA_CLASS_MASK;
1594         }
1595
1596         lastop = last_ins ? last_ins : start ? start : NULL;
1597         if (   type == OA_BINOP
1598             || type == OA_LISTOP
1599             || type == OA_PMOP
1600             || type == OA_LOOP
1601         )
1602             cLISTOPx(parent)->op_last = lastop;
1603
1604         if (lastop)
1605             OpLASTSIB_set(lastop, parent);
1606     }
1607     return last_del ? first : NULL;
1608
1609   no_parent:
1610     Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1611 }
1612
1613 /*
1614 =for apidoc op_parent
1615
1616 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1617
1618 =cut
1619 */
1620
1621 OP *
1622 Perl_op_parent(OP *o)
1623 {
1624     PERL_ARGS_ASSERT_OP_PARENT;
1625     while (OpHAS_SIBLING(o))
1626         o = OpSIBLING(o);
1627     return o->op_sibparent;
1628 }
1629
1630 /* replace the sibling following start with a new UNOP, which becomes
1631  * the parent of the original sibling; e.g.
1632  *
1633  *  op_sibling_newUNOP(P, A, unop-args...)
1634  *
1635  *  P              P
1636  *  |      becomes |
1637  *  A-B-C          A-U-C
1638  *                   |
1639  *                   B
1640  *
1641  * where U is the new UNOP.
1642  *
1643  * parent and start args are the same as for op_sibling_splice();
1644  * type and flags args are as newUNOP().
1645  *
1646  * Returns the new UNOP.
1647  */
1648
1649 STATIC OP *
1650 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1651 {
1652     OP *kid, *newop;
1653
1654     kid = op_sibling_splice(parent, start, 1, NULL);
1655     newop = newUNOP(type, flags, kid);
1656     op_sibling_splice(parent, start, 0, newop);
1657     return newop;
1658 }
1659
1660
1661 /* lowest-level newLOGOP-style function - just allocates and populates
1662  * the struct. Higher-level stuff should be done by S_new_logop() /
1663  * newLOGOP(). This function exists mainly to avoid op_first assignment
1664  * being spread throughout this file.
1665  */
1666
1667 LOGOP *
1668 Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1669 {
1670     LOGOP *logop;
1671     OP *kid = first;
1672     NewOp(1101, logop, 1, LOGOP);
1673     OpTYPE_set(logop, type);
1674     logop->op_first = first;
1675     logop->op_other = other;
1676     if (first)
1677         logop->op_flags = OPf_KIDS;
1678     while (kid && OpHAS_SIBLING(kid))
1679         kid = OpSIBLING(kid);
1680     if (kid)
1681         OpLASTSIB_set(kid, (OP*)logop);
1682     return logop;
1683 }
1684
1685
1686 /* Contextualizers */
1687
1688 /*
1689 =for apidoc op_contextualize
1690
1691 Applies a syntactic context to an op tree representing an expression.
1692 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_LIST>,
1693 or C<G_VOID> to specify the context to apply.  The modified op tree
1694 is returned.
1695
1696 =cut
1697 */
1698
1699 OP *
1700 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1701 {
1702     PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1703     switch (context) {
1704         case G_SCALAR: return scalar(o);
1705         case G_LIST:   return list(o);
1706         case G_VOID:   return scalarvoid(o);
1707         default:
1708             Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1709                        (long) context);
1710     }
1711 }
1712
1713 /*
1714
1715 =for apidoc op_linklist
1716 This function is the implementation of the L</LINKLIST> macro.  It should
1717 not be called directly.
1718
1719 =cut
1720 */
1721
1722
1723 OP *
1724 Perl_op_linklist(pTHX_ OP *o)
1725 {
1726
1727     OP **prevp;
1728     OP *kid;
1729     OP * top_op = o;
1730
1731     PERL_ARGS_ASSERT_OP_LINKLIST;
1732
1733     while (1) {
1734         /* Descend down the tree looking for any unprocessed subtrees to
1735          * do first */
1736         if (!o->op_next) {
1737             if (o->op_flags & OPf_KIDS) {
1738                 o = cUNOPo->op_first;
1739                 continue;
1740             }
1741             o->op_next = o; /* leaf node; link to self initially */
1742         }
1743
1744         /* if we're at the top level, there either weren't any children
1745          * to process, or we've worked our way back to the top. */
1746         if (o == top_op)
1747             return o->op_next;
1748
1749         /* o is now processed. Next, process any sibling subtrees */
1750
1751         if (OpHAS_SIBLING(o)) {
1752             o = OpSIBLING(o);
1753             continue;
1754         }
1755
1756         /* Done all the subtrees at this level. Go back up a level and
1757          * link the parent in with all its (processed) children.
1758          */
1759
1760         o = o->op_sibparent;
1761         assert(!o->op_next);
1762         prevp = &(o->op_next);
1763         kid   = (o->op_flags & OPf_KIDS) ? cUNOPo->op_first : NULL;
1764         while (kid) {
1765             *prevp = kid->op_next;
1766             prevp = &(kid->op_next);
1767             kid = OpSIBLING(kid);
1768         }
1769         *prevp = o;
1770     }
1771 }
1772
1773
1774 static OP *
1775 S_scalarkids(pTHX_ OP *o)
1776 {
1777     if (o && o->op_flags & OPf_KIDS) {
1778         OP *kid;
1779         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1780             scalar(kid);
1781     }
1782     return o;
1783 }
1784
1785 STATIC OP *
1786 S_scalarboolean(pTHX_ OP *o)
1787 {
1788     PERL_ARGS_ASSERT_SCALARBOOLEAN;
1789
1790     if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1791          !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1792         (o->op_type == OP_NOT     && cUNOPo->op_first->op_type == OP_SASSIGN &&
1793          cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1794          !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
1795         if (ckWARN(WARN_SYNTAX)) {
1796             const line_t oldline = CopLINE(PL_curcop);
1797
1798             if (PL_parser && PL_parser->copline != NOLINE) {
1799                 /* This ensures that warnings are reported at the first line
1800                    of the conditional, not the last.  */
1801                 CopLINE_set(PL_curcop, PL_parser->copline);
1802             }
1803             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1804             CopLINE_set(PL_curcop, oldline);
1805         }
1806     }
1807     return scalar(o);
1808 }
1809
1810 static SV *
1811 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1812 {
1813     assert(o);
1814     assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1815            o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1816     {
1817         const char funny  = o->op_type == OP_PADAV
1818                          || o->op_type == OP_RV2AV ? '@' : '%';
1819         if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1820             GV *gv;
1821             if (cUNOPo->op_first->op_type != OP_GV
1822              || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1823                 return NULL;
1824             return varname(gv, funny, 0, NULL, 0, subscript_type);
1825         }
1826         return
1827             varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1828     }
1829 }
1830
1831 SV *
1832 Perl_op_varname(pTHX_ const OP *o)
1833 {
1834     PERL_ARGS_ASSERT_OP_VARNAME;
1835
1836     return S_op_varname_subscript(aTHX_ o, 1);
1837 }
1838
1839 /*
1840
1841 Warns that an access of a single element from a named container variable in
1842 scalar context might not be what the programmer wanted. The container
1843 variable's (sigiled, full) name is given by C<name>, and the key to access
1844 it is given by the C<SVOP_sv> of the C<OP_CONST> op given by C<o>.
1845 C<is_hash> selects whether it prints using {KEY} or [KEY] brackets.
1846
1847 C<is_slice> selects between two different messages used in different places.
1848  */
1849 void
1850 Perl_warn_elem_scalar_context(pTHX_ const OP *o, SV *name, bool is_hash, bool is_slice)
1851 {
1852     PERL_ARGS_ASSERT_WARN_ELEM_SCALAR_CONTEXT;
1853
1854     SV *keysv = NULL;
1855     const char *keypv = NULL;
1856
1857     const char lbrack = is_hash ? '{' : '[';
1858     const char rbrack = is_hash ? '}' : ']';
1859
1860     if (o->op_type == OP_CONST) {
1861         keysv = cSVOPo_sv;
1862         if (SvPOK(keysv)) {
1863             SV *sv = keysv;
1864             keysv = sv_newmortal();
1865             pv_pretty(keysv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1866                       PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1867         }
1868         else if (!SvOK(keysv))
1869             keypv = "undef";
1870     }
1871     else keypv = "...";
1872
1873     assert(SvPOK(name));
1874     sv_chop(name,SvPVX(name)+1);
1875
1876     const char *msg;
1877
1878     if (keypv) {
1879         msg = is_slice ?
1880             "Scalar value @%" SVf "%c%s%c better written as $%" SVf "%c%s%c" :
1881             "%%%" SVf "%c%s%c in scalar context better written as $%" SVf "%c%s%c";
1882         /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1883         /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1884         Perl_warner(aTHX_ packWARN(WARN_SYNTAX), msg,
1885                 SVfARG(name), lbrack, keypv, rbrack,
1886                 SVfARG(name), lbrack, keypv, rbrack);
1887     }
1888     else {
1889         msg = is_slice ?
1890             "Scalar value @%" SVf "%c%" SVf "%c better written as $%" SVf "%c%" SVf "%c" :
1891             "%%%" SVf "%c%" SVf "%c in scalar context better written as $%" SVf "%c%" SVf "%c";
1892         /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1893         /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1894         Perl_warner(aTHX_ packWARN(WARN_SYNTAX), msg,
1895                 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1896                 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1897     }
1898 }
1899
1900
1901 /* apply scalar context to the o subtree */
1902
1903 OP *
1904 Perl_scalar(pTHX_ OP *o)
1905 {
1906     OP * top_op = o;
1907
1908     while (1) {
1909         OP *next_kid = NULL; /* what op (if any) to process next */
1910         OP *kid;
1911
1912         /* assumes no premature commitment */
1913         if (!o || (PL_parser && PL_parser->error_count)
1914              || (o->op_flags & OPf_WANT)
1915              || o->op_type == OP_RETURN)
1916         {
1917             goto do_next;
1918         }
1919
1920         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1921
1922         switch (o->op_type) {
1923         case OP_REPEAT:
1924             scalar(cBINOPo->op_first);
1925             /* convert what initially looked like a list repeat into a
1926              * scalar repeat, e.g. $s = (1) x $n
1927              */
1928             if (o->op_private & OPpREPEAT_DOLIST) {
1929                 kid = cLISTOPx(cUNOPo->op_first)->op_first;
1930                 assert(kid->op_type == OP_PUSHMARK);
1931                 if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1932                     op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1933                     o->op_private &=~ OPpREPEAT_DOLIST;
1934                 }
1935             }
1936             break;
1937
1938         case OP_OR:
1939         case OP_AND:
1940         case OP_COND_EXPR:
1941             /* impose scalar context on everything except the condition */
1942             next_kid = OpSIBLING(cUNOPo->op_first);
1943             break;
1944
1945         default:
1946             if (o->op_flags & OPf_KIDS)
1947                 next_kid = cUNOPo->op_first; /* do all kids */
1948             break;
1949
1950         /* the children of these ops are usually a list of statements,
1951          * except the leaves, whose first child is a corresponding enter
1952          */
1953         case OP_SCOPE:
1954         case OP_LINESEQ:
1955         case OP_LIST:
1956             kid = cLISTOPo->op_first;
1957             goto do_kids;
1958         case OP_LEAVE:
1959         case OP_LEAVETRY:
1960             kid = cLISTOPo->op_first;
1961             scalar(kid);
1962             kid = OpSIBLING(kid);
1963         do_kids:
1964             while (kid) {
1965                 OP *sib = OpSIBLING(kid);
1966                 /* Apply void context to all kids except the last, which
1967                  * is scalar (ignoring a trailing ex-nextstate in determining
1968                  * if it's the last kid). E.g.
1969                  *      $scalar = do { void; void; scalar }
1970                  * Except that 'when's are always scalar, e.g.
1971                  *      $scalar = do { given(..) {
1972                     *                 when (..) { scalar }
1973                     *                 when (..) { scalar }
1974                     *                 ...
1975                     *                }}
1976                     */
1977                 if (!sib
1978                      || (  !OpHAS_SIBLING(sib)
1979                          && sib->op_type == OP_NULL
1980                          && (   sib->op_targ == OP_NEXTSTATE
1981                              || sib->op_targ == OP_DBSTATE  )
1982                         )
1983                 )
1984                 {
1985                     /* tail call optimise calling scalar() on the last kid */
1986                     next_kid = kid;
1987                     goto do_next;
1988                 }
1989                 else if (kid->op_type == OP_LEAVEWHEN)
1990                     scalar(kid);
1991                 else
1992                     scalarvoid(kid);
1993                 kid = sib;
1994             }
1995             NOT_REACHED; /* NOTREACHED */
1996             break;
1997
1998         case OP_SORT:
1999             Perl_ck_warner(aTHX_ packWARN(WARN_SCALAR), "Useless use of %s in scalar context", "sort");
2000             break;
2001
2002         case OP_KVHSLICE:
2003         case OP_KVASLICE:
2004         {
2005             /* Warn about scalar context */
2006             SV *name;
2007
2008             /* This warning can be nonsensical when there is a syntax error. */
2009             if (PL_parser && PL_parser->error_count)
2010                 break;
2011
2012             if (!ckWARN(WARN_SYNTAX)) break;
2013
2014             kid = cLISTOPo->op_first;
2015             kid = OpSIBLING(kid); /* get past pushmark */
2016             assert(OpSIBLING(kid));
2017             name = op_varname(OpSIBLING(kid));
2018             if (!name) /* XS module fiddling with the op tree */
2019                 break;
2020             warn_elem_scalar_context(kid, name, o->op_type == OP_KVHSLICE, false);
2021         }
2022         } /* switch */
2023
2024         /* If next_kid is set, someone in the code above wanted us to process
2025          * that kid and all its remaining siblings.  Otherwise, work our way
2026          * back up the tree */
2027       do_next:
2028         while (!next_kid) {
2029             if (o == top_op)
2030                 return top_op; /* at top; no parents/siblings to try */
2031             if (OpHAS_SIBLING(o))
2032                 next_kid = o->op_sibparent;
2033             else {
2034                 o = o->op_sibparent; /*try parent's next sibling */
2035                 switch (o->op_type) {
2036                 case OP_SCOPE:
2037                 case OP_LINESEQ:
2038                 case OP_LIST:
2039                 case OP_LEAVE:
2040                 case OP_LEAVETRY:
2041                     /* should really restore PL_curcop to its old value, but
2042                      * setting it to PL_compiling is better than do nothing */
2043                     PL_curcop = &PL_compiling;
2044                 }
2045             }
2046         }
2047         o = next_kid;
2048     } /* while */
2049 }
2050
2051
2052 /* apply void context to the optree arg */
2053
2054 OP *
2055 Perl_scalarvoid(pTHX_ OP *arg)
2056 {
2057     OP *kid;
2058     SV* sv;
2059     OP *o = arg;
2060
2061     PERL_ARGS_ASSERT_SCALARVOID;
2062
2063     while (1) {
2064         U8 want;
2065         SV *useless_sv = NULL;
2066         const char* useless = NULL;
2067         OP * next_kid = NULL;
2068
2069         if (o->op_type == OP_NEXTSTATE
2070             || o->op_type == OP_DBSTATE
2071             || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
2072                                           || o->op_targ == OP_DBSTATE)))
2073             PL_curcop = (COP*)o;                /* for warning below */
2074
2075         /* assumes no premature commitment */
2076         want = o->op_flags & OPf_WANT;
2077         if ((want && want != OPf_WANT_SCALAR)
2078             || (PL_parser && PL_parser->error_count)
2079             || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
2080         {
2081             goto get_next_op;
2082         }
2083
2084         if ((o->op_private & OPpTARGET_MY)
2085             && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2086         {
2087             /* newASSIGNOP has already applied scalar context, which we
2088                leave, as if this op is inside SASSIGN.  */
2089             goto get_next_op;
2090         }
2091
2092         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
2093
2094         switch (o->op_type) {
2095         default:
2096             if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
2097                 break;
2098             /* FALLTHROUGH */
2099         case OP_REPEAT:
2100             if (o->op_flags & OPf_STACKED)
2101                 break;
2102             if (o->op_type == OP_REPEAT)
2103                 scalar(cBINOPo->op_first);
2104             goto func_ops;
2105         case OP_CONCAT:
2106             if ((o->op_flags & OPf_STACKED) &&
2107                     !(o->op_private & OPpCONCAT_NESTED))
2108                 break;
2109             goto func_ops;
2110         case OP_SUBSTR:
2111             if (o->op_private == 4)
2112                 break;
2113             /* FALLTHROUGH */
2114         case OP_WANTARRAY:
2115         case OP_GV:
2116         case OP_SMARTMATCH:
2117         case OP_AV2ARYLEN:
2118         case OP_REF:
2119         case OP_REFGEN:
2120         case OP_SREFGEN:
2121         case OP_DEFINED:
2122         case OP_HEX:
2123         case OP_OCT:
2124         case OP_LENGTH:
2125         case OP_VEC:
2126         case OP_INDEX:
2127         case OP_RINDEX:
2128         case OP_SPRINTF:
2129         case OP_KVASLICE:
2130         case OP_KVHSLICE:
2131         case OP_UNPACK:
2132         case OP_PACK:
2133         case OP_JOIN:
2134         case OP_LSLICE:
2135         case OP_ANONLIST:
2136         case OP_ANONHASH:
2137         case OP_SORT:
2138         case OP_REVERSE:
2139         case OP_RANGE:
2140         case OP_FLIP:
2141         case OP_FLOP:
2142         case OP_CALLER:
2143         case OP_FILENO:
2144         case OP_EOF:
2145         case OP_TELL:
2146         case OP_GETSOCKNAME:
2147         case OP_GETPEERNAME:
2148         case OP_READLINK:
2149         case OP_TELLDIR:
2150         case OP_GETPPID:
2151         case OP_GETPGRP:
2152         case OP_GETPRIORITY:
2153         case OP_TIME:
2154         case OP_TMS:
2155         case OP_LOCALTIME:
2156         case OP_GMTIME:
2157         case OP_GHBYNAME:
2158         case OP_GHBYADDR:
2159         case OP_GHOSTENT:
2160         case OP_GNBYNAME:
2161         case OP_GNBYADDR:
2162         case OP_GNETENT:
2163         case OP_GPBYNAME:
2164         case OP_GPBYNUMBER:
2165         case OP_GPROTOENT:
2166         case OP_GSBYNAME:
2167         case OP_GSBYPORT:
2168         case OP_GSERVENT:
2169         case OP_GPWNAM:
2170         case OP_GPWUID:
2171         case OP_GGRNAM:
2172         case OP_GGRGID:
2173         case OP_GETLOGIN:
2174         case OP_PROTOTYPE:
2175         case OP_RUNCV:
2176         func_ops:
2177             useless = OP_DESC(o);
2178             break;
2179
2180         case OP_GVSV:
2181         case OP_PADSV:
2182         case OP_PADAV:
2183         case OP_PADHV:
2184         case OP_PADANY:
2185         case OP_AELEM:
2186         case OP_AELEMFAST:
2187         case OP_AELEMFAST_LEX:
2188         case OP_ASLICE:
2189         case OP_HELEM:
2190         case OP_HSLICE:
2191             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
2192                 /* Otherwise it's "Useless use of grep iterator" */
2193                 useless = OP_DESC(o);
2194             break;
2195
2196         case OP_SPLIT:
2197             if (!(o->op_private & OPpSPLIT_ASSIGN))
2198                 useless = OP_DESC(o);
2199             break;
2200
2201         case OP_NOT:
2202             kid = cUNOPo->op_first;
2203             if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2204                 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2205                 goto func_ops;
2206             }
2207             useless = "negative pattern binding (!~)";
2208             break;
2209
2210         case OP_SUBST:
2211             if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2212                 useless = "non-destructive substitution (s///r)";
2213             break;
2214
2215         case OP_TRANSR:
2216             useless = "non-destructive transliteration (tr///r)";
2217             break;
2218
2219         case OP_RV2GV:
2220         case OP_RV2SV:
2221         case OP_RV2AV:
2222         case OP_RV2HV:
2223             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
2224                 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
2225                 useless = "a variable";
2226             break;
2227
2228         case OP_CONST:
2229             sv = cSVOPo_sv;
2230             if (cSVOPo->op_private & OPpCONST_STRICT)
2231                 no_bareword_allowed(o);
2232             else {
2233                 if (ckWARN(WARN_VOID)) {
2234                     NV nv;
2235                     /* don't warn on optimised away booleans, eg
2236                      * use constant Foo, 5; Foo || print; */
2237                     if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2238                         useless = NULL;
2239                     /* the constants 0 and 1 are permitted as they are
2240                        conventionally used as dummies in constructs like
2241                        1 while some_condition_with_side_effects;  */
2242                     else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2243                         useless = NULL;
2244                     else if (SvPOK(sv)) {
2245                         SV * const dsv = newSVpvs("");
2246                         useless_sv
2247                             = Perl_newSVpvf(aTHX_
2248                                             "a constant (%s)",
2249                                             pv_pretty(dsv, SvPVX_const(sv),
2250                                                       SvCUR(sv), 32, NULL, NULL,
2251                                                       PERL_PV_PRETTY_DUMP
2252                                                       | PERL_PV_ESCAPE_NOCLEAR
2253                                                       | PERL_PV_ESCAPE_UNI_DETECT));
2254                         SvREFCNT_dec_NN(dsv);
2255                     }
2256                     else if (SvOK(sv)) {
2257                         useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv));
2258                     }
2259                     else
2260                         useless = "a constant (undef)";
2261                 }
2262             }
2263             op_null(o);         /* don't execute or even remember it */
2264             break;
2265
2266         case OP_POSTINC:
2267             OpTYPE_set(o, OP_PREINC);  /* pre-increment is faster */
2268             break;
2269
2270         case OP_POSTDEC:
2271             OpTYPE_set(o, OP_PREDEC);  /* pre-decrement is faster */
2272             break;
2273
2274         case OP_I_POSTINC:
2275             OpTYPE_set(o, OP_I_PREINC);        /* pre-increment is faster */
2276             break;
2277
2278         case OP_I_POSTDEC:
2279             OpTYPE_set(o, OP_I_PREDEC);        /* pre-decrement is faster */
2280             break;
2281
2282         case OP_SASSIGN: {
2283             OP *rv2gv;
2284             UNOP *refgen, *rv2cv;
2285             LISTOP *exlist;
2286
2287             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2288                 break;
2289
2290             rv2gv = cBINOPo->op_last;
2291             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2292                 break;
2293
2294             refgen = cUNOPx(cBINOPo->op_first);
2295
2296             if (!refgen || (refgen->op_type != OP_REFGEN
2297                             && refgen->op_type != OP_SREFGEN))
2298                 break;
2299
2300             exlist = cLISTOPx(refgen->op_first);
2301             if (!exlist || exlist->op_type != OP_NULL
2302                 || exlist->op_targ != OP_LIST)
2303                 break;
2304
2305             if (exlist->op_first->op_type != OP_PUSHMARK
2306                 && exlist->op_first != exlist->op_last)
2307                 break;
2308
2309             rv2cv = cUNOPx(exlist->op_last);
2310
2311             if (rv2cv->op_type != OP_RV2CV)
2312                 break;
2313
2314             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2315             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2316             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2317
2318             o->op_private |= OPpASSIGN_CV_TO_GV;
2319             rv2gv->op_private |= OPpDONT_INIT_GV;
2320             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2321
2322             break;
2323         }
2324
2325         case OP_AASSIGN: {
2326             inplace_aassign(o);
2327             break;
2328         }
2329
2330         case OP_OR:
2331         case OP_AND:
2332             kid = cLOGOPo->op_first;
2333             if (kid->op_type == OP_NOT
2334                 && (kid->op_flags & OPf_KIDS)) {
2335                 if (o->op_type == OP_AND) {
2336                     OpTYPE_set(o, OP_OR);
2337                 } else {
2338                     OpTYPE_set(o, OP_AND);
2339                 }
2340                 op_null(kid);
2341             }
2342             /* FALLTHROUGH */
2343
2344         case OP_DOR:
2345         case OP_COND_EXPR:
2346         case OP_ENTERGIVEN:
2347         case OP_ENTERWHEN:
2348             next_kid = OpSIBLING(cUNOPo->op_first);
2349         break;
2350
2351         case OP_NULL:
2352             if (o->op_flags & OPf_STACKED)
2353                 break;
2354             /* FALLTHROUGH */
2355         case OP_NEXTSTATE:
2356         case OP_DBSTATE:
2357         case OP_ENTERTRY:
2358         case OP_ENTER:
2359             if (!(o->op_flags & OPf_KIDS))
2360                 break;
2361             /* FALLTHROUGH */
2362         case OP_SCOPE:
2363         case OP_LEAVE:
2364         case OP_LEAVETRY:
2365         case OP_LEAVELOOP:
2366         case OP_LINESEQ:
2367         case OP_LEAVEGIVEN:
2368         case OP_LEAVEWHEN:
2369         kids:
2370             next_kid = cLISTOPo->op_first;
2371             break;
2372         case OP_LIST:
2373             /* If the first kid after pushmark is something that the padrange
2374                optimisation would reject, then null the list and the pushmark.
2375             */
2376             if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2377                 && (  !(kid = OpSIBLING(kid))
2378                       || (  kid->op_type != OP_PADSV
2379                             && kid->op_type != OP_PADAV
2380                             && kid->op_type != OP_PADHV)
2381                       || kid->op_private & ~OPpLVAL_INTRO
2382                       || !(kid = OpSIBLING(kid))
2383                       || (  kid->op_type != OP_PADSV
2384                             && kid->op_type != OP_PADAV
2385                             && kid->op_type != OP_PADHV)
2386                       || kid->op_private & ~OPpLVAL_INTRO)
2387             ) {
2388                 op_null(cUNOPo->op_first); /* NULL the pushmark */
2389                 op_null(o); /* NULL the list */
2390             }
2391             goto kids;
2392         case OP_ENTEREVAL:
2393             scalarkids(o);
2394             break;
2395         case OP_SCALAR:
2396             scalar(o);
2397             break;
2398         }
2399
2400         if (useless_sv) {
2401             /* mortalise it, in case warnings are fatal.  */
2402             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2403                            "Useless use of %" SVf " in void context",
2404                            SVfARG(sv_2mortal(useless_sv)));
2405         }
2406         else if (useless) {
2407             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2408                            "Useless use of %s in void context",
2409                            useless);
2410         }
2411
2412       get_next_op:
2413         /* if a kid hasn't been nominated to process, continue with the
2414          * next sibling, or if no siblings left, go back to the parent's
2415          * siblings and so on
2416          */
2417         while (!next_kid) {
2418             if (o == arg)
2419                 return arg; /* at top; no parents/siblings to try */
2420             if (OpHAS_SIBLING(o))
2421                 next_kid = o->op_sibparent;
2422             else
2423                 o = o->op_sibparent; /*try parent's next sibling */
2424         }
2425         o = next_kid;
2426     }
2427
2428     return arg;
2429 }
2430
2431
2432 static OP *
2433 S_listkids(pTHX_ OP *o)
2434 {
2435     if (o && o->op_flags & OPf_KIDS) {
2436         OP *kid;
2437         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2438             list(kid);
2439     }
2440     return o;
2441 }
2442
2443
2444 /* apply list context to the o subtree */
2445
2446 OP *
2447 Perl_list(pTHX_ OP *o)
2448 {
2449     OP * top_op = o;
2450
2451     while (1) {
2452         OP *next_kid = NULL; /* what op (if any) to process next */
2453
2454         OP *kid;
2455
2456         /* assumes no premature commitment */
2457         if (!o || (o->op_flags & OPf_WANT)
2458              || (PL_parser && PL_parser->error_count)
2459              || o->op_type == OP_RETURN)
2460         {
2461             goto do_next;
2462         }
2463
2464         if ((o->op_private & OPpTARGET_MY)
2465             && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2466         {
2467             goto do_next;                               /* As if inside SASSIGN */
2468         }
2469
2470         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2471
2472         switch (o->op_type) {
2473         case OP_REPEAT:
2474             if (o->op_private & OPpREPEAT_DOLIST
2475              && !(o->op_flags & OPf_STACKED))
2476             {
2477                 list(cBINOPo->op_first);
2478                 kid = cBINOPo->op_last;
2479                 /* optimise away (.....) x 1 */
2480                 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2481                  && SvIVX(kSVOP_sv) == 1)
2482                 {
2483                     op_null(o); /* repeat */
2484                     op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2485                     /* const (rhs): */
2486                     op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2487                 }
2488             }
2489             break;
2490
2491         case OP_OR:
2492         case OP_AND:
2493         case OP_COND_EXPR:
2494             /* impose list context on everything except the condition */
2495             next_kid = OpSIBLING(cUNOPo->op_first);
2496             break;
2497
2498         default:
2499             if (!(o->op_flags & OPf_KIDS))
2500                 break;
2501             /* possibly flatten 1..10 into a constant array */
2502             if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2503                 list(cBINOPo->op_first);
2504                 gen_constant_list(o);
2505                 goto do_next;
2506             }
2507             next_kid = cUNOPo->op_first; /* do all kids */
2508             break;
2509
2510         case OP_LIST:
2511             if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2512                 op_null(cUNOPo->op_first); /* NULL the pushmark */
2513                 op_null(o); /* NULL the list */
2514             }
2515             if (o->op_flags & OPf_KIDS)
2516                 next_kid = cUNOPo->op_first; /* do all kids */
2517             break;
2518
2519         /* the children of these ops are usually a list of statements,
2520          * except the leaves, whose first child is a corresponding enter
2521          */
2522         case OP_SCOPE:
2523         case OP_LINESEQ:
2524             kid = cLISTOPo->op_first;
2525             goto do_kids;
2526         case OP_LEAVE:
2527         case OP_LEAVETRY:
2528             kid = cLISTOPo->op_first;
2529             list(kid);
2530             kid = OpSIBLING(kid);
2531         do_kids:
2532             while (kid) {
2533                 OP *sib = OpSIBLING(kid);
2534                 /* Apply void context to all kids except the last, which
2535                  * is list. E.g.
2536                  *      @a = do { void; void; list }
2537                  * Except that 'when's are always list context, e.g.
2538                  *      @a = do { given(..) {
2539                     *                 when (..) { list }
2540                     *                 when (..) { list }
2541                     *                 ...
2542                     *                }}
2543                     */
2544                 if (!sib) {
2545                     /* tail call optimise calling list() on the last kid */
2546                     next_kid = kid;
2547                     goto do_next;
2548                 }
2549                 else if (kid->op_type == OP_LEAVEWHEN)
2550                     list(kid);
2551                 else
2552                     scalarvoid(kid);
2553                 kid = sib;
2554             }
2555             NOT_REACHED; /* NOTREACHED */
2556             break;
2557
2558         }
2559
2560         /* If next_kid is set, someone in the code above wanted us to process
2561          * that kid and all its remaining siblings.  Otherwise, work our way
2562          * back up the tree */
2563       do_next:
2564         while (!next_kid) {
2565             if (o == top_op)
2566                 return top_op; /* at top; no parents/siblings to try */
2567             if (OpHAS_SIBLING(o))
2568                 next_kid = o->op_sibparent;
2569             else {
2570                 o = o->op_sibparent; /*try parent's next sibling */
2571                 switch (o->op_type) {
2572                 case OP_SCOPE:
2573                 case OP_LINESEQ:
2574                 case OP_LIST:
2575                 case OP_LEAVE:
2576                 case OP_LEAVETRY:
2577                     /* should really restore PL_curcop to its old value, but
2578                      * setting it to PL_compiling is better than do nothing */
2579                     PL_curcop = &PL_compiling;
2580                 }
2581             }
2582
2583
2584         }
2585         o = next_kid;
2586     } /* while */
2587 }
2588
2589 /* apply void context to non-final ops of a sequence */
2590
2591 static OP *
2592 S_voidnonfinal(pTHX_ OP *o)
2593 {
2594     if (o) {
2595         const OPCODE type = o->op_type;
2596
2597         if (type == OP_LINESEQ || type == OP_SCOPE ||
2598             type == OP_LEAVE || type == OP_LEAVETRY)
2599         {
2600             OP *kid = cLISTOPo->op_first, *sib;
2601             if(type == OP_LEAVE) {
2602                 /* Don't put the OP_ENTER in void context */
2603                 assert(kid->op_type == OP_ENTER);
2604                 kid = OpSIBLING(kid);
2605             }
2606             for (; kid; kid = sib) {
2607                 if ((sib = OpSIBLING(kid))
2608                  && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2609                     || (  sib->op_targ != OP_NEXTSTATE
2610                        && sib->op_targ != OP_DBSTATE  )))
2611                 {
2612                     scalarvoid(kid);
2613                 }
2614             }
2615             PL_curcop = &PL_compiling;
2616         }
2617         o->op_flags &= ~OPf_PARENS;
2618         if (PL_hints & HINT_BLOCK_SCOPE)
2619             o->op_flags |= OPf_PARENS;
2620     }
2621     else
2622         o = newOP(OP_STUB, 0);
2623     return o;
2624 }
2625
2626 STATIC OP *
2627 S_modkids(pTHX_ OP *o, I32 type)
2628 {
2629     if (o && o->op_flags & OPf_KIDS) {
2630         OP *kid;
2631         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2632             op_lvalue(kid, type);
2633     }
2634     return o;
2635 }
2636
2637
2638 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2639  * const fields. Also, convert CONST keys to HEK-in-SVs.
2640  * rop    is the op that retrieves the hash;
2641  * key_op is the first key
2642  * real   if false, only check (and possibly croak); don't update op
2643  */
2644
2645 void
2646 Perl_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op, int real)
2647 {
2648     PADNAME *lexname;
2649     GV **fields;
2650     bool check_fields;
2651
2652     /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2653     if (rop) {
2654         if (rop->op_first->op_type == OP_PADSV)
2655             /* @$hash{qw(keys here)} */
2656             rop = cUNOPx(rop->op_first);
2657         else {
2658             /* @{$hash}{qw(keys here)} */
2659             if (rop->op_first->op_type == OP_SCOPE
2660                 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2661                 {
2662                     rop = cUNOPx(cLISTOPx(rop->op_first)->op_last);
2663                 }
2664             else
2665                 rop = NULL;
2666         }
2667     }
2668
2669     lexname = NULL; /* just to silence compiler warnings */
2670     fields  = NULL; /* just to silence compiler warnings */
2671
2672     check_fields =
2673             rop
2674          && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2675              PadnameHasTYPE(lexname))
2676          && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2677          && isGV(*fields) && GvHV(*fields);
2678
2679     for (; key_op; key_op = cSVOPx(OpSIBLING(key_op))) {
2680         SV **svp, *sv;
2681         if (key_op->op_type != OP_CONST)
2682             continue;
2683         svp = cSVOPx_svp(key_op);
2684
2685         /* make sure it's not a bareword under strict subs */
2686         if (key_op->op_private & OPpCONST_BARE &&
2687             key_op->op_private & OPpCONST_STRICT)
2688         {
2689             no_bareword_allowed((OP*)key_op);
2690         }
2691
2692         /* Make the CONST have a shared SV */
2693         if (   !SvIsCOW_shared_hash(sv = *svp)
2694             && SvTYPE(sv) < SVt_PVMG
2695             && SvOK(sv)
2696             && !SvROK(sv)
2697             && real)
2698         {
2699             SSize_t keylen;
2700             const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2701             SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2702             SvREFCNT_dec_NN(sv);
2703             *svp = nsv;
2704         }
2705
2706         if (   check_fields
2707             && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2708         {
2709             Perl_croak(aTHX_ "No such class field \"%" SVf "\" "
2710                         "in variable %" PNf " of type %" HEKf,
2711                         SVfARG(*svp), PNfARG(lexname),
2712                         HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2713         }
2714     }
2715 }
2716
2717
2718 /* do all the final processing on an optree (e.g. running the peephole
2719  * optimiser on it), then attach it to cv (if cv is non-null)
2720  */
2721
2722 static void
2723 S_process_optree(pTHX_ CV *cv, OP *optree, OP* start)
2724 {
2725     OP **startp;
2726
2727     /* XXX for some reason, evals, require and main optrees are
2728      * never attached to their CV; instead they just hang off
2729      * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start
2730      * and get manually freed when appropriate */
2731     if (cv)
2732         startp = &CvSTART(cv);
2733     else
2734         startp = PL_in_eval? &PL_eval_start : &PL_main_start;
2735
2736     *startp = start;
2737     optree->op_private |= OPpREFCOUNTED;
2738     OpREFCNT_set(optree, 1);
2739     optimize_optree(optree);
2740     CALL_PEEP(*startp);
2741     finalize_optree(optree);
2742     op_prune_chain_head(startp);
2743
2744     if (cv) {
2745         /* now that optimizer has done its work, adjust pad values */
2746         pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT
2747                  : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
2748     }
2749 }
2750
2751 #ifdef USE_ITHREADS
2752 /* Relocate sv to the pad for thread safety.
2753  * Despite being a "constant", the SV is written to,
2754  * for reference counts, sv_upgrade() etc. */
2755 void
2756 Perl_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
2757 {
2758     PADOFFSET ix;
2759     PERL_ARGS_ASSERT_OP_RELOCATE_SV;
2760     if (!*svp) return;
2761     ix = pad_alloc(OP_CONST, SVf_READONLY);
2762     SvREFCNT_dec(PAD_SVl(ix));
2763     PAD_SETSV(ix, *svp);
2764     /* XXX I don't know how this isn't readonly already. */
2765     if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
2766     *svp = NULL;
2767     *targp = ix;
2768 }
2769 #endif
2770
2771 static void
2772 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
2773 {
2774     CV *cv = PL_compcv;
2775     PadnameLVALUE_on(pn);
2776     while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
2777         cv = CvOUTSIDE(cv);
2778         /* RT #127786: cv can be NULL due to an eval within the DB package
2779          * called from an anon sub - anon subs don't have CvOUTSIDE() set
2780          * unless they contain an eval, but calling eval within DB
2781          * pretends the eval was done in the caller's scope.
2782          */
2783         if (!cv)
2784             break;
2785         assert(CvPADLIST(cv));
2786         pn =
2787            PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
2788         assert(PadnameLEN(pn));
2789         PadnameLVALUE_on(pn);
2790     }
2791 }
2792
2793 static bool
2794 S_vivifies(const OPCODE type)
2795 {
2796     switch(type) {
2797     case OP_RV2AV:     case   OP_ASLICE:
2798     case OP_RV2HV:     case OP_KVASLICE:
2799     case OP_RV2SV:     case   OP_HSLICE:
2800     case OP_AELEMFAST: case OP_KVHSLICE:
2801     case OP_HELEM:
2802     case OP_AELEM:
2803         return 1;
2804     }
2805     return 0;
2806 }
2807
2808
2809 /* apply lvalue reference (aliasing) context to the optree o.
2810  * E.g. in
2811  *     \($x,$y) = (...)
2812  * o would be the list ($x,$y) and type would be OP_AASSIGN.
2813  * It may descend and apply this to children too, for example in
2814  * \( $cond ? $x, $y) = (...)
2815  */
2816
2817 static void
2818 S_lvref(pTHX_ OP *o, I32 type)
2819 {
2820     OP *kid;
2821     OP * top_op = o;
2822
2823     while (1) {
2824         switch (o->op_type) {
2825         case OP_COND_EXPR:
2826             o = OpSIBLING(cUNOPo->op_first);
2827             continue;
2828
2829         case OP_PUSHMARK:
2830             goto do_next;
2831
2832         case OP_RV2AV:
2833             if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2834             o->op_flags |= OPf_STACKED;
2835             if (o->op_flags & OPf_PARENS) {
2836                 if (o->op_private & OPpLVAL_INTRO) {
2837                      yyerror(Perl_form(aTHX_ "Can't modify reference to "
2838                           "localized parenthesized array in list assignment"));
2839                     goto do_next;
2840                 }
2841               slurpy:
2842                 OpTYPE_set(o, OP_LVAVREF);
2843                 o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
2844                 o->op_flags |= OPf_MOD|OPf_REF;
2845                 goto do_next;
2846             }
2847             o->op_private |= OPpLVREF_AV;
2848             goto checkgv;
2849
2850         case OP_RV2CV:
2851             kid = cUNOPo->op_first;
2852             if (kid->op_type == OP_NULL)
2853                 kid = cUNOPx(OpSIBLING(kUNOP->op_first))
2854                     ->op_first;
2855             o->op_private = OPpLVREF_CV;
2856             if (kid->op_type == OP_GV)
2857                 o->op_flags |= OPf_STACKED;
2858             else if (kid->op_type == OP_PADCV) {
2859                 o->op_targ = kid->op_targ;
2860                 kid->op_targ = 0;
2861                 op_free(cUNOPo->op_first);
2862                 cUNOPo->op_first = NULL;
2863                 o->op_flags &=~ OPf_KIDS;
2864             }
2865             else goto badref;
2866             break;
2867
2868         case OP_RV2HV:
2869             if (o->op_flags & OPf_PARENS) {
2870               parenhash:
2871                 yyerror(Perl_form(aTHX_ "Can't modify reference to "
2872                                      "parenthesized hash in list assignment"));
2873                     goto do_next;
2874             }
2875             o->op_private |= OPpLVREF_HV;
2876             /* FALLTHROUGH */
2877         case OP_RV2SV:
2878           checkgv:
2879             if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2880             o->op_flags |= OPf_STACKED;
2881             break;
2882
2883         case OP_PADHV:
2884             if (o->op_flags & OPf_PARENS) goto parenhash;
2885             o->op_private |= OPpLVREF_HV;
2886             /* FALLTHROUGH */
2887         case OP_PADSV:
2888             PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2889             break;
2890
2891         case OP_PADAV:
2892             PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2893             if (o->op_flags & OPf_PARENS) goto slurpy;
2894             o->op_private |= OPpLVREF_AV;
2895             break;
2896
2897         case OP_AELEM:
2898         case OP_HELEM:
2899             o->op_private |= OPpLVREF_ELEM;
2900             o->op_flags   |= OPf_STACKED;
2901             break;
2902
2903         case OP_ASLICE:
2904         case OP_HSLICE:
2905             OpTYPE_set(o, OP_LVREFSLICE);
2906             o->op_private &= OPpLVAL_INTRO;
2907             goto do_next;
2908
2909         case OP_NULL:
2910             if (o->op_flags & OPf_SPECIAL)              /* do BLOCK */
2911                 goto badref;
2912             else if (!(o->op_flags & OPf_KIDS))
2913                 goto do_next;
2914
2915             /* the code formerly only recursed into the first child of
2916              * a non ex-list OP_NULL. if we ever encounter such a null op with
2917              * more than one child, need to decide whether its ok to process
2918              * *all* its kids or not */
2919             assert(o->op_targ == OP_LIST
2920                     || !(OpHAS_SIBLING(cBINOPo->op_first)));
2921             /* FALLTHROUGH */
2922         case OP_LIST:
2923             o = cLISTOPo->op_first;
2924             continue;
2925
2926         case OP_STUB:
2927             if (o->op_flags & OPf_PARENS)
2928                 goto do_next;
2929             /* FALLTHROUGH */
2930         default:
2931           badref:
2932             /* diag_listed_as: Can't modify reference to %s in %s assignment */
2933             yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
2934                          o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
2935                           ? "do block"
2936                           : OP_DESC(o),
2937                          PL_op_desc[type]));
2938             goto do_next;
2939         }
2940
2941         OpTYPE_set(o, OP_LVREF);
2942         o->op_private &=
2943             OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
2944         if (type == OP_ENTERLOOP)
2945             o->op_private |= OPpLVREF_ITER;
2946
2947       do_next:
2948         while (1) {
2949             if (o == top_op)
2950                 return; /* at top; no parents/siblings to try */
2951             if (OpHAS_SIBLING(o)) {
2952                 o = o->op_sibparent;
2953                 break;
2954             }
2955             o = o->op_sibparent; /*try parent's next sibling */
2956         }
2957     } /* while */
2958 }
2959
2960
2961 PERL_STATIC_INLINE bool
2962 S_potential_mod_type(I32 type)
2963 {
2964     /* Types that only potentially result in modification.  */
2965     return type == OP_GREPSTART || type == OP_ENTERSUB
2966         || type == OP_REFGEN    || type == OP_LEAVESUBLV;
2967 }
2968
2969
2970 /*
2971 =for apidoc op_lvalue
2972
2973 Propagate lvalue ("modifiable") context to an op and its children.
2974 C<type> represents the context type, roughly based on the type of op that
2975 would do the modifying, although C<local()> is represented by C<OP_NULL>,
2976 because it has no op type of its own (it is signalled by a flag on
2977 the lvalue op).
2978
2979 This function detects things that can't be modified, such as C<$x+1>, and
2980 generates errors for them.  For example, C<$x+1 = 2> would cause it to be
2981 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
2982
2983 It also flags things that need to behave specially in an lvalue context,
2984 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
2985
2986 =cut
2987
2988 Perl_op_lvalue_flags() is a non-API lower-level interface to
2989 op_lvalue().  The flags param has these bits:
2990     OP_LVALUE_NO_CROAK:  return rather than croaking on error
2991
2992 */
2993
2994 OP *
2995 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
2996 {
2997     OP *top_op = o;
2998
2999     if (!o || (PL_parser && PL_parser->error_count))
3000         return o;
3001
3002     while (1) {
3003     OP *kid;
3004     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
3005     int localize = -1;
3006     OP *next_kid = NULL;
3007
3008     if ((o->op_private & OPpTARGET_MY)
3009         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
3010     {
3011         goto do_next;
3012     }
3013
3014     /* elements of a list might be in void context because the list is
3015        in scalar context or because they are attribute sub calls */
3016     if ((o->op_flags & OPf_WANT) == OPf_WANT_VOID)
3017         goto do_next;
3018
3019     if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
3020
3021     switch (o->op_type) {
3022     case OP_UNDEF:
3023         if (type == OP_SASSIGN)
3024             goto nomod;
3025         PL_modcount++;
3026         goto do_next;
3027
3028     case OP_STUB:
3029         if ((o->op_flags & OPf_PARENS))
3030             break;
3031         goto nomod;
3032
3033     case OP_ENTERSUB:
3034         if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
3035             !(o->op_flags & OPf_STACKED)) {
3036             OpTYPE_set(o, OP_RV2CV);            /* entersub => rv2cv */
3037             assert(cUNOPo->op_first->op_type == OP_NULL);
3038             op_null(cLISTOPx(cUNOPo->op_first)->op_first);/* disable pushmark */
3039             break;
3040         }
3041         else {                          /* lvalue subroutine call */
3042             o->op_private |= OPpLVAL_INTRO;
3043             PL_modcount = RETURN_UNLIMITED_NUMBER;
3044             if (S_potential_mod_type(type)) {
3045                 o->op_private |= OPpENTERSUB_INARGS;
3046                 break;
3047             }
3048             else {                      /* Compile-time error message: */
3049                 OP *kid = cUNOPo->op_first;
3050                 CV *cv;
3051                 GV *gv;
3052                 SV *namesv;
3053
3054                 if (kid->op_type != OP_PUSHMARK) {
3055                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
3056                         Perl_croak(aTHX_
3057                                 "panic: unexpected lvalue entersub "
3058                                 "args: type/targ %ld:%" UVuf,
3059                                 (long)kid->op_type, (UV)kid->op_targ);
3060                     kid = kLISTOP->op_first;
3061                 }
3062                 while (OpHAS_SIBLING(kid))
3063                     kid = OpSIBLING(kid);
3064                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
3065                     break;      /* Postpone until runtime */
3066                 }
3067
3068                 kid = kUNOP->op_first;
3069                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
3070                     kid = kUNOP->op_first;
3071                 if (kid->op_type == OP_NULL)
3072                     Perl_croak(aTHX_
3073                                "panic: unexpected constant lvalue entersub "
3074                                "entry via type/targ %ld:%" UVuf,
3075                                (long)kid->op_type, (UV)kid->op_targ);
3076                 if (kid->op_type != OP_GV) {
3077                     break;
3078                 }
3079
3080                 gv = kGVOP_gv;
3081                 cv = isGV(gv)
3082                     ? GvCV(gv)
3083                     : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
3084                         ? MUTABLE_CV(SvRV(gv))
3085                         : NULL;
3086                 if (!cv)
3087                     break;
3088                 if (CvLVALUE(cv))
3089                     break;
3090                 if (flags & OP_LVALUE_NO_CROAK)
3091                     return NULL;
3092
3093                 namesv = cv_name(cv, NULL, 0);
3094                 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
3095                                      "subroutine call of &%" SVf " in %s",
3096                                      SVfARG(namesv), PL_op_desc[type]),
3097                            SvUTF8(namesv));
3098                 goto do_next;
3099             }
3100         }
3101         /* FALLTHROUGH */
3102     default:
3103       nomod:
3104         if (flags & OP_LVALUE_NO_CROAK) return NULL;
3105         /* grep, foreach, subcalls, refgen */
3106         if (S_potential_mod_type(type))
3107             break;
3108         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
3109                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
3110                       ? "do block"
3111                       : OP_DESC(o)),
3112                      type ? PL_op_desc[type] : "local"));
3113         goto do_next;
3114
3115     case OP_PREINC:
3116     case OP_PREDEC:
3117     case OP_POW:
3118     case OP_MULTIPLY:
3119     case OP_DIVIDE:
3120     case OP_MODULO:
3121     case OP_ADD:
3122     case OP_SUBTRACT:
3123     case OP_CONCAT:
3124     case OP_LEFT_SHIFT:
3125     case OP_RIGHT_SHIFT:
3126     case OP_BIT_AND:
3127     case OP_BIT_XOR:
3128     case OP_BIT_OR:
3129     case OP_I_MULTIPLY:
3130     case OP_I_DIVIDE:
3131     case OP_I_MODULO:
3132     case OP_I_ADD:
3133     case OP_I_SUBTRACT:
3134         if (!(o->op_flags & OPf_STACKED))
3135             goto nomod;
3136         PL_modcount++;
3137         break;
3138
3139     case OP_REPEAT:
3140         if (o->op_flags & OPf_STACKED) {
3141             PL_modcount++;
3142             break;
3143         }
3144         if (!(o->op_private & OPpREPEAT_DOLIST))
3145             goto nomod;
3146         else {
3147             const I32 mods = PL_modcount;
3148             /* we recurse rather than iterate here because we need to
3149              * calculate and use the delta applied to PL_modcount by the
3150              * first child. So in something like
3151              *     ($x, ($y) x 3) = split;
3152              * split knows that 4 elements are wanted
3153              */
3154             modkids(cBINOPo->op_first, type);
3155             if (type != OP_AASSIGN)
3156                 goto nomod;
3157             kid = cBINOPo->op_last;
3158             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
3159                 const IV iv = SvIV(kSVOP_sv);
3160                 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
3161                     PL_modcount =
3162                         mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
3163             }
3164             else
3165                 PL_modcount = RETURN_UNLIMITED_NUMBER;
3166         }
3167         break;
3168
3169     case OP_COND_EXPR:
3170         localize = 1;
3171         next_kid = OpSIBLING(cUNOPo->op_first);
3172         break;
3173
3174     case OP_RV2AV:
3175     case OP_RV2HV:
3176         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
3177            PL_modcount = RETURN_UNLIMITED_NUMBER;
3178            /* Treat \(@foo) like ordinary list, but still mark it as modi-
3179               fiable since some contexts need to know.  */
3180            o->op_flags |= OPf_MOD;
3181            goto do_next;
3182         }
3183         /* FALLTHROUGH */
3184     case OP_RV2GV:
3185         if (scalar_mod_type(o, type))
3186             goto nomod;
3187         ref(cUNOPo->op_first, o->op_type);
3188         /* FALLTHROUGH */
3189     case OP_ASLICE:
3190     case OP_HSLICE:
3191         localize = 1;
3192         /* FALLTHROUGH */
3193     case OP_AASSIGN:
3194         /* Do not apply the lvsub flag for rv2[ah]v in scalar context.  */
3195         if (type == OP_LEAVESUBLV && (
3196                 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
3197              || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
3198            ))
3199             o->op_private |= OPpMAYBE_LVSUB;
3200         /* FALLTHROUGH */
3201     case OP_NEXTSTATE:
3202     case OP_DBSTATE:
3203        PL_modcount = RETURN_UNLIMITED_NUMBER;
3204         break;
3205
3206     case OP_KVHSLICE:
3207     case OP_KVASLICE:
3208     case OP_AKEYS:
3209         if (type == OP_LEAVESUBLV)
3210             o->op_private |= OPpMAYBE_LVSUB;
3211         goto nomod;
3212
3213     case OP_AVHVSWITCH:
3214         if (type == OP_LEAVESUBLV
3215          && (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS)
3216             o->op_private |= OPpMAYBE_LVSUB;
3217         goto nomod;
3218
3219     case OP_AV2ARYLEN:
3220         PL_hints |= HINT_BLOCK_SCOPE;
3221         if (type == OP_LEAVESUBLV)
3222             o->op_private |= OPpMAYBE_LVSUB;
3223         PL_modcount++;
3224         break;
3225
3226     case OP_RV2SV:
3227         ref(cUNOPo->op_first, o->op_type);
3228         localize = 1;
3229         /* FALLTHROUGH */
3230     case OP_GV:
3231         PL_hints |= HINT_BLOCK_SCOPE;
3232         /* FALLTHROUGH */
3233     case OP_SASSIGN:
3234     case OP_ANDASSIGN:
3235     case OP_ORASSIGN:
3236     case OP_DORASSIGN:
3237         PL_modcount++;
3238         break;
3239
3240     case OP_AELEMFAST:
3241     case OP_AELEMFAST_LEX:
3242         localize = -1;
3243         PL_modcount++;
3244         break;
3245
3246     case OP_PADAV:
3247     case OP_PADHV:
3248        PL_modcount = RETURN_UNLIMITED_NUMBER;
3249         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
3250         {
3251            /* Treat \(@foo) like ordinary list, but still mark it as modi-
3252               fiable since some contexts need to know.  */
3253             o->op_flags |= OPf_MOD;
3254             goto do_next;
3255         }
3256         if (scalar_mod_type(o, type))
3257             goto nomod;
3258         if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
3259           && type == OP_LEAVESUBLV)
3260             o->op_private |= OPpMAYBE_LVSUB;
3261         /* FALLTHROUGH */
3262     case OP_PADSV:
3263         PL_modcount++;
3264         if (!type) /* local() */
3265             Perl_croak(aTHX_ "Can't localize lexical variable %" PNf,
3266                               PNfARG(PAD_COMPNAME(o->op_targ)));
3267         if (!(o->op_private & OPpLVAL_INTRO)
3268          || (  type != OP_SASSIGN && type != OP_AASSIGN
3269             && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ))  ))
3270             S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
3271         break;
3272
3273     case OP_PUSHMARK:
3274         localize = 0;
3275         break;
3276
3277     case OP_KEYS:
3278         if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
3279             goto nomod;
3280         goto lvalue_func;
3281     case OP_SUBSTR:
3282         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
3283             goto nomod;
3284         /* FALLTHROUGH */
3285     case OP_POS:
3286     case OP_VEC:
3287       lvalue_func:
3288         if (type == OP_LEAVESUBLV)
3289             o->op_private |= OPpMAYBE_LVSUB;
3290         if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
3291             /* we recurse rather than iterate here because the child
3292              * needs to be processed with a different 'type' parameter */
3293
3294             /* substr and vec */
3295             /* If this op is in merely potential (non-fatal) modifiable
3296                context, then apply OP_ENTERSUB context to
3297                the kid op (to avoid croaking).  Other-
3298                wise pass this op’s own type so the correct op is mentioned
3299                in error messages.  */
3300             op_lvalue(OpSIBLING(cBINOPo->op_first),
3301                       S_potential_mod_type(type)
3302                         ? (I32)OP_ENTERSUB
3303                         : o->op_type);
3304         }
3305         break;
3306
3307     case OP_AELEM:
3308     case OP_HELEM:
3309         ref(cBINOPo->op_first, o->op_type);
3310         if (type == OP_ENTERSUB &&
3311              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
3312             o->op_private |= OPpLVAL_DEFER;
3313         if (type == OP_LEAVESUBLV)
3314             o->op_private |= OPpMAYBE_LVSUB;
3315         localize = 1;
3316         PL_modcount++;
3317         break;
3318
3319     case OP_LEAVE:
3320     case OP_LEAVELOOP:
3321         o->op_private |= OPpLVALUE;
3322         /* FALLTHROUGH */
3323     case OP_SCOPE:
3324     case OP_ENTER:
3325     case OP_LINESEQ:
3326         localize = 0;
3327         if (o->op_flags & OPf_KIDS)
3328             next_kid = cLISTOPo->op_last;
3329         break;
3330
3331     case OP_NULL:
3332         localize = 0;
3333         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
3334             goto nomod;
3335         else if (!(o->op_flags & OPf_KIDS))
3336             break;
3337
3338         if (o->op_targ != OP_LIST) {
3339             OP *sib = OpSIBLING(cLISTOPo->op_first);
3340             /* OP_TRANS and OP_TRANSR with argument have a weird optree
3341              * that looks like
3342              *
3343              *   null
3344              *      arg
3345              *      trans
3346              *
3347              * compared with things like OP_MATCH which have the argument
3348              * as a child:
3349              *
3350              *   match
3351              *      arg
3352              *
3353              * so handle specially to correctly get "Can't modify" croaks etc
3354              */
3355
3356             if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR))
3357             {
3358                 /* this should trigger a "Can't modify transliteration" err */
3359                 op_lvalue(sib, type);
3360             }
3361             next_kid = cBINOPo->op_first;
3362             /* we assume OP_NULLs which aren't ex-list have no more than 2
3363              * children. If this assumption is wrong, increase the scan
3364              * limit below */
3365             assert(   !OpHAS_SIBLING(next_kid)
3366                    || !OpHAS_SIBLING(OpSIBLING(next_kid)));
3367             break;
3368         }
3369         /* FALLTHROUGH */
3370     case OP_LIST:
3371         localize = 0;
3372         next_kid = cLISTOPo->op_first;
3373         break;
3374
3375     case OP_COREARGS:
3376         goto do_next;
3377
3378     case OP_AND:
3379     case OP_OR:
3380         if (type == OP_LEAVESUBLV
3381          || !S_vivifies(cLOGOPo->op_first->op_type))
3382             next_kid = cLOGOPo->op_first;
3383         else if (type == OP_LEAVESUBLV
3384          || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
3385             next_kid = OpSIBLING(cLOGOPo->op_first);
3386         goto nomod;
3387
3388     case OP_SREFGEN:
3389         if (type == OP_NULL) { /* local */
3390           local_refgen:
3391             if (!FEATURE_MYREF_IS_ENABLED)
3392                 Perl_croak(aTHX_ "The experimental declared_refs "
3393                                  "feature is not enabled");
3394             Perl_ck_warner_d(aTHX_
3395                      packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
3396                     "Declaring references is experimental");
3397             next_kid = cUNOPo->op_first;
3398             goto do_next;
3399         }
3400         if (type != OP_AASSIGN && type != OP_SASSIGN
3401          && type != OP_ENTERLOOP)
3402             goto nomod;
3403         /* Don’t bother applying lvalue context to the ex-list.  */
3404         kid = cUNOPx(cUNOPo->op_first)->op_first;
3405         assert (!OpHAS_SIBLING(kid));
3406         goto kid_2lvref;
3407     case OP_REFGEN:
3408         if (type == OP_NULL) /* local */
3409             goto local_refgen;
3410         if (type != OP_AASSIGN) goto nomod;
3411         kid = cUNOPo->op_first;
3412       kid_2lvref:
3413         {
3414             const U8 ec = PL_parser ? PL_parser->error_count : 0;
3415             S_lvref(aTHX_ kid, type);
3416             if (!PL_parser || PL_parser->error_count == ec) {
3417                 if (!FEATURE_REFALIASING_IS_ENABLED)
3418                     Perl_croak(aTHX_
3419                        "Experimental aliasing via reference not enabled");
3420                 Perl_ck_warner_d(aTHX_
3421                                  packWARN(WARN_EXPERIMENTAL__REFALIASING),
3422                                 "Aliasing via reference is experimental");
3423             }
3424         }
3425         if (o->op_type == OP_REFGEN)
3426             op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
3427         op_null(o);
3428         goto do_next;
3429
3430     case OP_SPLIT:
3431         if ((o->op_private & OPpSPLIT_ASSIGN)) {
3432             /* This is actually @array = split.  */
3433             PL_modcount = RETURN_UNLIMITED_NUMBER;
3434             break;
3435         }
3436         goto nomod;
3437
3438     case OP_SCALAR:
3439         op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
3440         goto nomod;
3441     }
3442
3443     /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
3444        their argument is a filehandle; thus \stat(".") should not set
3445        it. AMS 20011102 */
3446     if (type == OP_REFGEN && OP_IS_STAT(o->op_type))
3447         goto do_next;
3448
3449     if (type != OP_LEAVESUBLV)
3450         o->op_flags |= OPf_MOD;
3451
3452     if (type == OP_AASSIGN || type == OP_SASSIGN)
3453         o->op_flags |= o->op_type == OP_ENTERSUB ? 0 : OPf_SPECIAL|OPf_REF;
3454     else if (!type) { /* local() */
3455         switch (localize) {
3456         case 1:
3457             o->op_private |= OPpLVAL_INTRO;
3458             o->op_flags &= ~OPf_SPECIAL;
3459             PL_hints |= HINT_BLOCK_SCOPE;
3460             break;
3461         case 0:
3462             break;
3463         case -1:
3464             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
3465                            "Useless localization of %s", OP_DESC(o));
3466         }
3467     }
3468     else if (type != OP_GREPSTART && type != OP_ENTERSUB
3469              && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
3470         o->op_flags |= OPf_REF;
3471
3472   do_next:
3473     while (!next_kid) {
3474         if (o == top_op)
3475             return top_op; /* at top; no parents/siblings to try */
3476         if (OpHAS_SIBLING(o)) {
3477             next_kid = o->op_sibparent;
3478             if (!OpHAS_SIBLING(next_kid)) {
3479                 /* a few node types don't recurse into their second child */
3480                 OP *parent = next_kid->op_sibparent;
3481                 I32 ptype  = parent->op_type;
3482                 if (   (ptype == OP_NULL && parent->op_targ != OP_LIST)
3483                     || (   (ptype == OP_AND || ptype == OP_OR)
3484                         && (type != OP_LEAVESUBLV
3485                             && S_vivifies(next_kid->op_type))
3486                        )
3487                 )  {
3488                     /*try parent's next sibling */
3489                     o = parent;
3490                     next_kid =  NULL;
3491                 }
3492             }
3493         }
3494         else
3495             o = o->op_sibparent; /*try parent's next sibling */
3496
3497     }
3498     o = next_kid;
3499
3500     } /* while */
3501
3502 }
3503
3504
3505 STATIC bool
3506 S_scalar_mod_type(const OP *o, I32 type)
3507 {
3508     switch (type) {
3509     case OP_POS:
3510     case OP_SASSIGN:
3511         if (o && o->op_type == OP_RV2GV)
3512             return FALSE;
3513         /* FALLTHROUGH */
3514     case OP_PREINC:
3515     case OP_PREDEC:
3516     case OP_POSTINC:
3517     case OP_POSTDEC:
3518     case OP_I_PREINC:
3519     case OP_I_PREDEC:
3520     case OP_I_POSTINC:
3521     case OP_I_POSTDEC:
3522     case OP_POW:
3523     case OP_MULTIPLY:
3524     case OP_DIVIDE:
3525     case OP_MODULO:
3526     case OP_REPEAT:
3527     case OP_ADD:
3528     case OP_SUBTRACT:
3529     case OP_I_MULTIPLY:
3530     case OP_I_DIVIDE:
3531     case OP_I_MODULO:
3532     case OP_I_ADD:
3533     case OP_I_SUBTRACT:
3534     case OP_LEFT_SHIFT:
3535     case OP_RIGHT_SHIFT:
3536     case OP_BIT_AND:
3537     case OP_BIT_XOR:
3538     case OP_BIT_OR:
3539     case OP_NBIT_AND:
3540     case OP_NBIT_XOR:
3541     case OP_NBIT_OR:
3542     case OP_SBIT_AND:
3543     case OP_SBIT_XOR:
3544     case OP_SBIT_OR:
3545     case OP_CONCAT:
3546     case OP_SUBST:
3547     case OP_TRANS:
3548     case OP_TRANSR:
3549     case OP_READ:
3550     case OP_SYSREAD:
3551     case OP_RECV:
3552     case OP_ANDASSIGN:
3553     case OP_ORASSIGN:
3554     case OP_DORASSIGN:
3555     case OP_VEC:
3556     case OP_SUBSTR:
3557         return TRUE;
3558     default:
3559         return FALSE;
3560     }
3561 }
3562
3563 STATIC bool
3564 S_is_handle_constructor(const OP *o, I32 numargs)
3565 {
3566     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
3567
3568     switch (o->op_type) {
3569     case OP_PIPE_OP:
3570     case OP_SOCKPAIR:
3571         if (numargs == 2)
3572             return TRUE;
3573         /* FALLTHROUGH */
3574     case OP_SYSOPEN:
3575     case OP_OPEN:
3576     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
3577     case OP_SOCKET:
3578     case OP_OPEN_DIR:
3579     case OP_ACCEPT:
3580         if (numargs == 1)
3581             return TRUE;
3582         /* FALLTHROUGH */
3583     default:
3584         return FALSE;
3585     }
3586 }
3587
3588 static OP *
3589 S_refkids(pTHX_ OP *o, I32 type)
3590 {
3591     if (o && o->op_flags & OPf_KIDS) {
3592         OP *kid;
3593         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3594             ref(kid, type);
3595     }
3596     return o;
3597 }
3598
3599
3600 /* Apply reference (autovivification) context to the subtree at o.
3601  * For example in
3602  *     push @{expression}, ....;
3603  * o will be the head of 'expression' and type will be OP_RV2AV.
3604  * It marks the op o (or a suitable child) as autovivifying, e.g. by
3605  * setting  OPf_MOD.
3606  * For OP_RV2AV/OP_PADAV and OP_RV2HV/OP_PADHV sets OPf_REF too if
3607  * set_op_ref is true.
3608  *
3609  * Also calls scalar(o).
3610  */
3611
3612 OP *
3613 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
3614 {
3615     OP * top_op = o;
3616
3617     PERL_ARGS_ASSERT_DOREF;
3618
3619     if (PL_parser && PL_parser->error_count)
3620         return o;
3621
3622     while (1) {
3623         switch (o->op_type) {
3624         case OP_ENTERSUB:
3625             if ((type == OP_EXISTS || type == OP_DEFINED) &&
3626                 !(o->op_flags & OPf_STACKED)) {
3627                 OpTYPE_set(o, OP_RV2CV);             /* entersub => rv2cv */
3628                 assert(cUNOPo->op_first->op_type == OP_NULL);
3629                 /* disable pushmark */
3630                 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
3631                 o->op_flags |= OPf_SPECIAL;
3632             }
3633             else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
3634                 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3635                                   : type == OP_RV2HV ? OPpDEREF_HV
3636                                   : OPpDEREF_SV);
3637                 o->op_flags |= OPf_MOD;
3638             }
3639
3640             break;
3641
3642         case OP_COND_EXPR:
3643             o = OpSIBLING(cUNOPo->op_first);
3644             continue;
3645
3646         case OP_RV2SV:
3647             if (type == OP_DEFINED)
3648                 o->op_flags |= OPf_SPECIAL;             /* don't create GV */
3649             /* FALLTHROUGH */
3650         case OP_PADSV:
3651             if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3652                 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3653                                   : type == OP_RV2HV ? OPpDEREF_HV
3654                                   : OPpDEREF_SV);
3655                 o->op_flags |= OPf_MOD;
3656             }
3657             if (o->op_flags & OPf_KIDS) {
3658                 type = o->op_type;
3659                 o = cUNOPo->op_first;
3660                 continue;
3661             }
3662             break;
3663
3664         case OP_RV2AV:
3665         case OP_RV2HV:
3666             if (set_op_ref)
3667                 o->op_flags |= OPf_REF;
3668             /* FALLTHROUGH */
3669         case OP_RV2GV:
3670             if (type == OP_DEFINED)
3671                 o->op_flags |= OPf_SPECIAL;             /* don't create GV */
3672             type = o->op_type;
3673             o = cUNOPo->op_first;
3674             continue;
3675
3676         case OP_PADAV:
3677         case OP_PADHV:
3678             if (set_op_ref)
3679                 o->op_flags |= OPf_REF;
3680             break;
3681
3682         case OP_SCALAR:
3683         case OP_NULL:
3684             if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
3685                 break;
3686              o = cBINOPo->op_first;
3687             continue;
3688
3689         case OP_AELEM:
3690         case OP_HELEM:
3691             if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3692                 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3693                                   : type == OP_RV2HV ? OPpDEREF_HV
3694                                   : OPpDEREF_SV);
3695                 o->op_flags |= OPf_MOD;
3696             }
3697             type = o->op_type;
3698             o = cBINOPo->op_first;
3699             continue;;
3700
3701         case OP_SCOPE:
3702         case OP_LEAVE:
3703             set_op_ref = FALSE;
3704             /* FALLTHROUGH */
3705         case OP_ENTER:
3706         case OP_LIST:
3707             if (!(o->op_flags & OPf_KIDS))
3708                 break;
3709             o = cLISTOPo->op_last;
3710             continue;
3711
3712         default:
3713             break;
3714         } /* switch */
3715
3716         while (1) {
3717             if (o == top_op)
3718                 return scalar(top_op); /* at top; no parents/siblings to try */
3719             if (OpHAS_SIBLING(o)) {
3720                 o = o->op_sibparent;
3721                 /* Normally skip all siblings and go straight to the parent;
3722                  * the only op that requires two children to be processed
3723                  * is OP_COND_EXPR */
3724                 if (!OpHAS_SIBLING(o)
3725                         && o->op_sibparent->op_type == OP_COND_EXPR)
3726                     break;
3727                 continue;
3728             }
3729             o = o->op_sibparent; /*try parent's next sibling */
3730         }
3731     } /* while */
3732 }
3733
3734
3735 STATIC OP *
3736 S_dup_attrlist(pTHX_ OP *o)
3737 {
3738     OP *rop;
3739
3740     PERL_ARGS_ASSERT_DUP_ATTRLIST;
3741
3742     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
3743      * where the first kid is OP_PUSHMARK and the remaining ones
3744      * are OP_CONST.  We need to push the OP_CONST values.
3745      */
3746     if (o->op_type == OP_CONST)
3747         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
3748     else {
3749         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
3750         rop = NULL;
3751         for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
3752             if (o->op_type == OP_CONST)
3753                 rop = op_append_elem(OP_LIST, rop,
3754                                   newSVOP(OP_CONST, o->op_flags,
3755                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
3756         }
3757     }
3758     return rop;
3759 }
3760
3761 STATIC void
3762 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
3763 {
3764     PERL_ARGS_ASSERT_APPLY_ATTRS;
3765     {
3766         SV * const stashsv = newSVhek(HvNAME_HEK(stash));
3767
3768         /* fake up C<use attributes $pkg,$rv,@attrs> */
3769
3770 #define ATTRSMODULE "attributes"
3771 #define ATTRSMODULE_PM "attributes.pm"
3772
3773         Perl_load_module(
3774           aTHX_ PERL_LOADMOD_IMPORT_OPS,
3775           newSVpvs(ATTRSMODULE),
3776           NULL,
3777           op_prepend_elem(OP_LIST,
3778                           newSVOP(OP_CONST, 0, stashsv),
3779                           op_prepend_elem(OP_LIST,
3780                                           newSVOP(OP_CONST, 0,
3781                                                   newRV(target)),
3782                                           dup_attrlist(attrs))));
3783     }
3784 }
3785
3786 STATIC void
3787 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
3788 {
3789     OP *pack, *imop, *arg;
3790     SV *meth, *stashsv, **svp;
3791
3792     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
3793
3794     if (!attrs)
3795         return;
3796
3797     assert(target->op_type == OP_PADSV ||
3798            target->op_type == OP_PADHV ||
3799            target->op_type == OP_PADAV);
3800
3801     /* Ensure that attributes.pm is loaded. */
3802     /* Don't force the C<use> if we don't need it. */
3803     svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
3804     if (svp && *svp != &PL_sv_undef)
3805         NOOP;   /* already in %INC */
3806     else
3807         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
3808                                newSVpvs(ATTRSMODULE), NULL);
3809
3810     /* Need package name for method call. */
3811     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
3812
3813     /* Build up the real arg-list. */
3814     stashsv = newSVhek(HvNAME_HEK(stash));
3815
3816     arg = newOP(OP_PADSV, 0);
3817     arg->op_targ = target->op_targ;
3818     arg = op_prepend_elem(OP_LIST,
3819                        newSVOP(OP_CONST, 0, stashsv),
3820                        op_prepend_elem(OP_LIST,
3821                                     newUNOP(OP_REFGEN, 0,
3822                                             arg),
3823                                     dup_attrlist(attrs)));
3824
3825     /* Fake up a method call to import */
3826     meth = newSVpvs_share("import");
3827     imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_WANT_VOID,
3828                    op_append_elem(OP_LIST,
3829                                op_prepend_elem(OP_LIST, pack, arg),
3830                                newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
3831
3832     /* Combine the ops. */
3833     *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
3834 }
3835
3836 /*
3837 =notfor apidoc apply_attrs_string
3838
3839 Attempts to apply a list of attributes specified by the C<attrstr> and
3840 C<len> arguments to the subroutine identified by the C<cv> argument which
3841 is expected to be associated with the package identified by the C<stashpv>
3842 argument (see L<attributes>).  It gets this wrong, though, in that it
3843 does not correctly identify the boundaries of the individual attribute
3844 specifications within C<attrstr>.  This is not really intended for the
3845 public API, but has to be listed here for systems such as AIX which
3846 need an explicit export list for symbols.  (It's called from XS code
3847 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
3848 to respect attribute syntax properly would be welcome.
3849
3850 =cut
3851 */
3852
3853 void
3854 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
3855                         const char *attrstr, STRLEN len)
3856 {
3857     OP *attrs = NULL;
3858
3859     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
3860
3861     if (!len) {
3862         len = strlen(attrstr);
3863     }
3864
3865     while (len) {
3866         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
3867         if (len) {
3868             const char * const sstr = attrstr;
3869             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
3870             attrs = op_append_elem(OP_LIST, attrs,
3871                                 newSVOP(OP_CONST, 0,
3872                                         newSVpvn(sstr, attrstr-sstr)));
3873         }
3874     }
3875
3876     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3877                      newSVpvs(ATTRSMODULE),
3878                      NULL, op_prepend_elem(OP_LIST,
3879                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
3880                                   op_prepend_elem(OP_LIST,
3881                                                newSVOP(OP_CONST, 0,
3882                                                        newRV(MUTABLE_SV(cv))),
3883                                                attrs)));
3884 }
3885
3886 STATIC void
3887 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name,
3888                         bool curstash)
3889 {
3890     OP *new_proto = NULL;
3891     STRLEN pvlen;
3892     char *pv;
3893     OP *o;
3894
3895     PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
3896
3897     if (!*attrs)
3898         return;
3899
3900     o = *attrs;
3901     if (o->op_type == OP_CONST) {
3902         pv = SvPV(cSVOPo_sv, pvlen);
3903         if (memBEGINs(pv, pvlen, "prototype(")) {
3904             SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3905             SV ** const tmpo = cSVOPx_svp(o);
3906             SvREFCNT_dec(cSVOPo_sv);
3907             *tmpo = tmpsv;
3908             new_proto = o;
3909             *attrs = NULL;
3910         }
3911     } else if (o->op_type == OP_LIST) {
3912         OP * lasto;
3913         assert(o->op_flags & OPf_KIDS);
3914         lasto = cLISTOPo->op_first;
3915         assert(lasto->op_type == OP_PUSHMARK);
3916         for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
3917             if (o->op_type == OP_CONST) {
3918                 pv = SvPV(cSVOPo_sv, pvlen);
3919                 if (memBEGINs(pv, pvlen, "prototype(")) {
3920                     SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3921                     SV ** const tmpo = cSVOPx_svp(o);
3922                     SvREFCNT_dec(cSVOPo_sv);
3923                     *tmpo = tmpsv;
3924                     if (new_proto && ckWARN(WARN_MISC)) {
3925                         STRLEN new_len;
3926                         const char * newp = SvPV(cSVOPo_sv, new_len);
3927                         Perl_warner(aTHX_ packWARN(WARN_MISC),
3928                             "Attribute prototype(%" UTF8f ") discards earlier prototype attribute in same sub",
3929                             UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
3930                         op_free(new_proto);
3931                     }
3932                     else if (new_proto)
3933                         op_free(new_proto);
3934                     new_proto = o;
3935                     /* excise new_proto from the list */
3936                     op_sibling_splice(*attrs, lasto, 1, NULL);
3937                     o = lasto;
3938                     continue;
3939                 }
3940             }
3941             lasto = o;
3942         }
3943         /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
3944            would get pulled in with no real need */
3945         if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
3946             op_free(*attrs);
3947             *attrs = NULL;
3948         }
3949     }
3950
3951     if (new_proto) {
3952         SV *svname;
3953         if (isGV(name)) {
3954             svname = sv_newmortal();
3955             gv_efullname3(svname, name, NULL);
3956         }
3957         else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
3958             svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
3959         else
3960             svname = (SV *)name;
3961         if (ckWARN(WARN_ILLEGALPROTO))
3962             (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE,
3963                                  curstash);
3964         if (*proto && ckWARN(WARN_PROTOTYPE)) {
3965             STRLEN old_len, new_len;
3966             const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
3967             const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
3968
3969             if (curstash && svname == (SV *)name
3970              && !memchr(SvPVX(svname), ':', SvCUR(svname))) {
3971                 svname = sv_2mortal(newSVsv(PL_curstname));
3972                 sv_catpvs(svname, "::");
3973                 sv_catsv(svname, (SV *)name);
3974             }
3975
3976             Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3977                 "Prototype '%" UTF8f "' overridden by attribute 'prototype(%" UTF8f ")'"
3978                 " in %" SVf,
3979                 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
3980                 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
3981                 SVfARG(svname));
3982         }
3983         if (*proto)
3984             op_free(*proto);
3985         *proto = new_proto;
3986     }
3987 }
3988
3989 static void
3990 S_cant_declare(pTHX_ OP *o)
3991 {
3992     if (o->op_type == OP_NULL
3993      && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
3994         o = cUNOPo->op_first;
3995     yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
3996                              o->op_type == OP_NULL
3997                                && o->op_flags & OPf_SPECIAL
3998                                  ? "do block"
3999                                  : OP_DESC(o),
4000                              PL_parser->in_my == KEY_our   ? "our"   :
4001                              PL_parser->in_my == KEY_state ? "state" :
4002                                                              "my"));
4003 }
4004
4005 STATIC OP *
4006 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
4007 {
4008     I32 type;
4009     const bool stately = PL_parser && PL_parser->in_my == KEY_state;
4010
4011     PERL_ARGS_ASSERT_MY_KID;
4012
4013     if (!o || (PL_parser && PL_parser->error_count))
4014         return o;
4015
4016     type = o->op_type;
4017
4018     if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
4019         OP *kid;
4020         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4021             my_kid(kid, attrs, imopsp);
4022         return o;
4023     } else if (type == OP_UNDEF || type == OP_STUB) {
4024         return o;
4025     } else if (type == OP_RV2SV ||      /* "our" declaration */
4026                type == OP_RV2AV ||
4027                type == OP_RV2HV) {
4028         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
4029             S_cant_declare(aTHX_ o);
4030         } else if (attrs) {
4031             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
4032             assert(PL_parser);
4033             PL_parser->in_my = FALSE;
4034             PL_parser->in_my_stash = NULL;
4035             apply_attrs(GvSTASH(gv),
4036                         (type == OP_RV2SV ? GvSVn(gv) :
4037                          type == OP_RV2AV ? MUTABLE_SV(GvAVn(gv)) :
4038                          type == OP_RV2HV ? MUTABLE_SV(GvHVn(gv)) : MUTABLE_SV(gv)),
4039                         attrs);
4040         }
4041         o->op_private |= OPpOUR_INTRO;
4042         return o;
4043     }
4044     else if (type == OP_REFGEN || type == OP_SREFGEN) {
4045         if (!FEATURE_MYREF_IS_ENABLED)
4046             Perl_croak(aTHX_ "The experimental declared_refs "
4047                              "feature is not enabled");
4048         Perl_ck_warner_d(aTHX_
4049              packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4050             "Declaring references is experimental");
4051         /* Kid is a nulled OP_LIST, handled above.  */
4052         my_kid(cUNOPo->op_first, attrs, imopsp);
4053         return o;
4054     }
4055     else if (type != OP_PADSV &&
4056              type != OP_PADAV &&
4057              type != OP_PADHV &&
4058              type != OP_PUSHMARK)
4059     {
4060         S_cant_declare(aTHX_ o);
4061         return o;
4062     }
4063     else if (attrs && type != OP_PUSHMARK) {
4064         HV *stash;
4065
4066         assert(PL_parser);
4067         PL_parser->in_my = FALSE;
4068         PL_parser->in_my_stash = NULL;
4069
4070         /* check for C<my Dog $spot> when deciding package */
4071         stash = PAD_COMPNAME_TYPE(o->op_targ);
4072         if (!stash)
4073             stash = PL_curstash;
4074         apply_attrs_my(stash, o, attrs, imopsp);
4075     }
4076     o->op_flags |= OPf_MOD;
4077     o->op_private |= OPpLVAL_INTRO;
4078     if (stately)
4079         o->op_private |= OPpPAD_STATE;
4080     return o;
4081 }
4082
4083 OP *
4084 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
4085 {
4086     OP *rops;
4087     int maybe_scalar = 0;
4088
4089     PERL_ARGS_ASSERT_MY_ATTRS;
4090
4091 /* [perl #17376]: this appears to be premature, and results in code such as
4092    C< our(%x); > executing in list mode rather than void mode */
4093 #if 0
4094     if (o->op_flags & OPf_PARENS)
4095         list(o);
4096     else
4097         maybe_scalar = 1;
4098 #else
4099     maybe_scalar = 1;
4100 #endif
4101     if (attrs)
4102         SAVEFREEOP(attrs);
4103     rops = NULL;
4104     o = my_kid(o, attrs, &rops);
4105     if (rops) {
4106         if (maybe_scalar && o->op_type == OP_PADSV) {
4107             o = scalar(op_append_list(OP_LIST, rops, o));
4108             o->op_private |= OPpLVAL_INTRO;
4109         }
4110         else {
4111             /* The listop in rops might have a pushmark at the beginning,
4112                which will mess up list assignment. */
4113             LISTOP * const lrops = cLISTOPx(rops); /* for brevity */
4114             if (rops->op_type == OP_LIST &&
4115                 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
4116             {
4117                 OP * const pushmark = lrops->op_first;
4118                 /* excise pushmark */
4119                 op_sibling_splice(rops, NULL, 1, NULL);
4120                 op_free(pushmark);
4121             }
4122             o = op_append_list(OP_LIST, o, rops);
4123         }
4124     }
4125     PL_parser->in_my = FALSE;
4126     PL_parser->in_my_stash = NULL;
4127     return o;
4128 }
4129
4130 OP *
4131 Perl_sawparens(pTHX_ OP *o)
4132 {
4133     PERL_UNUSED_CONTEXT;
4134     if (o)
4135         o->op_flags |= OPf_PARENS;
4136     return o;
4137 }
4138
4139 OP *
4140 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
4141 {
4142     OP *o;
4143     bool ismatchop = 0;
4144     const OPCODE ltype = left->op_type;
4145     const OPCODE rtype = right->op_type;
4146
4147     PERL_ARGS_ASSERT_BIND_MATCH;
4148
4149     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
4150           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
4151     {
4152       const char * const desc
4153           = PL_op_desc[(
4154                           rtype == OP_SUBST || rtype == OP_TRANS
4155                        || rtype == OP_TRANSR
4156                        )
4157                        ? (int)rtype : OP_MATCH];
4158       const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
4159       SV * const name = op_varname(left);
4160       if (name)
4161         Perl_warner(aTHX_ packWARN(WARN_MISC),
4162              "Applying %s to %" SVf " will act on scalar(%" SVf ")",
4163              desc, SVfARG(name), SVfARG(name));
4164       else {
4165         const char * const sample = (isary
4166              ? "@array" : "%hash");
4167         Perl_warner(aTHX_ packWARN(WARN_MISC),
4168              "Applying %s to %s will act on scalar(%s)",
4169              desc, sample, sample);
4170       }
4171     }
4172
4173     if (rtype == OP_CONST &&
4174         cSVOPx(right)->op_private & OPpCONST_BARE &&
4175         cSVOPx(right)->op_private & OPpCONST_STRICT)
4176     {
4177         no_bareword_allowed(right);
4178     }
4179
4180     /* !~ doesn't make sense with /r, so error on it for now */
4181     if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
4182         type == OP_NOT)
4183         /* diag_listed_as: Using !~ with %s doesn't make sense */
4184         yyerror("Using !~ with s///r doesn't make sense");
4185     if (rtype == OP_TRANSR && type == OP_NOT)
4186         /* diag_listed_as: Using !~ with %s doesn't make sense */
4187         yyerror("Using !~ with tr///r doesn't make sense");
4188
4189     ismatchop = (rtype == OP_MATCH ||
4190                  rtype == OP_SUBST ||
4191                  rtype == OP_TRANS || rtype == OP_TRANSR)
4192              && !(right->op_flags & OPf_SPECIAL);
4193     if (ismatchop && right->op_private & OPpTARGET_MY) {
4194         right->op_targ = 0;
4195         right->op_private &= ~OPpTARGET_MY;
4196     }
4197     if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
4198         if (left->op_type == OP_PADSV
4199          && !(left->op_private & OPpLVAL_INTRO))
4200         {
4201             right->op_targ = left->op_targ;
4202             op_free(left);
4203             o = right;
4204         }
4205         else {
4206             right->op_flags |= OPf_STACKED;
4207             if (rtype != OP_MATCH && rtype != OP_TRANSR &&
4208             ! (rtype == OP_TRANS &&
4209                right->op_private & OPpTRANS_IDENTICAL) &&
4210             ! (rtype == OP_SUBST &&
4211                (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
4212                 left = op_lvalue(left, rtype);
4213             if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
4214                 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
4215             else
4216                 o = op_prepend_elem(rtype, scalar(left), right);
4217         }
4218         if (type == OP_NOT)
4219             return newUNOP(OP_NOT, 0, scalar(o));
4220         return o;
4221     }
4222     else
4223         return bind_match(type, left,
4224                 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
4225 }
4226
4227 OP *
4228 Perl_invert(pTHX_ OP *o)
4229 {
4230     if (!o)
4231         return NULL;
4232     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
4233 }
4234
4235 OP *
4236 Perl_cmpchain_start(pTHX_ I32 type, OP *left, OP *right)
4237 {
4238     BINOP *bop;
4239     OP *op;
4240
4241     if (!left)
4242         left = newOP(OP_NULL, 0);
4243     if (!right)
4244         right = newOP(OP_NULL, 0);
4245     scalar(left);
4246     scalar(right);
4247     NewOp(0, bop, 1, BINOP);
4248     op = (OP*)bop;
4249     ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP);
4250     OpTYPE_set(op, type);
4251     cBINOPx(op)->op_flags = OPf_KIDS;
4252     cBINOPx(op)->op_private = 2;
4253     cBINOPx(op)->op_first = left;
4254     cBINOPx(op)->op_last = right;
4255     OpMORESIB_set(left, right);
4256     OpLASTSIB_set(right, op);
4257     return op;
4258 }
4259
4260 OP *
4261 Perl_cmpchain_extend(pTHX_ I32 type, OP *ch, OP *right)
4262 {
4263     BINOP *bop;
4264     OP *op;
4265
4266     PERL_ARGS_ASSERT_CMPCHAIN_EXTEND;
4267     if (!right)
4268         right = newOP(OP_NULL, 0);
4269     scalar(right);
4270     NewOp(0, bop, 1, BINOP);
4271     op = (OP*)bop;
4272     ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP);
4273     OpTYPE_set(op, type);
4274     if (ch->op_type != OP_NULL) {
4275         UNOP *lch;
4276         OP *nch, *cleft, *cright;
4277         NewOp(0, lch, 1, UNOP);
4278         nch = (OP*)lch;
4279         OpTYPE_set(nch, OP_NULL);
4280         nch->op_flags = OPf_KIDS;
4281         cleft = cBINOPx(ch)->op_first;
4282         cright = cBINOPx(ch)->op_last;
4283         cBINOPx(ch)->op_first = NULL;
4284         cBINOPx(ch)->op_last = NULL;
4285         cBINOPx(ch)->op_private = 0;
4286         cBINOPx(ch)->op_flags = 0;
4287         cUNOPx(nch)->op_first = cright;
4288         OpMORESIB_set(cright, ch);
4289         OpMORESIB_set(ch, cleft);
4290         OpLASTSIB_set(cleft, nch);
4291         ch = nch;
4292     }
4293     OpMORESIB_set(right, op);
4294     OpMORESIB_set(op, cUNOPx(ch)->op_first);
4295     cUNOPx(ch)->op_first = right;
4296     return ch;
4297 }
4298
4299 OP *
4300 Perl_cmpchain_finish(pTHX_ OP *ch)
4301 {
4302
4303     PERL_ARGS_ASSERT_CMPCHAIN_FINISH;
4304     if (ch->op_type != OP_NULL) {
4305         OPCODE cmpoptype = ch->op_type;
4306         ch = CHECKOP(cmpoptype, ch);
4307         if(!ch->op_next && ch->op_type == cmpoptype)
4308             ch = fold_constants(op_integerize(op_std_init(ch)));
4309         return ch;
4310     } else {
4311         OP *condop = NULL;
4312         OP *rightarg = cUNOPx(ch)->op_first;
4313         cUNOPx(ch)->op_first = OpSIBLING(rightarg);
4314         OpLASTSIB_set(rightarg, NULL);
4315         while (1) {
4316             OP *cmpop = cUNOPx(ch)->op_first;
4317             OP *leftarg = OpSIBLING(cmpop);
4318             OPCODE cmpoptype = cmpop->op_type;
4319             OP *nextrightarg;
4320             bool is_last;
4321             is_last = !(cUNOPx(ch)->op_first = OpSIBLING(leftarg));
4322             OpLASTSIB_set(cmpop, NULL);
4323             OpLASTSIB_set(leftarg, NULL);
4324             if (is_last) {
4325                 ch->op_flags = 0;
4326                 op_free(ch);
4327                 nextrightarg = NULL;
4328             } else {
4329                 nextrightarg = newUNOP(OP_CMPCHAIN_DUP, 0, leftarg);
4330                 leftarg = newOP(OP_NULL, 0);
4331             }
4332             cBINOPx(cmpop)->op_first = leftarg;
4333             cBINOPx(cmpop)->op_last = rightarg;
4334             OpMORESIB_set(leftarg, rightarg);
4335             OpLASTSIB_set(rightarg, cmpop);
4336             cmpop->op_flags = OPf_KIDS;
4337             cmpop->op_private = 2;
4338             cmpop = CHECKOP(cmpoptype, cmpop);
4339             if(!cmpop->op_next && cmpop->op_type == cmpoptype)
4340                 cmpop = op_integerize(op_std_init(cmpop));
4341             condop = condop ? newLOGOP(OP_CMPCHAIN_AND, 0, cmpop, condop) :
4342                         cmpop;
4343             if (!nextrightarg)
4344                 return condop;
4345             rightarg = nextrightarg;
4346         }
4347     }
4348 }
4349
4350 /*
4351 =for apidoc op_scope
4352
4353 Wraps up an op tree with some additional ops so that at runtime a dynamic
4354 scope will be created.  The original ops run in the new dynamic scope,
4355 and then, provided that they exit normally, the scope will be unwound.
4356 The additional ops used to create and unwind the dynamic scope will
4357 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
4358 instead if the ops are simple enough to not need the full dynamic scope
4359 structure.
4360
4361 =cut
4362 */
4363
4364 OP *
4365 Perl_op_scope(pTHX_ OP *o)
4366 {
4367     if (o) {
4368         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
4369             o = op_prepend_elem(OP_LINESEQ,
4370                     newOP(OP_ENTER, (o->op_flags & OPf_WANT)), o);
4371             OpTYPE_set(o, OP_LEAVE);
4372         }
4373         else if (o->op_type == OP_LINESEQ) {
4374             OP *kid;
4375             OpTYPE_set(o, OP_SCOPE);
4376             kid = cLISTOPo->op_first;
4377             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
4378                 op_null(kid);
4379
4380                 /* The following deals with things like 'do {1 for 1}' */
4381                 kid = OpSIBLING(kid);
4382                 if (kid &&
4383                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
4384                     op_null(kid);
4385             }
4386         }
4387         else
4388             o = newLISTOP(OP_SCOPE, 0, o, NULL);
4389     }
4390     return o;
4391 }
4392
4393 OP *
4394 Perl_op_unscope(pTHX_ OP *o)
4395 {
4396     if (o && o->op_type == OP_LINESEQ) {
4397         OP *kid = cLISTOPo->op_first;
4398         for(; kid; kid = OpSIBLING(kid))
4399             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
4400                 op_null(kid);
4401     }
4402     return o;
4403 }
4404
4405 /*
4406 =for apidoc block_start
4407
4408 Handles compile-time scope entry.
4409 Arranges for hints to be restored on block
4410 exit and also handles pad sequence numbers to make lexical variables scope
4411 right.  Returns a savestack index for use with C<block_end>.
4412
4413 =cut
4414 */
4415
4416 int
4417 Perl_block_start(pTHX_ int full)
4418 {
4419     const int retval = PL_savestack_ix;
4420
4421     PL_compiling.cop_seq = PL_cop_seqmax;
4422     COP_SEQMAX_INC;
4423     pad_block_start(full);
4424     SAVEHINTS();
4425     PL_hints &= ~HINT_BLOCK_SCOPE;
4426     SAVECOMPILEWARNINGS();
4427     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
4428     SAVEI32(PL_compiling.cop_seq);
4429     PL_compiling.cop_seq = 0;
4430
4431     CALL_BLOCK_HOOKS(bhk_start, full);
4432
4433     return retval;
4434 }
4435
4436 /*
4437 =for apidoc block_end
4438
4439 Handles compile-time scope exit.  C<floor>
4440 is the savestack index returned by
4441 C<block_start>, and C<seq> is the body of the block.  Returns the block,
4442 possibly modified.
4443
4444 =cut
4445 */
4446
4447 OP*
4448 Perl_block_end(pTHX_ I32 floor, OP *seq)
4449 {
4450     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
4451     OP* retval = voidnonfinal(seq);
4452     OP *o;
4453
4454     /* XXX Is the null PL_parser check necessary here? */
4455     assert(PL_parser); /* Let’s find out under debugging builds.  */
4456     if (PL_parser && PL_parser->parsed_sub) {
4457         o = newSTATEOP(0, NULL, NULL);
4458         op_null(o);
4459         retval = op_append_elem(OP_LINESEQ, retval, o);
4460     }
4461
4462     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
4463
4464     LEAVE_SCOPE(floor);
4465     if (needblockscope)
4466         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
4467     o = pad_leavemy();
4468
4469     if (o) {
4470         /* pad_leavemy has created a sequence of introcv ops for all my
4471            subs declared in the block.  We have to replicate that list with
4472            clonecv ops, to deal with this situation:
4473
4474                sub {
4475                    my sub s1;
4476                    my sub s2;
4477                    sub s1 { state sub foo { \&s2 } }
4478                }->()
4479
4480            Originally, I was going to have introcv clone the CV and turn
4481            off the stale flag.  Since &s1 is declared before &s2, the
4482            introcv op for &s1 is executed (on sub entry) before the one for
4483            &s2.  But the &foo sub inside &s1 (which is cloned when &s1 is
4484            cloned, since it is a state sub) closes over &s2 and expects
4485            to see it in its outer CV’s pad.  If the introcv op clones &s1,
4486            then &s2 is still marked stale.  Since &s1 is not active, and
4487            &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
4488            ble will not stay shared’ warning.  Because it is the same stub
4489            that will be used when the introcv op for &s2 is executed, clos-
4490            ing over it is safe.  Hence, we have to turn off the stale flag
4491            on all lexical subs in the block before we clone any of them.
4492            Hence, having introcv clone the sub cannot work.  So we create a
4493            list of ops like this:
4494
4495                lineseq
4496                   |
4497                   +-- introcv
4498                   |
4499                   +-- introcv
4500                   |
4501                   +-- introcv
4502                   |
4503                   .
4504                   .
4505                   .
4506                   |
4507                   +-- clonecv
4508                   |
4509                   +-- clonecv
4510                   |
4511                   +-- clonecv
4512                   |
4513                   .
4514                   .
4515                   .
4516          */
4517         OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
4518         OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
4519         for (;; kid = OpSIBLING(kid)) {
4520             OP *newkid = newOP(OP_CLONECV, 0);
4521             newkid->op_targ = kid->op_targ;
4522             o = op_append_elem(OP_LINESEQ, o, newkid);
4523             if (kid == last) break;
4524         }
4525         retval = op_prepend_elem(OP_LINESEQ, o, retval);
4526     }
4527
4528     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
4529
4530     return retval;
4531 }
4532
4533 /*
4534 =for apidoc_section $scope
4535
4536 =for apidoc blockhook_register
4537
4538 Register a set of hooks to be called when the Perl lexical scope changes
4539 at compile time.  See L<perlguts/"Compile-time scope hooks">.
4540
4541 =cut
4542 */
4543
4544 void
4545 Perl_blockhook_register(pTHX_ BHK *hk)
4546 {
4547     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
4548
4549     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
4550 }
4551
4552 void
4553 Perl_newPROG(pTHX_ OP *o)
4554 {
4555     OP *start;
4556
4557     PERL_ARGS_ASSERT_NEWPROG;
4558
4559     if (PL_in_eval) {
4560         PERL_CONTEXT *cx;
4561         I32 i;
4562         if (PL_eval_root)
4563                 return;
4564         PL_eval_root = newUNOP(OP_LEAVEEVAL,
4565                                ((PL_in_eval & EVAL_KEEPERR)
4566                                 ? OPf_SPECIAL : 0), o);
4567
4568         cx = CX_CUR();
4569         assert(CxTYPE(cx) == CXt_EVAL);
4570
4571         if ((cx->blk_gimme & G_WANT) == G_VOID)
4572             scalarvoid(PL_eval_root);
4573         else if ((cx->blk_gimme & G_WANT) == G_LIST)
4574             list(PL_eval_root);
4575         else
4576             scalar(PL_eval_root);
4577
4578         start = op_linklist(PL_eval_root);
4579         PL_eval_root->op_next = 0;
4580         i = PL_savestack_ix;
4581         SAVEFREEOP(o);
4582         ENTER;
4583         S_process_optree(aTHX_ NULL, PL_eval_root, start);
4584         LEAVE;
4585         PL_savestack_ix = i;
4586     }
4587     else {
4588         if (o->op_type == OP_STUB) {
4589             /* This block is entered if nothing is compiled for the main
4590                program. This will be the case for an genuinely empty main
4591                program, or one which only has BEGIN blocks etc, so already
4592                run and freed.
4593
4594                Historically (5.000) the guard above was !o. However, commit
4595                f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
4596                c71fccf11fde0068, changed perly.y so that newPROG() is now
4597                called with the output of block_end(), which returns a new
4598                OP_STUB for the case of an empty optree. ByteLoader (and
4599                maybe other things) also take this path, because they set up
4600                PL_main_start and PL_main_root directly, without generating an
4601                optree.
4602
4603                If the parsing the main program aborts (due to parse errors,
4604                or due to BEGIN or similar calling exit), then newPROG()
4605                isn't even called, and hence this code path and its cleanups
4606                are skipped. This shouldn't make a make a difference:
4607                * a non-zero return from perl_parse is a failure, and
4608                  perl_destruct() should be called immediately.
4609                * however, if exit(0) is called during the parse, then
4610                  perl_parse() returns 0, and perl_run() is called. As
4611                  PL_main_start will be NULL, perl_run() will return
4612                  promptly, and the exit code will remain 0.
4613             */
4614
4615             PL_comppad_name = 0;
4616             PL_compcv = 0;
4617             S_op_destroy(aTHX_ o);
4618             return;
4619         }
4620         PL_main_root = op_scope(sawparens(scalarvoid(o)));
4621         PL_curcop = &PL_compiling;
4622         start = LINKLIST(PL_main_root);
4623         PL_main_root->op_next = 0;
4624         S_process_optree(aTHX_ NULL, PL_main_root, start);
4625         if (!PL_parser->error_count)
4626             /* on error, leave CV slabbed so that ops left lying around
4627              * will eb cleaned up. Else unslab */
4628             cv_forget_slab(PL_compcv);
4629         PL_compcv = 0;
4630
4631         /* Register with debugger */
4632         if (PERLDB_INTER) {
4633             CV * const cv = get_cvs("DB::postponed", 0);
4634             if (cv) {
4635                 dSP;
4636                 PUSHMARK(SP);
4637                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
4638                 PUTBACK;
4639                 call_sv(MUTABLE_SV(cv), G_DISCARD);
4640             }
4641         }
4642     }
4643 }
4644
4645 OP *
4646 Perl_localize(pTHX_ OP *o, I32 lex)
4647 {
4648     PERL_ARGS_ASSERT_LOCALIZE;
4649
4650     if (o->op_flags & OPf_PARENS)
4651 /* [perl #17376]: this appears to be premature, and results in code such as
4652    C< our(%x); > executing in list mode rather than void mode */
4653 #if 0
4654         list(o);
4655 #else
4656         NOOP;
4657 #endif
4658     else {
4659         if ( PL_parser->bufptr > PL_parser->oldbufptr
4660             && PL_parser->bufptr[-1] == ','
4661             && ckWARN(WARN_PARENTHESIS))
4662         {
4663             char *s = PL_parser->bufptr;
4664             bool sigil = FALSE;
4665
4666             /* some heuristics to detect a potential error */
4667             while (*s && (memCHRs(", \t\n", *s)))
4668                 s++;
4669
4670             while (1) {
4671                 if (*s && (memCHRs("@$%", *s) || (!lex && *s == '*'))
4672                        && *++s
4673                        && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
4674                     s++;
4675                     sigil = TRUE;
4676                     while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
4677                         s++;
4678                     while (*s && (memCHRs(", \t\n", *s)))
4679                         s++;
4680                 }
4681                 else
4682                     break;
4683             }
4684             if (sigil && (*s == ';' || *s == '=')) {
4685                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
4686                                 "Parentheses missing around \"%s\" list",
4687                                 lex
4688                                     ? (PL_parser->in_my == KEY_our
4689                                         ? "our"
4690                                         : PL_parser->in_my == KEY_state
4691                                             ? "state"
4692                                             : "my")
4693                                     : "local");
4694             }
4695         }
4696     }
4697     if (lex)
4698         o = my(o);
4699     else
4700         o = op_lvalue(o, OP_NULL);              /* a bit kludgey */
4701     PL_parser->in_my = FALSE;
4702     PL_parser->in_my_stash = NULL;
4703     return o;
4704 }
4705
4706 OP *
4707 Perl_jmaybe(pTHX_ OP *o)
4708 {
4709     PERL_ARGS_ASSERT_JMAYBE;
4710
4711     if (o->op_type == OP_LIST) {
4712         if (FEATURE_MULTIDIMENSIONAL_IS_ENABLED) {
4713             OP * const o2
4714                 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
4715             o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
4716         }
4717         else {
4718             /* If the user disables this, then a warning might not be enough to alert
4719                them to a possible change of behaviour here, so throw an exception.
4720             */
4721             yyerror("Multidimensional hash lookup is disabled");
4722         }
4723     }
4724     return o;
4725 }
4726
4727 PERL_STATIC_INLINE OP *
4728 S_op_std_init(pTHX_ OP *o)
4729 {
4730     I32 type = o->op_type;
4731
4732     PERL_ARGS_ASSERT_OP_STD_INIT;
4733
4734     if (PL_opargs[type] & OA_RETSCALAR)
4735         scalar(o);
4736     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
4737         o->op_targ = pad_alloc(type, SVs_PADTMP);
4738
4739     return o;
4740 }
4741
4742 PERL_STATIC_INLINE OP *
4743 S_op_integerize(pTHX_ OP *o)
4744 {
4745     I32 type = o->op_type;
4746
4747     PERL_ARGS_ASSERT_OP_INTEGERIZE;
4748
4749     /* integerize op. */
4750     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
4751     {
4752         o->op_ppaddr = PL_ppaddr[++(o->op_type)];
4753     }
4754
4755     if (type == OP_NEGATE)
4756         /* XXX might want a ck_negate() for this */
4757         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
4758
4759     return o;
4760 }
4761
4762 /* This function exists solely to provide a scope to limit
4763    setjmp/longjmp() messing with auto variables.  It cannot be inlined because
4764    it uses setjmp
4765  */
4766 STATIC int
4767 S_fold_constants_eval(pTHX) {
4768     int ret = 0;
4769     dJMPENV;
4770
4771     JMPENV_PUSH(ret);
4772
4773     if (ret == 0) {
4774         CALLRUNOPS(aTHX);
4775     }
4776
4777     JMPENV_POP;
4778
4779     return ret;
4780 }
4781
4782 static OP *
4783 S_fold_constants(pTHX_ OP *const o)
4784 {
4785     OP *curop;
4786     OP *newop;
4787     I32 type = o->op_type;
4788     bool is_stringify;
4789     SV *sv = NULL;
4790     int ret = 0;
4791     OP *old_next;
4792     SV * const oldwarnhook = PL_warnhook;
4793     SV * const olddiehook  = PL_diehook;
4794     COP not_compiling;
4795     U8 oldwarn = PL_dowarn;
4796     I32 old_cxix;
4797
4798     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
4799
4800     if (!(PL_opargs[type] & OA_FOLDCONST))
4801         goto nope;
4802
4803     switch (type) {
4804     case OP_UCFIRST:
4805     case OP_LCFIRST:
4806     case OP_UC:
4807     case OP_LC:
4808     case OP_FC:
4809 #ifdef USE_LOCALE_CTYPE
4810         if (IN_LC_COMPILETIME(LC_CTYPE))
4811             goto nope;
4812 #endif
4813         break;
4814     case OP_SLT:
4815     case OP_SGT:
4816     case OP_SLE:
4817     case OP_SGE:
4818     case OP_SCMP:
4819 #ifdef USE_LOCALE_COLLATE
4820         if (IN_LC_COMPILETIME(LC_COLLATE))
4821             goto nope;
4822 #endif
4823         break;
4824     case OP_SPRINTF:
4825         /* XXX what about the numeric ops? */
4826 #ifdef USE_LOCALE_NUMERIC
4827         if (IN_LC_COMPILETIME(LC_NUMERIC))
4828             goto nope;
4829 #endif
4830         break;
4831     case OP_PACK:
4832         if (!OpHAS_SIBLING(cLISTOPo->op_first)
4833           || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
4834             goto nope;
4835         {
4836             SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
4837             if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
4838             {
4839                 const char *s = SvPVX_const(sv);
4840                 while (s < SvEND(sv)) {
4841                     if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
4842                     s++;
4843                 }
4844             }
4845         }
4846         break;
4847     case OP_REPEAT:
4848         if (o->op_private & OPpREPEAT_DOLIST) goto nope;
4849         break;
4850     case OP_SREFGEN:
4851         if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
4852          || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
4853             goto nope;
4854     }
4855
4856     if (PL_parser && PL_parser->error_count)
4857         goto nope;              /* Don't try to run w/ errors */
4858
4859     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4860         switch (curop->op_type) {
4861         case OP_CONST:
4862             if (   (curop->op_private & OPpCONST_BARE)
4863                 && (curop->op_private & OPpCONST_STRICT)) {
4864                 no_bareword_allowed(curop);
4865                 goto nope;
4866             }
4867             /* FALLTHROUGH */
4868         case OP_LIST:
4869         case OP_SCALAR:
4870         case OP_NULL:
4871         case OP_PUSHMARK:
4872             /* Foldable; move to next op in list */
4873             break;
4874
4875         default:
4876             /* No other op types are considered foldable */
4877             goto nope;
4878         }
4879     }
4880
4881     curop = LINKLIST(o);
4882     old_next = o->op_next;
4883     o->op_next = 0;
4884     PL_op = curop;
4885
4886     old_cxix = cxstack_ix;
4887     create_eval_scope(NULL, G_FAKINGEVAL);
4888
4889     /* Verify that we don't need to save it:  */
4890     assert(PL_curcop == &PL_compiling);
4891     StructCopy(&PL_compiling, &not_compiling, COP);
4892     PL_curcop = &not_compiling;
4893     /* The above ensures that we run with all the correct hints of the
4894        currently compiling COP, but that IN_PERL_RUNTIME is true. */
4895     assert(IN_PERL_RUNTIME);
4896     PL_warnhook = PERL_WARNHOOK_FATAL;
4897     PL_diehook  = NULL;
4898
4899     /* Effective $^W=1.  */
4900     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
4901         PL_dowarn |= G_WARN_ON;
4902
4903     ret = S_fold_constants_eval(aTHX);
4904
4905     switch (ret) {
4906     case 0:
4907         sv = *(PL_stack_sp--);
4908         if (o->op_targ && sv == PAD_SV(o->op_targ)) {   /* grab pad temp? */
4909             pad_swipe(o->op_targ,  FALSE);
4910         }
4911         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
4912             SvREFCNT_inc_simple_void(sv);
4913             SvTEMP_off(sv);
4914         }
4915         else { assert(SvIMMORTAL(sv)); }
4916         break;
4917     case 3:
4918         /* Something tried to die.  Abandon constant folding.  */
4919         /* Pretend the error never happened.  */
4920         CLEAR_ERRSV();
4921         o->op_next = old_next;
4922         break;
4923     default:
4924         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
4925         PL_warnhook = oldwarnhook;
4926         PL_diehook  = olddiehook;
4927         /* XXX note that this croak may fail as we've already blown away
4928          * the stack - eg any nested evals */
4929         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
4930     }
4931     PL_dowarn   = oldwarn;
4932     PL_warnhook = oldwarnhook;
4933     PL_diehook  = olddiehook;
4934     PL_curcop = &PL_compiling;
4935
4936     /* if we croaked, depending on how we croaked the eval scope
4937      * may or may not have already been popped */
4938     if (cxstack_ix > old_cxix) {
4939         assert(cxstack_ix == old_cxix + 1);
4940         assert(CxTYPE(CX_CUR()) == CXt_EVAL);
4941         delete_eval_scope();
4942     }
4943     if (ret)
4944         goto nope;
4945
4946     /* OP_STRINGIFY and constant folding are used to implement qq.
4947        Here the constant folding is an implementation detail that we
4948        want to hide.  If the stringify op is itself already marked
4949        folded, however, then it is actually a folded join.  */
4950     is_stringify = type == OP_STRINGIFY && !o->op_folded;
4951     op_free(o);
4952     assert(sv);
4953     if (is_stringify)
4954         SvPADTMP_off(sv);
4955     else if (!SvIMMORTAL(sv)) {
4956         SvPADTMP_on(sv);
4957         SvREADONLY_on(sv);
4958     }
4959     newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
4960     if (!is_stringify) newop->op_folded = 1;
4961     return newop;
4962
4963  nope:
4964     return o;
4965 }
4966
4967 /* convert a constant range in list context into an OP_RV2AV, OP_CONST pair;
4968  * the constant value being an AV holding the flattened range.
4969  */
4970
4971 static void
4972 S_gen_constant_list(pTHX_ OP *o)
4973 {
4974     OP *curop, *old_next;
4975     SV * const oldwarnhook = PL_warnhook;
4976     SV * const olddiehook  = PL_diehook;
4977     COP *old_curcop;
4978     U8 oldwarn = PL_dowarn;
4979     SV **svp;
4980     AV *av;
4981     I32 old_cxix;
4982     COP not_compiling;
4983     int ret = 0;
4984     dJMPENV;
4985     bool op_was_null;
4986
4987     list(o);
4988     if (PL_parser && PL_parser->error_count)
4989         return;         /* Don't attempt to run with errors */
4990
4991     curop = LINKLIST(o);
4992     old_next = o->op_next;
4993     o->op_next = 0;
4994     op_was_null = o->op_type == OP_NULL;
4995     if (op_was_null) /* b3698342565fb462291fba4b432cfcd05b6eb4e1 */
4996         o->op_type = OP_CUSTOM;
4997     CALL_PEEP(curop);
4998     if (op_was_null)
4999         o->op_type = OP_NULL;
5000     op_prune_chain_head(&curop);
5001     PL_op = curop;
5002
5003     old_cxix = cxstack_ix;
5004     create_eval_scope(NULL, G_FAKINGEVAL);
5005
5006     old_curcop = PL_curcop;
5007     StructCopy(old_curcop, &not_compiling, COP);
5008     PL_curcop = &not_compiling;
5009     /* The above ensures that we run with all the correct hints of the
5010        current COP, but that IN_PERL_RUNTIME is true. */
5011     assert(IN_PERL_RUNTIME);
5012     PL_warnhook = PERL_WARNHOOK_FATAL;
5013     PL_diehook  = NULL;
5014     JMPENV_PUSH(ret);
5015
5016     /* Effective $^W=1.  */
5017     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
5018         PL_dowarn |= G_WARN_ON;
5019
5020     switch (ret) {
5021     case 0:
5022 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
5023         PL_curstackinfo->si_stack_hwm = 0; /* stop valgrind complaining */
5024 #endif
5025         Perl_pp_pushmark(aTHX);
5026         CALLRUNOPS(aTHX);
5027         PL_op = curop;
5028         assert (!(curop->op_flags & OPf_SPECIAL));
5029         assert(curop->op_type == OP_RANGE);
5030         Perl_pp_anonlist(aTHX);
5031         break;
5032     case 3:
5033         CLEAR_ERRSV();
5034         o->op_next = old_next;
5035         break;
5036     default:
5037         JMPENV_POP;
5038         PL_warnhook = oldwarnhook;
5039         PL_diehook = olddiehook;
5040         Perl_croak(aTHX_ "panic: gen_constant_list JMPENV_PUSH returned %d",
5041             ret);
5042     }
5043
5044     JMPENV_POP;
5045     PL_dowarn = oldwarn;
5046     PL_warnhook = oldwarnhook;
5047     PL_diehook = olddiehook;
5048     PL_curcop = old_curcop;
5049
5050     if (cxstack_ix > old_cxix) {
5051         assert(cxstack_ix == old_cxix + 1);
5052         assert(CxTYPE(CX_CUR()) == CXt_EVAL);
5053         delete_eval_scope();
5054     }
5055     if (ret)
5056         return;
5057
5058     OpTYPE_set(o, OP_RV2AV);
5059     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
5060     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
5061     o->op_opt = 0;              /* needs to be revisited in rpeep() */
5062     av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
5063
5064     /* replace subtree with an OP_CONST */
5065     curop = cUNOPo->op_first;
5066     op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
5067     op_free(curop);
5068
5069     if (AvFILLp(av) != -1)
5070         for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
5071         {
5072             SvPADTMP_on(*svp);
5073             SvREADONLY_on(*svp);
5074         }
5075     LINKLIST(o);
5076     list(o);
5077     return;
5078 }
5079
5080 /*
5081 =for apidoc_section $optree_manipulation
5082 */
5083
5084 /* List constructors */
5085
5086 /*
5087 =for apidoc op_append_elem
5088
5089 Append an item to the list of ops contained directly within a list-type
5090 op, returning the lengthened list.  C<first> is the list-type op,
5091 and C<last> is the op to append to the list.  C<optype> specifies the
5092 intended opcode for the list.  If C<first> is not already a list of the
5093 right type, it will be upgraded into one.  If either C<first> or C<last>
5094 is null, the other is returned unchanged.
5095
5096 =cut
5097 */
5098
5099 OP *
5100 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
5101 {
5102     if (!first)
5103         return last;
5104
5105     if (!last)
5106         return first;
5107
5108     if (first->op_type != (unsigned)type
5109         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
5110     {
5111         return newLISTOP(type, 0, first, last);
5112     }
5113
5114     op_sibling_splice(first, cLISTOPx(first)->op_last, 0, last);
5115     first->op_flags |= OPf_KIDS;
5116     return first;
5117 }
5118
5119 /*
5120 =for apidoc op_append_list
5121
5122 Concatenate the lists of ops contained directly within two list-type ops,
5123 returning the combined list.  C<first> and C<last> are the list-type ops
5124 to concatenate.  C<optype> specifies the intended opcode for the list.
5125 If either C<first> or C<last> is not already a list of the right type,
5126 it will be upgraded into one.  If either C<first> or C<last> is null,
5127 the other is returned unchanged.
5128
5129 =cut
5130 */
5131
5132 OP *
5133 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
5134 {
5135     if (!first)
5136         return last;
5137
5138     if (!last)
5139         return first;
5140
5141     if (first->op_type != (unsigned)type)
5142         return op_prepend_elem(type, first, last);
5143
5144     if (last->op_type != (unsigned)type)
5145         return op_append_elem(type, first, last);
5146
5147     OpMORESIB_set(cLISTOPx(first)->op_last, cLISTOPx(last)->op_first);
5148     cLISTOPx(first)->op_last = cLISTOPx(last)->op_last;
5149     OpLASTSIB_set(cLISTOPx(first)->op_last, first);
5150     first->op_flags |= (last->op_flags & OPf_KIDS);
5151
5152     S_op_destroy(aTHX_ last);
5153
5154     return first;
5155 }
5156
5157 /*
5158 =for apidoc op_prepend_elem
5159
5160 Prepend an item to the list of ops contained directly within a list-type
5161 op, returning the lengthened list.  C<first> is the op to prepend to the
5162 list, and C<last> is the list-type op.  C<optype> specifies the intended
5163 opcode for the list.  If C<last> is not already a list of the right type,
5164 it will be upgraded into one.  If either C<first> or C<last> is null,
5165 the other is returned unchanged.
5166
5167 =cut
5168 */
5169
5170 OP *
5171 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
5172 {
5173     if (!first)
5174         return last;
5175
5176     if (!last)
5177         return first;
5178
5179     if (last->op_type == (unsigned)type) {
5180         if (type == OP_LIST) {  /* already a PUSHMARK there */
5181             /* insert 'first' after pushmark */
5182             op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
5183             if (!(first->op_flags & OPf_PARENS))
5184                 last->op_flags &= ~OPf_PARENS;
5185         }
5186         else
5187             op_sibling_splice(last, NULL, 0, first);
5188         last->op_flags |= OPf_KIDS;
5189         return last;
5190     }
5191
5192     return newLISTOP(type, 0, first, last);
5193 }
5194
5195 /*
5196 =for apidoc op_convert_list
5197
5198 Converts C<o> into a list op if it is not one already, and then converts it
5199 into the specified C<type>, calling its check function, allocating a target if
5200 it needs one, and folding constants.
5201
5202 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
5203 C<op_prepend_elem> and C<op_append_elem>.  Then finally it is passed to
5204 C<op_convert_list> to make it the right type.
5205
5206 =cut
5207 */
5208
5209 OP *
5210 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
5211 {
5212     if (type < 0) type = -type, flags |= OPf_SPECIAL;
5213     if (!o || o->op_type != OP_LIST)
5214         o = force_list(o, FALSE);
5215     else
5216     {
5217         o->op_flags &= ~OPf_WANT;
5218         o->op_private &= ~OPpLVAL_INTRO;
5219     }
5220
5221     if (!(PL_opargs[type] & OA_MARK))
5222         op_null(cLISTOPo->op_first);
5223     else {
5224         OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
5225         if (kid2 && kid2->op_type == OP_COREARGS) {
5226             op_null(cLISTOPo->op_first);
5227             kid2->op_private |= OPpCOREARGS_PUSHMARK;
5228         }
5229     }
5230
5231     if (type != OP_SPLIT)
5232         /* At this point o is a LISTOP, but OP_SPLIT is a PMOP; let
5233          * ck_split() create a real PMOP and leave the op's type as listop
5234          * for now. Otherwise op_free() etc will crash.
5235          */
5236         OpTYPE_set(o, type);
5237
5238     o->op_flags |= flags;
5239     if (flags & OPf_FOLDED)
5240         o->op_folded = 1;
5241
5242     o = CHECKOP(type, o);
5243     if (o->op_type != (unsigned)type)
5244         return o;
5245
5246     return fold_constants(op_integerize(op_std_init(o)));
5247 }
5248
5249 /* Constructors */
5250
5251
5252 /*
5253 =for apidoc_section $optree_construction
5254
5255 =for apidoc newNULLLIST
5256
5257 Constructs, checks, and returns a new C<stub> op, which represents an
5258 empty list expression.
5259
5260 =cut
5261 */
5262
5263 OP *
5264 Perl_newNULLLIST(pTHX)
5265 {
5266     return newOP(OP_STUB, 0);
5267 }
5268
5269 /* promote o and any siblings to be a list if its not already; i.e.
5270  *
5271  *  o - A - B
5272  *
5273  * becomes
5274  *
5275  *  list
5276  *    |
5277  *  pushmark - o - A - B
5278  *
5279  * If nullit it true, the list op is nulled.
5280  */
5281
5282 static OP *
5283 S_force_list(pTHX_ OP *o, bool nullit)
5284 {
5285     if (!o || o->op_type != OP_LIST) {
5286         OP *rest = NULL;
5287         if (o) {
5288             /* manually detach any siblings then add them back later */
5289             rest = OpSIBLING(o);
5290             OpLASTSIB_set(o, NULL);
5291         }
5292         o = newLISTOP(OP_LIST, 0, o, NULL);
5293         if (rest)
5294             op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
5295     }
5296     if (nullit)
5297         op_null(o);
5298     return o;
5299 }
5300
5301 /*
5302 =for apidoc newLISTOP
5303
5304 Constructs, checks, and returns an op of any list type.  C<type> is
5305 the opcode.  C<flags> gives the eight bits of C<op_flags>, except that
5306 C<OPf_KIDS> will be set automatically if required.  C<first> and C<last>
5307 supply up to two ops to be direct children of the list op; they are
5308 consumed by this function and become part of the constructed op tree.
5309
5310 For most list operators, the check function expects all the kid ops to be
5311 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
5312 appropriate.  What you want to do in that case is create an op of type
5313 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
5314 See L</op_convert_list> for more information.
5315
5316
5317 =cut
5318 */
5319
5320 OP *
5321 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
5322 {
5323     LISTOP *listop;
5324     /* Note that allocating an OP_PUSHMARK can die under Safe.pm if
5325      * pushmark is banned. So do it now while existing ops are in a
5326      * consistent state, in case they suddenly get freed */
5327     OP* const pushop = type == OP_LIST ? newOP(OP_PUSHMARK, 0) : NULL;
5328
5329     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
5330         || type == OP_CUSTOM);
5331
5332     NewOp(1101, listop, 1, LISTOP);
5333     OpTYPE_set(listop, type);
5334     if (first || last)
5335         flags |= OPf_KIDS;
5336     listop->op_flags = (U8)flags;
5337
5338     if (!last && first)
5339         last = first;
5340     else if (!first && last)
5341         first = last;
5342     else if (first)
5343         OpMORESIB_set(first, last);
5344     listop->op_first = first;
5345     listop->op_last = last;
5346
5347     if (pushop) {
5348         OpMORESIB_set(pushop, first);
5349         listop->op_first = pushop;
5350         listop->op_flags |= OPf_KIDS;
5351         if (!last)
5352             listop->op_last = pushop;
5353     }
5354     if (listop->op_last)
5355         OpLASTSIB_set(listop->op_last, (OP*)listop);
5356
5357     return CHECKOP(type, listop);
5358 }
5359
5360 /*
5361 =for apidoc newOP
5362
5363 Constructs, checks, and returns an op of any base type (any type that
5364 has no extra fields).  C<type> is the opcode.  C<flags> gives the
5365 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
5366 of C<op_private>.
5367
5368 =cut
5369 */
5370
5371 OP *
5372 Perl_newOP(pTHX_ I32 type, I32 flags)
5373 {
5374     OP *o;
5375
5376     if (type == -OP_ENTEREVAL) {
5377         type = OP_ENTEREVAL;
5378         flags |= OPpEVAL_BYTES<<8;
5379     }
5380
5381     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
5382         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
5383         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5384         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5385
5386     NewOp(1101, o, 1, OP);
5387     OpTYPE_set(o, type);
5388     o->op_flags = (U8)flags;
5389
5390     o->op_next = o;
5391     o->op_private = (U8)(0 | (flags >> 8));
5392     if (PL_opargs[type] & OA_RETSCALAR)
5393         scalar(o);
5394     if (PL_opargs[type] & OA_TARGET)
5395         o->op_targ = pad_alloc(type, SVs_PADTMP);
5396     return CHECKOP(type, o);
5397 }
5398
5399 /*
5400 =for apidoc newUNOP
5401
5402 Constructs, checks, and returns an op of any unary type.  C<type> is
5403 the opcode.  C<flags> gives the eight bits of C<op_flags>, except that
5404 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
5405 bits, the eight bits of C<op_private>, except that the bit with value 1
5406 is automatically set.  C<first> supplies an optional op to be the direct
5407 child of the unary op; it is consumed by this function and become part
5408 of the constructed op tree.
5409
5410 =for apidoc Amnh||OPf_KIDS
5411
5412 =cut
5413 */
5414
5415 OP *
5416 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
5417 {
5418     UNOP *unop;
5419
5420     if (type == -OP_ENTEREVAL) {
5421         type = OP_ENTEREVAL;
5422         flags |= OPpEVAL_BYTES<<8;
5423     }
5424
5425     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
5426         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
5427         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5428         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
5429         || type == OP_SASSIGN
5430         || type == OP_ENTERTRY
5431         || type == OP_ENTERTRYCATCH
5432         || type == OP_CUSTOM
5433         || type == OP_NULL );
5434
5435     if (!first)
5436         first = newOP(OP_STUB, 0);
5437     if (PL_opargs[type] & OA_MARK)
5438         first = force_list(first, TRUE);
5439
5440     NewOp(1101, unop, 1, UNOP);
5441     OpTYPE_set(unop, type);
5442     unop->op_first = first;
5443     unop->op_flags = (U8)(flags | OPf_KIDS);
5444     unop->op_private = (U8)(1 | (flags >> 8));
5445
5446     if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
5447         OpLASTSIB_set(first, (OP*)unop);
5448
5449     unop = (UNOP*) CHECKOP(type, unop);
5450     if (unop->op_next)
5451         return (OP*)unop;
5452
5453     return fold_constants(op_integerize(op_std_init((OP *) unop)));
5454 }
5455
5456 /*
5457 =for apidoc newUNOP_AUX
5458
5459 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
5460 initialised to C<aux>
5461
5462 =cut
5463 */
5464
5465 OP *
5466 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
5467 {
5468     UNOP_AUX *unop;
5469
5470     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
5471         || type == OP_CUSTOM);
5472
5473     NewOp(1101, unop, 1, UNOP_AUX);
5474     unop->op_type = (OPCODE)type;
5475     unop->op_ppaddr = PL_ppaddr[type];
5476     unop->op_first = first;
5477     unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
5478     unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
5479     unop->op_aux = aux;
5480
5481     if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
5482         OpLASTSIB_set(first, (OP*)unop);
5483
5484     unop = (UNOP_AUX*) CHECKOP(type, unop);
5485
5486     return op_std_init((OP *) unop);
5487 }
5488
5489 /*
5490 =for apidoc newMETHOP
5491
5492 Constructs, checks, and returns an op of method type with a method name
5493 evaluated at runtime.  C<type> is the opcode.  C<flags> gives the eight
5494 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
5495 and, shifted up eight bits, the eight bits of C<op_private>, except that
5496 the bit with value 1 is automatically set.  C<dynamic_meth> supplies an
5497 op which evaluates method name; it is consumed by this function and
5498 become part of the constructed op tree.
5499 Supported optypes: C<OP_METHOD>.
5500
5501 =cut
5502 */
5503
5504 static OP*
5505 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
5506     METHOP *methop;
5507
5508     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
5509         || type == OP_CUSTOM);
5510
5511     NewOp(1101, methop, 1, METHOP);
5512     if (dynamic_meth) {
5513         if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, TRUE);
5514         methop->op_flags = (U8)(flags | OPf_KIDS);
5515         methop->op_u.op_first = dynamic_meth;
5516         methop->op_private = (U8)(1 | (flags >> 8));
5517
5518         if (!OpHAS_SIBLING(dynamic_meth))
5519             OpLASTSIB_set(dynamic_meth, (OP*)methop);
5520     }
5521     else {
5522         assert(const_meth);
5523         methop->op_flags = (U8)(flags & ~OPf_KIDS);
5524         methop->op_u.op_meth_sv = const_meth;
5525         methop->op_private = (U8)(0 | (flags >> 8));
5526         methop->op_next = (OP*)methop;
5527     }
5528
5529 #ifdef USE_ITHREADS
5530     methop->op_rclass_targ = 0;
5531 #else
5532     methop->op_rclass_sv = NULL;
5533 #endif
5534
5535     OpTYPE_set(methop, type);
5536     return CHECKOP(type, methop);
5537 }
5538
5539 OP *
5540 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
5541     PERL_ARGS_ASSERT_NEWMETHOP;
5542     return newMETHOP_internal(type, flags, dynamic_meth, NULL);
5543 }
5544
5545 /*
5546 =for apidoc newMETHOP_named
5547
5548 Constructs, checks, and returns an op of method type with a constant
5549 method name.  C<type> is the opcode.  C<flags> gives the eight bits of
5550 C<op_flags>, and, shifted up eight bits, the eight bits of
5551 C<op_private>.  C<const_meth> supplies a constant method name;
5552 it must be a shared COW string.
5553 Supported optypes: C<OP_METHOD_NAMED>.
5554
5555 =cut
5556 */
5557
5558 OP *
5559 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
5560     PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
5561     return newMETHOP_internal(type, flags, NULL, const_meth);
5562 }
5563
5564 /*
5565 =for apidoc newBINOP
5566
5567 Constructs, checks, and returns an op of any binary type.  C<type>
5568 is the opcode.  C<flags> gives the eight bits of C<op_flags>, except
5569 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
5570 the eight bits of C<op_private>, except that the bit with value 1 or
5571 2 is automatically set as required.  C<first> and C<last> supply up to
5572 two ops to be the direct children of the binary op; they are consumed
5573 by this function and become part of the constructed op tree.
5574
5575 =cut
5576 */
5577
5578 OP *
5579 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
5580 {
5581     BINOP *binop;
5582
5583     ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
5584         || type == OP_NULL || type == OP_CUSTOM);
5585
5586     NewOp(1101, binop, 1, BINOP);
5587
5588     if (!first)
5589         first = newOP(OP_NULL, 0);
5590
5591     OpTYPE_set(binop, type);
5592     binop->op_first = first;
5593     binop->op_flags = (U8)(flags | OPf_KIDS);
5594     if (!last) {
5595         last = first;
5596         binop->op_private = (U8)(1 | (flags >> 8));
5597     }
5598     else {
5599         binop->op_private = (U8)(2 | (flags >> 8));
5600         OpMORESIB_set(first, last);
5601     }
5602
5603     if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
5604         OpLASTSIB_set(last, (OP*)binop);
5605
5606     binop->op_last = OpSIBLING(binop->op_first);
5607     if (binop->op_last)
5608         OpLASTSIB_set(binop->op_last, (OP*)binop);
5609
5610     binop = (BINOP*) CHECKOP(type, binop);
5611     if (binop->op_next || binop->op_type != (OPCODE)type)
5612         return (OP*)binop;
5613
5614     return fold_constants(op_integerize(op_std_init((OP *)binop)));
5615 }
5616
5617 void
5618 Perl_invmap_dump(pTHX_ SV* invlist, UV *map)
5619 {
5620     const char indent[] = "    ";
5621
5622     UV len = _invlist_len(invlist);
5623     UV * array = invlist_array(invlist);
5624     UV i;
5625
5626     PERL_ARGS_ASSERT_INVMAP_DUMP;
5627
5628     for (i = 0; i < len; i++) {
5629         UV start = array[i];
5630         UV end   = (i + 1 < len) ? array[i+1] - 1 : IV_MAX;
5631
5632         PerlIO_printf(Perl_debug_log, "%s[%" UVuf "] 0x%04" UVXf, indent, i, start);
5633         if (end == IV_MAX) {
5634             PerlIO_printf(Perl_debug_log, " .. INFTY");
5635         }
5636         else if (end != start) {
5637             PerlIO_printf(Perl_debug_log, " .. 0x%04" UVXf, end);
5638         }
5639         else {
5640             PerlIO_printf(Perl_debug_log, "            ");
5641         }
5642
5643         PerlIO_printf(Perl_debug_log, "\t");
5644
5645         if (map[i] == TR_UNLISTED) {
5646             PerlIO_printf(Perl_debug_log, "TR_UNLISTED\n");
5647         }
5648         else if (map[i] == TR_SPECIAL_HANDLING) {
5649             PerlIO_printf(Perl_debug_log, "TR_SPECIAL_HANDLING\n");
5650         }
5651         else {
5652             PerlIO_printf(Perl_debug_log, "0x%04" UVXf "\n", map[i]);
5653         }
5654     }
5655 }
5656
5657 /* Given an OP_TRANS / OP_TRANSR op o, plus OP_CONST ops expr and repl
5658  * containing the search and replacement strings, assemble into
5659  * a translation table attached as o->op_pv.
5660  * Free expr and repl.
5661  * It expects the toker to have already set the
5662  *   OPpTRANS_COMPLEMENT
5663  *   OPpTRANS_SQUASH
5664  *   OPpTRANS_DELETE
5665  * flags as appropriate; this function may add
5666  *   OPpTRANS_USE_SVOP
5667  *   OPpTRANS_CAN_FORCE_UTF8
5668  *   OPpTRANS_IDENTICAL
5669  *   OPpTRANS_GROWS
5670  * flags
5671  */
5672
5673 static OP *
5674 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
5675 {
5676     /* This function compiles a tr///, from data gathered from toke.c, into a
5677      * form suitable for use by do_trans() in doop.c at runtime.
5678      *
5679      * It first normalizes the data, while discarding extraneous inputs; then
5680      * writes out the compiled data.  The normalization allows for complete
5681      * analysis, and avoids some false negatives and positives earlier versions
5682      * of this code had.
5683      *
5684      * The normalization form is an inversion map (described below in detail).
5685      * This is essentially the compiled form for tr///'s that require UTF-8,
5686      * and its easy to use it to write the 257-byte table for tr///'s that
5687      * don't need UTF-8.  That table is identical to what's been in use for
5688      * many perl versions, except that it doesn't handle some edge cases that
5689      * it used to, involving code points above 255.  The UTF-8 form now handles
5690      * these.  (This could be changed with extra coding should it shown to be
5691      * desirable.)
5692      *
5693      * If the complement (/c) option is specified, the lhs string (tstr) is
5694      * parsed into an inversion list.  Complementing these is trivial.  Then a
5695      * complemented tstr is built from that, and used thenceforth.  This hides
5696      * the fact that it was complemented from almost all successive code.
5697      *
5698      * One of the important characteristics to know about the input is whether
5699      * the transliteration may be done in place, or does a temporary need to be
5700      * allocated, then copied.  If the replacement for every character in every
5701      * possible string takes up no more bytes than the character it
5702      * replaces, then it can be edited in place.  Otherwise the replacement
5703      * could overwrite a byte we are about to read, depending on the strings
5704      * being processed.  The comments and variable names here refer to this as
5705      * "growing".  Some inputs won't grow, and might even shrink under /d, but
5706      * some inputs could grow, so we have to assume any given one might grow.
5707      * On very long inputs, the temporary could eat up a lot of memory, so we
5708      * want to avoid it if possible.  For non-UTF-8 inputs, everything is
5709      * single-byte, so can be edited in place, unless there is something in the
5710      * pattern that could force it into UTF-8.  The inversion map makes it
5711      * feasible to determine this.  Previous versions of this code pretty much
5712      * punted on determining if UTF-8 could be edited in place.  Now, this code
5713      * is rigorous in making that determination.
5714      *
5715      * Another characteristic we need to know is whether the lhs and rhs are
5716      * identical.  If so, and no other flags are present, the only effect of
5717      * the tr/// is to count the characters present in the input that are
5718      * mentioned in the lhs string.  The implementation of that is easier and
5719      * runs faster than the more general case.  Normalizing here allows for
5720      * accurate determination of this.  Previously there were false negatives
5721      * possible.
5722      *
5723      * Instead of 'transliterated', the comments here use 'unmapped' for the
5724      * characters that are left unchanged by the operation; otherwise they are
5725      * 'mapped'
5726      *
5727      * The lhs of the tr/// is here referred to as the t side.
5728      * The rhs of the tr/// is here referred to as the r side.
5729      */
5730
5731     SV * const tstr = cSVOPx(expr)->op_sv;
5732     SV * const rstr = cSVOPx(repl)->op_sv;
5733     STRLEN tlen;
5734     STRLEN rlen;
5735     const U8 * t0 = (U8*)SvPV_const(tstr, tlen);
5736     const U8 * r0 = (U8*)SvPV_const(rstr, rlen);
5737     const U8 * t = t0;
5738     const U8 * r = r0;
5739     UV t_count = 0, r_count = 0;  /* Number of characters in search and
5740                                          replacement lists */
5741
5742     /* khw thinks some of the private flags for this op are quaintly named.
5743      * OPpTRANS_GROWS for example is TRUE if the replacement for some lhs
5744      * character when represented in UTF-8 is longer than the original
5745      * character's UTF-8 representation */
5746     const bool complement = cBOOL(o->op_private & OPpTRANS_COMPLEMENT);
5747     const bool squash     = cBOOL(o->op_private & OPpTRANS_SQUASH);
5748     const bool del        = cBOOL(o->op_private & OPpTRANS_DELETE);
5749
5750     /* Set to true if there is some character < 256 in the lhs that maps to
5751      * above 255.  If so, a non-UTF-8 match string can be forced into being in
5752      * UTF-8 by a tr/// operation. */
5753     bool can_force_utf8 = FALSE;
5754
5755     /* What is the maximum expansion factor in UTF-8 transliterations.  If a
5756      * 2-byte UTF-8 encoded character is to be replaced by a 3-byte one, its
5757      * expansion factor is 1.5.  This number is used at runtime to calculate
5758      * how much space to allocate for non-inplace transliterations.  Without
5759      * this number, the worst case is 14, which is extremely unlikely to happen
5760      * in real life, and could require significant memory overhead. */
5761     NV max_expansion = 1.;
5762
5763     UV t_range_count, r_range_count, min_range_count;
5764     UV* t_array;
5765     SV* t_invlist;
5766     UV* r_map;
5767     UV r_cp = 0, t_cp = 0;
5768     UV t_cp_end = (UV) -1;
5769     UV r_cp_end;
5770     Size_t len;
5771     AV* invmap;
5772     UV final_map = TR_UNLISTED;    /* The final character in the replacement
5773                                       list, updated as we go along.  Initialize
5774                                       to something illegal */
5775
5776     bool rstr_utf8 = cBOOL(SvUTF8(rstr));
5777     bool tstr_utf8 = cBOOL(SvUTF8(tstr));
5778
5779     const U8* tend = t + tlen;
5780     const U8* rend = r + rlen;
5781
5782     SV * inverted_tstr = NULL;
5783
5784     Size_t i;
5785     unsigned int pass2;
5786
5787     /* This routine implements detection of a transliteration having a longer
5788      * UTF-8 representation than its source, by partitioning all the possible
5789      * code points of the platform into equivalence classes of the same UTF-8
5790      * byte length in the first pass.  As it constructs the mappings, it carves
5791      * these up into smaller chunks, but doesn't merge any together.  This
5792      * makes it easy to find the instances it's looking for.  A second pass is
5793      * done after this has been determined which merges things together to
5794      * shrink the table for runtime.  The table below is used for both ASCII
5795      * and EBCDIC platforms.  On EBCDIC, the byte length is not monotonically
5796      * increasing for code points below 256.  To correct for that, the macro
5797      * CP_ADJUST defined below converts those code points to ASCII in the first
5798      * pass, and we use the ASCII partition values.  That works because the
5799      * growth factor will be unaffected, which is all that is calculated during
5800      * the first pass. */
5801     UV PL_partition_by_byte_length[] = {
5802         0,
5803         0x80,   /* Below this is 1 byte representations */
5804         (32 * (1UL << (    UTF_ACCUMULATION_SHIFT))),   /* 2 bytes below this */
5805         (16 * (1UL << (2 * UTF_ACCUMULATION_SHIFT))),   /* 3 bytes below this */
5806         ( 8 * (1UL << (3 * UTF_ACCUMULATION_SHIFT))),   /* 4 bytes below this */
5807         ( 4 * (1UL << (4 * UTF_ACCUMULATION_SHIFT))),   /* 5 bytes below this */
5808         ( 2 * (1UL << (5 * UTF_ACCUMULATION_SHIFT)))    /* 6 bytes below this */
5809
5810 #  ifdef UV_IS_QUAD
5811                                                     ,
5812         ( ((UV) 1U << (6 * UTF_ACCUMULATION_SHIFT)))    /* 7 bytes below this */
5813 #  endif
5814
5815     };
5816
5817     PERL_ARGS_ASSERT_PMTRANS;
5818
5819     PL_hints |= HINT_BLOCK_SCOPE;
5820
5821     /* If /c, the search list is sorted and complemented.  This is now done by
5822      * creating an inversion list from it, and then trivially inverting that.
5823      * The previous implementation used qsort, but creating the list
5824      * automatically keeps it sorted as we go along */
5825     if (complement) {
5826         UV start, end;
5827         SV * inverted_tlist = _new_invlist(tlen);
5828         Size_t temp_len;
5829
5830         DEBUG_y(PerlIO_printf(Perl_debug_log,
5831                     "%s: %d: tstr before inversion=\n%s\n",
5832                     __FILE__, __LINE__, _byte_dump_string(t, tend - t, 0)));
5833
5834         while (t < tend) {
5835
5836             /* Non-utf8 strings don't have ranges, so each character is listed
5837              * out */
5838             if (! tstr_utf8) {
5839                 inverted_tlist = add_cp_to_invlist(inverted_tlist, *t);
5840                 t++;
5841             }
5842             else {  /* But UTF-8 strings have been parsed in toke.c to have
5843                  * ranges if appropriate. */
5844                 UV t_cp;
5845                 Size_t t_char_len;
5846
5847                 /* Get the first character */
5848                 t_cp = valid_utf8_to_uvchr(t, &t_char_len);
5849                 t += t_char_len;
5850
5851                 /* If the next byte indicates that this wasn't the first
5852                  * element of a range, the range is just this one */
5853                 if (t >= tend || *t != RANGE_INDICATOR) {
5854                     inverted_tlist = add_cp_to_invlist(inverted_tlist, t_cp);
5855                 }
5856                 else { /* Otherwise, ignore the indicator byte, and get the
5857                           final element, and add the whole range */
5858                     t++;
5859                     t_cp_end = valid_utf8_to_uvchr(t, &t_char_len);
5860                     t += t_char_len;
5861
5862                     inverted_tlist = _add_range_to_invlist(inverted_tlist,
5863                                                       t_cp, t_cp_end);
5864                 }
5865             }
5866         } /* End of parse through tstr */
5867
5868         /* The inversion list is done; now invert it */
5869         _invlist_invert(inverted_tlist);
5870
5871         /* Now go through the inverted list and create a new tstr for the rest
5872          * of the routine to use.  Since the UTF-8 version can have ranges, and
5873          * can be much more compact than the non-UTF-8 version, we create the
5874          * string in UTF-8 even if not necessary.  (This is just an intermediate
5875          * value that gets thrown away anyway.) */
5876         invlist_iterinit(inverted_tlist);
5877         inverted_tstr = newSVpvs("");
5878         while (invlist_iternext(inverted_tlist, &start, &end)) {
5879             U8 temp[UTF8_MAXBYTES];
5880             U8 * temp_end_pos;
5881
5882             /* IV_MAX keeps things from going out of bounds */
5883             start = MIN(IV_MAX, start);
5884             end   = MIN(IV_MAX, end);
5885
5886             temp_end_pos = uvchr_to_utf8(temp, start);
5887             sv_catpvn(inverted_tstr, (char *) temp, temp_end_pos - temp);
5888
5889             if (start != end) {
5890                 Perl_sv_catpvf(aTHX_ inverted_tstr, "%c", RANGE_INDICATOR);
5891                 temp_end_pos = uvchr_to_utf8(temp, end);
5892                 sv_catpvn(inverted_tstr, (char *) temp, temp_end_pos - temp);
5893             }
5894         }
5895
5896         /* Set up so the remainder of the routine uses this complement, instead
5897          * of the actual input */
5898         t0 = t = (U8*)SvPV_const(inverted_tstr, temp_len);
5899         tend = t0 + temp_len;
5900         tstr_utf8 = TRUE;
5901
5902         SvREFCNT_dec_NN(inverted_tlist);
5903     }
5904
5905     /* For non-/d, an empty rhs means to use the lhs */
5906     if (rlen == 0 && ! del) {
5907         r0 = t0;
5908         rend = tend;
5909         rstr_utf8  = tstr_utf8;
5910     }
5911
5912     t_invlist = _new_invlist(1);
5913
5914     /* Initialize to a single range */
5915     t_invlist = _add_range_to_invlist(t_invlist, 0, UV_MAX);
5916
5917     /* Below, we parse the (potentially adjusted) input, creating the inversion
5918      * map.  This is done in two passes.  The first pass is just to determine
5919      * if the transliteration can be done in-place.  It can be done in place if
5920      * no possible inputs result in the replacement taking up more bytes than
5921      * the input.  To figure that out, in the first pass we start with all the
5922      * possible code points partitioned into ranges so that every code point in
5923      * a range occupies the same number of UTF-8 bytes as every other code
5924      * point in the range.  Constructing the inversion map doesn't merge ranges
5925      * together, but can split them into multiple ones.  Given the starting
5926      * partition, the ending state will also have the same characteristic,
5927      * namely that each code point in each partition requires the same number
5928      * of UTF-8 bytes to represent as every other code point in the same
5929      * partition.
5930      *
5931      * This partioning has been pre-compiled.  Copy it to initialize */
5932     len = C_ARRAY_LENGTH(PL_partition_by_byte_length);
5933     invlist_extend(t_invlist, len);
5934     t_array = invlist_array(t_invlist);
5935     Copy(PL_partition_by_byte_length, t_array, len, UV);
5936     invlist_set_len(t_invlist, len, *(get_invlist_offset_addr(t_invlist)));
5937     Newx(r_map, len + 1, UV);
5938
5939     /* The inversion map the first pass creates could be used as-is, but
5940      * generally would be larger and slower to run than the output of the
5941      * second pass.  */
5942
5943     for (pass2 = 0; pass2 < 2; pass2++) {
5944         if (pass2) {
5945             /* In the second pass, we start with a single range */
5946             t_invlist = _add_range_to_invlist(t_invlist, 0, UV_MAX);
5947             len = 1;
5948             t_array = invlist_array(t_invlist);
5949         }
5950
5951 /* As noted earlier, we convert EBCDIC code points to Unicode in the first pass
5952  * so as to get the well-behaved length 1 vs length 2 boundary.  Only code
5953  * points below 256 differ between the two character sets in this regard.  For
5954  * these, we also can't have any ranges, as they have to be individually
5955  * converted. */
5956 #ifdef EBCDIC
5957 #  define CP_ADJUST(x)          ((pass2) ? (x) : NATIVE_TO_UNI(x))
5958 #  define FORCE_RANGE_LEN_1(x)  ((pass2) ? 0 : ((x) < 256))
5959 #  define CP_SKIP(x)            ((pass2) ? UVCHR_SKIP(x) : OFFUNISKIP(x))
5960 #else
5961 #  define CP_ADJUST(x)          (x)
5962 #  define FORCE_RANGE_LEN_1(x)  0
5963 #  define CP_SKIP(x)            UVCHR_SKIP(x)
5964 #endif
5965
5966         /* And the mapping of each of the ranges is initialized.  Initially,
5967          * everything is TR_UNLISTED. */
5968         for (i = 0; i < len; i++) {
5969             r_map[i] = TR_UNLISTED;
5970         }
5971
5972         t = t0;
5973         t_count = 0;
5974         r = r0;
5975         r_count = 0;
5976         t_range_count = r_range_count = 0;
5977
5978         DEBUG_y(PerlIO_printf(Perl_debug_log, "%s: %d:\ntstr=%s\n",
5979                     __FILE__, __LINE__, _byte_dump_string(t, tend - t, 0)));
5980         DEBUG_y(PerlIO_printf(Perl_debug_log, "rstr=%s\n",
5981                                         _byte_dump_string(r, rend - r, 0)));
5982         DEBUG_y(PerlIO_printf(Perl_debug_log, "/c=%d; /s=%d; /d=%d\n",
5983                                                   complement, squash, del));
5984         DEBUG_y(invmap_dump(t_invlist, r_map));
5985
5986         /* Now go through the search list constructing an inversion map.  The
5987          * input is not necessarily in any particular order.  Making it an
5988          * inversion map orders it, potentially simplifying, and makes it easy
5989          * to deal with at run time.  This is the only place in core that
5990          * generates an inversion map; if others were introduced, it might be
5991          * better to create general purpose routines to handle them.
5992          * (Inversion maps are created in perl in other places.)
5993          *
5994          * An inversion map consists of two parallel arrays.  One is
5995          * essentially an inversion list: an ordered list of code points such
5996          * that each element gives the first code point of a range of
5997          * consecutive code points that map to the element in the other array
5998          * that has the same index as this one (in other words, the
5999          * corresponding element).  Thus the range extends up to (but not
6000          * including) the code point given by the next higher element.  In a
6001          * true inversion map, the corresponding element in the other array
6002          * gives the mapping of the first code point in the range, with the
6003          * understanding that the next higher code point in the inversion
6004          * list's range will map to the next higher code point in the map.
6005          *
6006          * So if at element [i], let's say we have:
6007          *
6008          *     t_invlist  r_map
6009          * [i]    A         a
6010          *
6011          * This means that A => a, B => b, C => c....  Let's say that the
6012          * situation is such that:
6013          *
6014          * [i+1]  L        -1
6015          *
6016          * This means the sequence that started at [i] stops at K => k.  This
6017          * illustrates that you need to look at the next element to find where
6018          * a sequence stops.  Except, the highest element in the inversion list
6019          * begins a range that is understood to extend to the platform's
6020          * infinity.
6021          *
6022          * This routine modifies traditional inversion maps to reserve two
6023          * mappings:
6024          *
6025          *  TR_UNLISTED (or -1) indicates that no code point in the range
6026          *      is listed in the tr/// searchlist.  At runtime, these are
6027          *      always passed through unchanged.  In the inversion map, all
6028          *      points in the range are mapped to -1, instead of increasing,
6029          *      like the 'L' in the example above.
6030          *
6031          *      We start the parse with every code point mapped to this, and as
6032          *      we parse and find ones that are listed in the search list, we
6033          *      carve out ranges as we go along that override that.
6034          *
6035          *  TR_SPECIAL_HANDLING (or -2) indicates that every code point in the
6036          *      range needs special handling.  Again, all code points in the
6037          *      range are mapped to -2, instead of increasing.
6038          *
6039          *      Under /d this value means the code point should be deleted from
6040          *      the transliteration when encountered.
6041          *
6042          *      Otherwise, it marks that every code point in the range is to
6043          *      map to the final character in the replacement list.  This
6044          *      happens only when the replacement list is shorter than the
6045          *      search one, so there are things in the search list that have no
6046          *      correspondence in the replacement list.  For example, in
6047          *      tr/a-z/A/, 'A' is the final value, and the inversion map
6048          *      generated for this would be like this:
6049          *          \0  =>  -1
6050          *          a   =>   A
6051          *          b-z =>  -2
6052          *          z+1 =>  -1
6053          *      'A' appears once, then the remainder of the range maps to -2.
6054          *      The use of -2 isn't strictly necessary, as an inversion map is
6055          *      capable of representing this situation, but not nearly so
6056          *      compactly, and this is actually quite commonly encountered.
6057          *      Indeed, the original design of this code used a full inversion
6058          *      map for this.  But things like
6059          *          tr/\0-\x{FFFF}/A/
6060          *      generated huge data structures, slowly, and the execution was
6061          *      also slow.  So the current scheme was implemented.
6062          *
6063          *  So, if the next element in our example is:
6064          *
6065          * [i+2]  Q        q
6066          *
6067          * Then all of L, M, N, O, and P map to TR_UNLISTED.  If the next
6068          * elements are
6069          *
6070          * [i+3]  R        z
6071          * [i+4]  S       TR_UNLISTED
6072          *
6073          * Then Q => q; R => z; and S => TR_UNLISTED.  If [i+4] (the 'S') is
6074          * the final element in the arrays, every code point from S to infinity
6075          * maps to TR_UNLISTED.
6076          *
6077          */
6078                            /* Finish up range started in what otherwise would
6079                             * have been the final iteration */
6080         while (t < tend || t_range_count > 0) {
6081             bool adjacent_to_range_above = FALSE;
6082             bool adjacent_to_range_below = FALSE;
6083
6084             bool merge_with_range_above = FALSE;
6085             bool merge_with_range_below = FALSE;
6086
6087             UV span, invmap_range_length_remaining;
6088             SSize_t j;
6089             Size_t i;
6090
6091             /* If we are in the middle of processing a range in the 'target'
6092              * side, the previous iteration has set us up.  Otherwise, look at
6093              * the next character in the search list */
6094             if (t_range_count <= 0) {
6095                 if (! tstr_utf8) {
6096
6097                     /* Here, not in the middle of a range, and not UTF-8.  The
6098                      * next code point is the single byte where we're at */
6099                     t_cp = CP_ADJUST(*t);
6100                     t_range_count = 1;
6101                     t++;
6102                 }
6103                 else {
6104                     Size_t t_char_len;
6105
6106                     /* Here, not in the middle of a range, and is UTF-8.  The
6107                      * next code point is the next UTF-8 char in the input.  We
6108                      * know the input is valid, because the toker constructed
6109                      * it */
6110                     t_cp = CP_ADJUST(valid_utf8_to_uvchr(t, &t_char_len));
6111                     t += t_char_len;
6112
6113                     /* UTF-8 strings (only) have been parsed in toke.c to have
6114                      * ranges.  See if the next byte indicates that this was
6115                      * the first element of a range.  If so, get the final
6116                      * element and calculate the range size.  If not, the range
6117                      * size is 1 */
6118                     if (   t < tend && *t == RANGE_INDICATOR
6119                         && ! FORCE_RANGE_LEN_1(t_cp))
6120                     {
6121                         t++;
6122                         t_range_count = valid_utf8_to_uvchr(t, &t_char_len)
6123                                       - t_cp + 1;
6124                         t += t_char_len;
6125                     }
6126                     else {
6127                         t_range_count = 1;
6128                     }
6129                 }
6130
6131                 /* Count the total number of listed code points * */
6132                 t_count += t_range_count;
6133             }
6134
6135             /* Similarly, get the next character in the replacement list */
6136             if (r_range_count <= 0) {
6137                 if (r >= rend) {
6138
6139                     /* But if we've exhausted the rhs, there is nothing to map
6140                      * to, except the special handling one, and we make the
6141                      * range the same size as the lhs one. */
6142                     r_cp = TR_SPECIAL_HANDLING;
6143                     r_range_count = t_range_count;
6144
6145                     if (! del) {
6146                         DEBUG_yv(PerlIO_printf(Perl_debug_log,
6147                                         "final_map =%" UVXf "\n", final_map));
6148                     }
6149                 }
6150                 else {
6151                     if (! rstr_utf8) {
6152                         r_cp = CP_ADJUST(*r);
6153                         r_range_count = 1;
6154                         r++;
6155                     }
6156                     else {
6157                         Size_t r_char_len;
6158
6159                         r_cp = CP_ADJUST(valid_utf8_to_uvchr(r, &r_char_len));
6160                         r += r_char_len;
6161                         if (   r < rend && *r == RANGE_INDICATOR
6162                             && ! FORCE_RANGE_LEN_1(r_cp))
6163                         {
6164                             r++;
6165                             r_range_count = valid_utf8_to_uvchr(r,
6166                                                     &r_char_len) - r_cp + 1;
6167                             r += r_char_len;
6168                         }
6169                         else {
6170                             r_range_count = 1;
6171                         }
6172                     }
6173
6174                     if (r_cp == TR_SPECIAL_HANDLING) {
6175                         r_range_count = t_range_count;
6176                     }
6177
6178                     /* This is the final character so far */
6179                     final_map = r_cp + r_range_count - 1;
6180
6181                     r_count += r_range_count;
6182                 }
6183             }
6184
6185             /* Here, we have the next things ready in both sides.  They are
6186              * potentially ranges.  We try to process as big a chunk as
6187              * possible at once, but the lhs and rhs must be synchronized, so
6188              * things like tr/A-Z/a-ij-z/ will need to be processed in 2 chunks
6189              * */
6190             min_range_count = MIN(t_range_count, r_range_count);
6191
6192             /* Search the inversion list for the entry that contains the input
6193              * code point <cp>.  The inversion map was initialized to cover the
6194              * entire range of possible inputs, so this should not fail.  So
6195              * the return value is the index into the list's array of the range
6196              * that contains <cp>, that is, 'i' such that array[i] <= cp <
6197              * array[i+1] */
6198             j = _invlist_search(t_invlist, t_cp);
6199             assert(j >= 0);
6200             i = j;
6201
6202             /* Here, the data structure might look like:
6203              *
6204              * index    t   r     Meaning
6205              * [i-1]    J   j   # J-L => j-l
6206              * [i]      M  -1   # M => default; as do N, O, P, Q
6207              * [i+1]    R   x   # R => x, S => x+1, T => x+2
6208              * [i+2]    U   y   # U => y, V => y+1, ...
6209              * ...
6210              * [-1]     Z  -1   # Z => default; as do Z+1, ... infinity
6211              *
6212              * where 'x' and 'y' above are not to be taken literally.
6213              *
6214              * The maximum chunk we can handle in this loop iteration, is the
6215              * smallest of the three components: the lhs 't_', the rhs 'r_',
6216              * and the remainder of the range in element [i].  (In pass 1, that
6217              * range will have everything in it be of the same class; we can't
6218              * cross into another class.)  'min_range_count' already contains
6219              * the smallest of the first two values.  The final one is
6220              * irrelevant if the map is to the special indicator */
6221
6222             invmap_range_length_remaining = (i + 1 < len)
6223                                             ? t_array[i+1] - t_cp
6224                                             : IV_MAX - t_cp;
6225             span = MAX(1, MIN(min_range_count, invmap_range_length_remaining));
6226
6227             /* The end point of this chunk is where we are, plus the span, but
6228              * never larger than the platform's infinity */
6229             t_cp_end = MIN(IV_MAX, t_cp + span - 1);
6230
6231             if (r_cp == TR_SPECIAL_HANDLING) {
6232
6233                 /* If unmatched lhs code points map to the final map, use that
6234                  * value.  This being set to TR_SPECIAL_HANDLING indicates that
6235                  * we don't have a final map: unmatched lhs code points are
6236                  * simply deleted */
6237                 r_cp_end = (del) ? TR_SPECIAL_HANDLING : final_map;
6238             }
6239             else {
6240                 r_cp_end = MIN(IV_MAX, r_cp + span - 1);
6241
6242                 /* If something on the lhs is below 256, and something on the
6243                  * rhs is above, there is a potential mapping here across that
6244                  * boundary.  Indeed the only way there isn't is if both sides
6245                  * start at the same point.  That means they both cross at the
6246                  * same time.  But otherwise one crosses before the other */
6247                 if (t_cp < 256 && r_cp_end > 255 && r_cp != t_cp) {
6248                     can_force_utf8 = TRUE;
6249                 }
6250             }
6251
6252             /* If a character appears in the search list more than once, the
6253              * 2nd and succeeding occurrences are ignored, so only do this
6254              * range if haven't already processed this character.  (The range
6255              * has been set up so that all members in it will be of the same
6256              * ilk) */
6257             if (r_map[i] == TR_UNLISTED) {
6258                 DEBUG_yv(PerlIO_printf(Perl_debug_log,
6259                     "Processing %" UVxf "-%" UVxf " => %" UVxf "-%" UVxf "\n",
6260                     t_cp, t_cp_end, r_cp, r_cp_end));
6261
6262                 /* This is the first definition for this chunk, hence is valid
6263                  * and needs to be processed.  Here and in the comments below,
6264                  * we use the above sample data.  The t_cp chunk must be any
6265                  * contiguous subset of M, N, O, P, and/or Q.
6266                  *
6267                  * In the first pass, calculate if there is any possible input
6268                  * string that has a character whose transliteration will be
6269                  * longer than it.  If none, the transliteration may be done
6270                  * in-place, as it can't write over a so-far unread byte.
6271                  * Otherwise, a copy must first be made.  This could be
6272                  * expensive for long inputs.
6273                  *
6274                  * In the first pass, the t_invlist has been partitioned so
6275                  * that all elements in any single range have the same number
6276                  * of bytes in their UTF-8 representations.  And the r space is
6277                  * either a single byte, or a range of strictly monotonically
6278                  * increasing code points.  So the final element in the range
6279                  * will be represented by no fewer bytes than the initial one.
6280                  * That means that if the final code point in the t range has
6281                  * at least as many bytes as the final code point in the r,
6282                  * then all code points in the t range have at least as many
6283                  * bytes as their corresponding r range element.  But if that's
6284                  * not true, the transliteration of at least the final code
6285                  * point grows in length.  As an example, suppose we had
6286                  *      tr/\x{fff0}-\x{fff1}/\x{ffff}-\x{10000}/
6287                  * The UTF-8 for all but 10000 occupies 3 bytes on ASCII
6288                  * platforms.  We have deliberately set up the data structure
6289                  * so that any range in the lhs gets split into chunks for
6290                  * processing, such that every code point in a chunk has the
6291                  * same number of UTF-8 bytes.  We only have to check the final
6292                  * code point in the rhs against any code point in the lhs. */
6293                 if ( ! pass2
6294                     && r_cp_end != TR_SPECIAL_HANDLING
6295                     && CP_SKIP(t_cp_end) < CP_SKIP(r_cp_end))
6296                 {
6297                     /* Here, we will need to make a copy of the input string
6298                      * before doing the transliteration.  The worst possible
6299                      * case is an expansion ratio of 14:1. This is rare, and
6300                      * we'd rather allocate only the necessary amount of extra
6301                      * memory for that copy.  We can calculate the worst case
6302                      * for this particular transliteration is by keeping track
6303                      * of the expansion factor for each range.
6304                      *
6305                      * Consider tr/\xCB/\X{E000}/.  The maximum expansion
6306                      * factor is 1 byte going to 3 if the target string is not
6307                      * UTF-8, but 2 bytes going to 3 if it is in UTF-8.  We
6308                      * could pass two different values so doop could choose
6309                      * based on the UTF-8ness of the target.  But khw thinks
6310                      * (perhaps wrongly) that is overkill.  It is used only to
6311                      * make sure we malloc enough space.
6312                      *
6313                      * If no target string can force the result to be UTF-8,
6314                      * then we don't have to worry about the case of the target
6315                      * string not being UTF-8 */
6316                     NV t_size = (can_force_utf8 && t_cp < 256)
6317                                 ? 1
6318                                 : CP_SKIP(t_cp_end);
6319                     NV ratio = CP_SKIP(r_cp_end) / t_size;
6320
6321                     o->op_private |= OPpTRANS_GROWS;
6322
6323                     /* Now that we know it grows, we can keep track of the
6324                      * largest ratio */
6325                     if (ratio > max_expansion) {
6326                         max_expansion = ratio;
6327                         DEBUG_y(PerlIO_printf(Perl_debug_log,
6328                                         "New expansion factor: %" NVgf "\n",
6329                                         max_expansion));
6330                     }
6331                 }
6332
6333                 /* The very first range is marked as adjacent to the
6334                  * non-existent range below it, as it causes things to "just
6335                  * work" (TradeMark)
6336                  *
6337                  * If the lowest code point in this chunk is M, it adjoins the
6338                  * J-L range */
6339                 if (t_cp == t_array[i]) {
6340                     adjacent_to_range_below = TRUE;
6341
6342                     /* And if the map has the same offset from the beginning of
6343                      * the range as does this new code point (or both are for
6344                      * TR_SPECIAL_HANDLING), this chunk can be completely
6345                      * merged with the range below.  EXCEPT, in the first pass,
6346                      * we don't merge ranges whose UTF-8 byte representations
6347                      * have different lengths, so that we can more easily
6348                      * detect if a replacement is longer than the source, that
6349                      * is if it 'grows'.  But in the 2nd pass, there's no
6350                      * reason to not merge */
6351                     if (   (i > 0 && (   pass2
6352                                       || CP_SKIP(t_array[i-1])
6353                                                             == CP_SKIP(t_cp)))
6354                         && (   (   r_cp == TR_SPECIAL_HANDLING
6355                                 && r_map[i-1] == TR_SPECIAL_HANDLING)
6356                             || (   r_cp != TR_SPECIAL_HANDLING
6357                                 && r_cp - r_map[i-1] == t_cp - t_array[i-1])))
6358                     {
6359                         merge_with_range_below = TRUE;
6360                     }
6361                 }
6362
6363                 /* Similarly, if the highest code point in this chunk is 'Q',
6364                  * it adjoins the range above, and if the map is suitable, can
6365                  * be merged with it */
6366                 if (    t_cp_end >= IV_MAX - 1
6367                     || (   i + 1 < len
6368                         && t_cp_end + 1 == t_array[i+1]))
6369                 {
6370                     adjacent_to_range_above = TRUE;
6371                     if (i + 1 < len)
6372                     if (    (   pass2
6373                              || CP_SKIP(t_cp) == CP_SKIP(t_array[i+1]))
6374                         && (   (   r_cp == TR_SPECIAL_HANDLING
6375                                 && r_map[i+1] == (UV) TR_SPECIAL_HANDLING)
6376                             || (   r_cp != TR_SPECIAL_HANDLING
6377                                 && r_cp_end == r_map[i+1] - 1)))
6378                     {
6379                         merge_with_range_above = TRUE;
6380                     }
6381                 }
6382
6383                 if (merge_with_range_below && merge_with_range_above) {
6384
6385                     /* Here the new chunk looks like M => m, ... Q => q; and
6386                      * the range above is like R => r, ....  Thus, the [i-1]
6387                      * and [i+1] ranges should be seamlessly melded so the
6388                      * result looks like
6389                      *
6390                      * [i-1]    J   j   # J-T => j-t
6391                      * [i]      U   y   # U => y, V => y+1, ...
6392                      * ...
6393                      * [-1]     Z  -1   # Z => default; as do Z+1, ... infinity
6394                      */
6395                     Move(t_array + i + 2, t_array + i, len - i - 2, UV);
6396                     Move(r_map   + i + 2, r_map   + i, len - i - 2, UV);
6397                     len -= 2;
6398                     invlist_set_len(t_invlist,
6399                                     len,
6400                                     *(get_invlist_offset_addr(t_invlist)));
6401                 }
6402                 else if (merge_with_range_below) {
6403
6404                     /* Here the new chunk looks like M => m, .... But either
6405                      * (or both) it doesn't extend all the way up through Q; or
6406                      * the range above doesn't start with R => r. */
6407                     if (! adjacent_to_range_above) {
6408
6409                         /* In the first case, let's say the new chunk extends
6410                          * through O.  We then want:
6411                          *
6412                          * [i-1]    J   j   # J-O => j-o
6413                          * [i]      P  -1   # P => -1, Q => -1
6414                          * [i+1]    R   x   # R => x, S => x+1, T => x+2
6415                          * [i+2]    U   y   # U => y, V => y+1, ...
6416                          * ...
6417                          * [-1]     Z  -1   # Z => default; as do Z+1, ...
6418                          *                                            infinity
6419                          */
6420                         t_array[i] = t_cp_end + 1;
6421                         r_map[i] = TR_UNLISTED;
6422                     }
6423                     else { /* Adjoins the range above, but can't merge with it
6424                               (because 'x' is not the next map after q) */
6425                         /*
6426                          * [i-1]    J   j   # J-Q => j-q
6427                          * [i]      R   x   # R => x, S => x+1, T => x+2
6428                          * [i+1]    U   y   # U => y, V => y+1, ...
6429                          * ...
6430                          * [-1]     Z  -1   # Z => default; as do Z+1, ...
6431                          *                                          infinity
6432                          */
6433
6434                         Move(t_array + i + 1, t_array + i, len - i - 1, UV);
6435                         Move(r_map + i + 1, r_map + i, len - i - 1, UV);
6436                         len--;
6437                         invlist_set_len(t_invlist, len,
6438                                         *(get_invlist_offset_addr(t_invlist)));
6439                     }
6440                 }
6441                 else if (merge_with_range_above) {
6442
6443                     /* Here the new chunk ends with Q => q, and the range above
6444                      * must start with R => r, so the two can be merged. But
6445                      * either (or both) the new chunk doesn't extend all the
6446                      * way down to M; or the mapping of the final code point
6447                      * range below isn't m */
6448                     if (! adjacent_to_range_below) {
6449
6450                         /* In the first case, let's assume the new chunk starts
6451                          * with P => p.  Then, because it's merge-able with the
6452                          * range above, that range must be R => r.  We want:
6453                          *
6454                          * [i-1]    J   j   # J-L => j-l
6455                          * [i]      M  -1   # M => -1, N => -1
6456                          * [i+1]    P   p   # P-T => p-t
6457                          * [i+2]    U   y   # U => y, V => y+1, ...
6458                          * ...
6459                          * [-1]     Z  -1   # Z => default; as do Z+1, ...
6460                          *                                          infinity
6461                          */
6462                         t_array[i+1] = t_cp;
6463                         r_map[i+1] = r_cp;
6464                     }
6465                     else { /* Adjoins the range below, but can't merge with it
6466                             */
6467                         /*
6468                          * [i-1]    J   j   # J-L => j-l
6469                          * [i]      M   x   # M-T => x-5 .. x+2
6470                          * [i+1]    U   y   # U => y, V => y+1, ...
6471                          * ...
6472                          * [-1]     Z  -1   # Z => default; as do Z+1, ...
6473                          *                                          infinity
6474                          */
6475                         Move(t_array + i + 1, t_array + i, len - i - 1, UV);
6476                         Move(r_map   + i + 1, r_map   + i, len - i - 1, UV);
6477                         len--;
6478                         t_array[i] = t_cp;
6479                         r_map[i] = r_cp;
6480                         invlist_set_len(t_invlist, len,
6481                                         *(get_invlist_offset_addr(t_invlist)));
6482                     }
6483                 }
6484                 else if (adjacent_to_range_below && adjacent_to_range_above) {
6485                     /* The new chunk completely fills the gap between the
6486                      * ranges on either side, but can't merge with either of
6487                      * them.
6488                      *
6489                      * [i-1]    J   j   # J-L => j-l
6490                      * [i]      M   z   # M => z, N => z+1 ... Q => z+4
6491                      * [i+1]    R   x   # R => x, S => x+1, T => x+2
6492                      * [i+2]    U   y   # U => y, V => y+1, ...
6493                      * ...
6494                      * [-1]     Z  -1   # Z => default; as do Z+1, ... infinity
6495                      */
6496                     r_map[i] = r_cp;
6497                 }
6498                 else if (adjacent_to_range_below) {
6499                     /* The new chunk adjoins the range below, but not the range
6500                      * above, and can't merge.  Let's assume the chunk ends at
6501                      * O.
6502                      *
6503                      * [i-1]    J   j   # J-L => j-l
6504                      * [i]      M   z   # M => z, N => z+1, O => z+2
6505                      * [i+1]    P   -1  # P => -1, Q => -1
6506                      * [i+2]    R   x   # R => x, S => x+1, T => x+2
6507                      * [i+3]    U   y   # U => y, V => y+1, ...
6508                      * ...
6509                      * [-w]     Z  -1   # Z => default; as do Z+1, ... infinity
6510                      */
6511                     invlist_extend(t_invlist, len + 1);
6512                     t_array = invlist_array(t_invlist);
6513                     Renew(r_map, len + 1, UV);
6514
6515                     Move(t_array + i + 1, t_array + i + 2, len - i - 1, UV);
6516                     Move(r_map + i + 1,   r_map   + i + 2, len - i - 1, UV);
6517                     r_map[i] = r_cp;
6518                     t_array[i+1] = t_cp_end + 1;
6519                     r_map[i+1] = TR_UNLISTED;
6520                     len++;
6521                     invlist_set_len(t_invlist, len,
6522                                     *(get_invlist_offset_addr(t_invlist)));
6523                 }
6524                 else if (adjacent_to_range_above) {
6525                     /* The new chunk adjoins the range above, but not the range
6526                      * below, and can't merge.  Let's assume the new chunk
6527                      * starts at O
6528                      *
6529                      * [i-1]    J   j   # J-L => j-l
6530                      * [i]      M  -1   # M => default, N => default
6531                      * [i+1]    O   z   # O => z, P => z+1, Q => z+2
6532                      * [i+2]    R   x   # R => x, S => x+1, T => x+2
6533                      * [i+3]    U   y   # U => y, V => y+1, ...
6534                      * ...
6535                      * [-1]     Z  -1   # Z => default; as do Z+1, ... infinity
6536                      */
6537                     invlist_extend(t_invlist, len + 1);
6538                     t_array = invlist_array(t_invlist);
6539                     Renew(r_map, len + 1, UV);
6540
6541                     Move(t_array + i + 1, t_array + i + 2, len - i - 1, UV);
6542                     Move(r_map   + i + 1, r_map   + i + 2, len - i - 1, UV);
6543                     t_array[i+1] = t_cp;
6544                     r_map[i+1] = r_cp;
6545                     len++;
6546                     invlist_set_len(t_invlist, len,
6547                                     *(get_invlist_offset_addr(t_invlist)));
6548                 }
6549                 else {
6550                     /* The new chunk adjoins neither the range above, nor the
6551                      * range below.  Lets assume it is N..P => n..p
6552                      *
6553                      * [i-1]    J   j   # J-L => j-l
6554                      * [i]      M  -1   # M => default
6555                      * [i+1]    N   n   # N..P => n..p
6556                      * [i+2]    Q  -1   # Q => default
6557                      * [i+3]    R   x   # R => x, S => x+1, T => x+2
6558                      * [i+4]    U   y   # U => y, V => y+1, ...
6559                      * ...
6560                      * [-1]     Z  -1   # Z => default; as do Z+1, ... infinity
6561                      */
6562
6563                     DEBUG_yv(PerlIO_printf(Perl_debug_log,
6564                                         "Before fixing up: len=%d, i=%d\n",
6565                                         (int) len, (int) i));
6566                     DEBUG_yv(invmap_dump(t_invlist, r_map));
6567
6568                     invlist_extend(t_invlist, len + 2);
6569                     t_array = invlist_array(t_invlist);
6570                     Renew(r_map, len + 2, UV);
6571
6572                     Move(t_array + i + 1,
6573                          t_array + i + 2 + 1, len - i - (2 - 1), UV);
6574                     Move(r_map   + i + 1,
6575                          r_map   + i + 2 + 1, len - i - (2 - 1), UV);
6576
6577                     len += 2;
6578                     invlist_set_len(t_invlist, len,
6579                                     *(get_invlist_offset_addr(t_invlist)));
6580
6581                     t_array[i+1] = t_cp;
6582                     r_map[i+1] = r_cp;
6583
6584                     t_array[i+2] = t_cp_end + 1;
6585                     r_map[i+2] = TR_UNLISTED;
6586                 }
6587                 DEBUG_yv(PerlIO_printf(Perl_debug_log,
6588                           "After iteration: span=%" UVuf ", t_range_count=%"
6589                           UVuf " r_range_count=%" UVuf "\n",
6590                           span, t_range_count, r_range_count));
6591                 DEBUG_yv(invmap_dump(t_invlist, r_map));
6592             } /* End of this chunk needs to be processed */
6593
6594             /* Done with this chunk. */
6595             t_cp += span;
6596             if (t_cp >= IV_MAX) {
6597                 break;
6598             }
6599             t_range_count -= span;
6600             if (r_cp != TR_SPECIAL_HANDLING) {
6601                 r_cp += span;
6602                 r_range_count -= span;
6603             }
6604             else {
6605                 r_range_count = 0;
6606             }
6607
6608         } /* End of loop through the search list */
6609
6610         /* We don't need an exact count, but we do need to know if there is
6611          * anything left over in the replacement list.  So, just assume it's
6612          * one byte per character */
6613         if (rend > r) {
6614             r_count++;
6615         }
6616     } /* End of passes */
6617
6618     SvREFCNT_dec(inverted_tstr);
6619
6620     DEBUG_y(PerlIO_printf(Perl_debug_log, "After everything: \n"));
6621     DEBUG_y(invmap_dump(t_invlist, r_map));
6622
6623     /* We now have normalized the input into an inversion map.
6624      *
6625      * See if the lhs and rhs are equivalent.  If so, this tr/// is a no-op
6626      * except for the count, and streamlined runtime code can be used */
6627     if (!del && !squash) {
6628
6629         /* They are identical if they point to the same address, or if
6630          * everything maps to UNLISTED or to itself.  This catches things that
6631          * not looking at the normalized inversion map doesn't catch, like
6632          * tr/aa/ab/ or tr/\x{100}-\x{104}/\x{100}-\x{102}\x{103}-\x{104}  */
6633         if (r0 != t0) {
6634             for (i = 0; i < len; i++) {
6635                 if (r_map[i] != TR_UNLISTED && r_map[i] != t_array[i]) {
6636                     goto done_identical_check;
6637                 }
6638             }
6639         }
6640
6641         /* Here have gone through entire list, and didn't find any
6642          * non-identical mappings */
6643         o->op_private |= OPpTRANS_IDENTICAL;
6644
6645       done_identical_check: ;
6646     }
6647
6648     t_array = invlist_array(t_invlist);
6649
6650     /* If has components above 255, we generally need to use the inversion map
6651      * implementation */
6652     if (   can_force_utf8
6653         || (   len > 0
6654             && t_array[len-1] > 255
6655                  /* If the final range is 0x100-INFINITY and is a special
6656                   * mapping, the table implementation can handle it */
6657             && ! (   t_array[len-1] == 256
6658                   && (   r_map[len-1] == TR_UNLISTED
6659                       || r_map[len-1] == TR_SPECIAL_HANDLING))))
6660     {
6661         SV* r_map_sv;
6662         SV* temp_sv;
6663
6664         /* A UTF-8 op is generated, indicated by this flag.  This op is an
6665          * sv_op */
6666         o->op_private |= OPpTRANS_USE_SVOP;
6667
6668         if (can_force_utf8) {
6669             o->op_private |= OPpTRANS_CAN_FORCE_UTF8;
6670         }
6671
6672         /* The inversion map is pushed; first the list. */
6673         invmap = MUTABLE_AV(newAV());
6674
6675         SvREADONLY_on(t_invlist);
6676         av_push(invmap, t_invlist);
6677
6678         /* 2nd is the mapping */
6679         r_map_sv = newSVpvn((char *) r_map, len * sizeof(UV));
6680         SvREADONLY_on(r_map_sv);
6681         av_push(invmap, r_map_sv);
6682
6683         /* 3rd is the max possible expansion factor */
6684         temp_sv = newSVnv(max_expansion);
6685         SvREADONLY_on(temp_sv);
6686         av_push(invmap, temp_sv);
6687
6688         /* Characters that are in the search list, but not in the replacement
6689          * list are mapped to the final character in the replacement list */
6690         if (! del && r_count < t_count) {
6691             temp_sv = newSVuv(final_map);
6692             SvREADONLY_on(temp_sv);
6693             av_push(invmap, temp_sv);
6694         }
6695
6696 #ifdef USE_ITHREADS
6697         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
6698         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
6699         PAD_SETSV(cPADOPo->op_padix, (SV *) invmap);
6700         SvPADTMP_on(invmap);
6701         SvREADONLY_on(invmap);
6702 #else
6703         cSVOPo->op_sv = (SV *) invmap;
6704 #endif
6705
6706     }
6707     else {
6708         OPtrans_map *tbl;
6709         unsigned short i;
6710
6711         /* The OPtrans_map struct already contains one slot; hence the -1. */
6712         SSize_t struct_size = sizeof(OPtrans_map)
6713                             + (256 - 1 + 1)*sizeof(short);
6714
6715         /* Non-utf8 case: set o->op_pv to point to a simple 256+ entry lookup
6716          * table. Entries with the value TR_UNMAPPED indicate chars not to be
6717          * translated, while TR_DELETE indicates a search char without a
6718          * corresponding replacement char under /d.
6719          *
6720          * In addition, an extra slot at the end is used to store the final
6721          * repeating char, or TR_R_EMPTY under an empty replacement list, or
6722          * TR_DELETE under /d; which makes the runtime code easier. */
6723
6724         /* Indicate this is an op_pv */
6725         o->op_private &= ~OPpTRANS_USE_SVOP;
6726
6727         tbl = (OPtrans_map*)PerlMemShared_calloc(struct_size, 1);
6728         tbl->size = 256;
6729         cPVOPo->op_pv = (char*)tbl;
6730
6731         for (i = 0; i < len; i++) {
6732             STATIC_ASSERT_DECL(TR_SPECIAL_HANDLING == TR_DELETE);
6733             short upper = i >= len - 1 ? 256 : (short) t_array[i+1];
6734             short to = (short) r_map[i];
6735             short j;
6736             bool do_increment = TRUE;
6737
6738             /* Any code points above our limit should be irrelevant */
6739             if (t_array[i] >= tbl->size) break;
6740
6741             /* Set up the map */
6742             if (to == (short) TR_SPECIAL_HANDLING && ! del) {
6743                 to = (short) final_map;
6744                 do_increment = FALSE;
6745             }
6746             else if (to < 0) {
6747                 do_increment = FALSE;
6748             }
6749
6750             /* Create a map for everything in this range.  The value increases
6751              * except for the special cases */
6752             for (j = (short) t_array[i]; j < upper; j++) {
6753                 tbl->map[j] = to;
6754                 if (do_increment) to++;
6755             }
6756         }
6757
6758         tbl->map[tbl->size] = del
6759                               ? (short) TR_DELETE
6760                               : (short) rlen
6761                                 ? (short) final_map
6762                                 : (short) TR_R_EMPTY;
6763         DEBUG_y(PerlIO_printf(Perl_debug_log,"%s: %d\n", __FILE__, __LINE__));
6764         for (i = 0; i < tbl->size; i++) {
6765             if (tbl->map[i] < 0) {
6766                 DEBUG_y(PerlIO_printf(Perl_debug_log," %02x=>%d",
6767                                                 (unsigned) i, tbl->map[i]));
6768             }
6769             else {
6770                 DEBUG_y(PerlIO_printf(Perl_debug_log," %02x=>%02x",
6771                                                 (unsigned) i, tbl->map[i]));
6772             }
6773             if ((i+1) % 8 == 0 || i + 1 == (short) tbl->size) {
6774                 DEBUG_y(PerlIO_printf(Perl_debug_log,"\n"));
6775             }
6776         }
6777         DEBUG_y(PerlIO_printf(Perl_debug_log,"Final map 0x%x=>%02x\n",
6778                                 (unsigned) tbl->size, tbl->map[tbl->size]));
6779
6780         SvREFCNT_dec(t_invlist);
6781
6782 #if 0   /* code that added excess above-255 chars at the end of the table, in
6783            case we ever want to not use the inversion map implementation for
6784            this */
6785
6786         ASSUME(j <= rlen);
6787         excess = rlen - j;
6788
6789         if (excess) {
6790             /* More replacement chars than search chars:
6791              * store excess replacement chars at end of main table.
6792              */
6793
6794             struct_size += excess;
6795             tbl = (OPtrans_map*)PerlMemShared_realloc(tbl,
6796                         struct_size + excess * sizeof(short));
6797             tbl->size += excess;
6798             cPVOPo->op_pv = (char*)tbl;
6799
6800             for (i = 0; i < excess; i++)
6801                 tbl->map[i + 256] = r[j+i];
6802         }
6803         else {
6804             /* no more replacement chars than search chars */
6805         }
6806 #endif
6807
6808     }
6809
6810     DEBUG_y(PerlIO_printf(Perl_debug_log,
6811             "/d=%d, /s=%d, /c=%d, identical=%d, grows=%d,"
6812             " use_svop=%d, can_force_utf8=%d,\nexpansion=%" NVgf "\n",
6813             del, squash, complement,
6814             cBOOL(o->op_private & OPpTRANS_IDENTICAL),
6815             cBOOL(o->op_private & OPpTRANS_USE_SVOP),
6816             cBOOL(o->op_private & OPpTRANS_GROWS),
6817             cBOOL(o->op_private & OPpTRANS_CAN_FORCE_UTF8),
6818             max_expansion));
6819
6820     Safefree(r_map);
6821
6822     if(del && rlen != 0 && r_count == t_count) {
6823         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
6824     } else if(r_count > t_count) {
6825         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
6826     }
6827
6828     op_free(expr);
6829     op_free(repl);
6830
6831     return o;
6832 }
6833
6834
6835 /*
6836 =for apidoc newPMOP
6837
6838 Constructs, checks, and returns an op of any pattern matching type.
6839 C<type> is the opcode.  C<flags> gives the eight bits of C<op_flags>
6840 and, shifted up eight bits, the eight bits of C<op_private>.
6841
6842 =cut
6843 */
6844
6845 OP *
6846 Perl_newPMOP(pTHX_ I32 type, I32 flags)
6847 {
6848     PMOP *pmop;
6849
6850     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
6851         || type == OP_CUSTOM);
6852
6853     NewOp(1101, pmop, 1, PMOP);
6854     OpTYPE_set(pmop, type);
6855     pmop->op_flags = (U8)flags;
6856     pmop->op_private = (U8)(0 | (flags >> 8));
6857     if (PL_opargs[type] & OA_RETSCALAR)
6858         scalar((OP *)pmop);
6859
6860     if (PL_hints & HINT_RE_TAINT)
6861         pmop->op_pmflags |= PMf_RETAINT;
6862 #ifdef USE_LOCALE_CTYPE
6863     if (IN_LC_COMPILETIME(LC_CTYPE)) {
6864         set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
6865     }
6866     else
6867 #endif
6868          if (IN_UNI_8_BIT) {
6869         set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
6870     }
6871     if (PL_hints & HINT_RE_FLAGS) {
6872         SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
6873          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
6874         );
6875         if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
6876         reflags = Perl_refcounted_he_fetch_pvn(aTHX_
6877          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
6878         );
6879         if (reflags && SvOK(reflags)) {
6880             set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
6881         }
6882     }
6883
6884
6885 #ifdef USE_ITHREADS
6886     assert(SvPOK(PL_regex_pad[0]));
6887     if (SvCUR(PL_regex_pad[0])) {
6888         /* Pop off the "packed" IV from the end.  */
6889         SV *const repointer_list = PL_regex_pad[0];
6890         const char *p = SvEND(repointer_list) - sizeof(IV);
6891         const IV offset = *((IV*)p);
6892
6893         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
6894
6895         SvEND_set(repointer_list, p);
6896
6897         pmop->op_pmoffset = offset;
6898         /* This slot should be free, so assert this:  */
6899         assert(PL_regex_pad[offset] == &PL_sv_undef);
6900     } else {
6901         SV * const repointer = &PL_sv_undef;
6902         av_push(PL_regex_padav, repointer);
6903         pmop->op_pmoffset = av_top_index(PL_regex_padav);
6904         PL_regex_pad = AvARRAY(PL_regex_padav);
6905     }
6906 #endif
6907
6908     return CHECKOP(type, pmop);
6909 }
6910
6911 static void
6912 S_set_haseval(pTHX)
6913 {
6914     PADOFFSET i = 1;
6915     PL_cv_has_eval = 1;
6916     /* Any pad names in scope are potentially lvalues.  */
6917     for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
6918         PADNAME *pn = PAD_COMPNAME_SV(i);
6919         if (!pn || !PadnameLEN(pn))
6920             continue;
6921         if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
6922             S_mark_padname_lvalue(aTHX_ pn);
6923     }
6924 }
6925
6926 /* Given some sort of match op o, and an expression expr containing a
6927  * pattern, either compile expr into a regex and attach it to o (if it's
6928  * constant), or convert expr into a runtime regcomp op sequence (if it's
6929  * not)
6930  *
6931  * Flags currently has 2 bits of meaning:
6932  * 1: isreg indicates that the pattern is part of a regex construct, eg
6933  *      $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
6934  *      split "pattern", which aren't. In the former case, expr will be a list
6935  *      if the pattern contains more than one term (eg /a$b/).
6936  * 2: The pattern is for a split.
6937  *
6938  * When the pattern has been compiled within a new anon CV (for
6939  * qr/(?{...})/ ), then floor indicates the savestack level just before
6940  * the new sub was created
6941  *
6942  * tr/// is also handled.
6943  */
6944
6945 OP *
6946 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor)
6947 {
6948     PMOP *pm;
6949     LOGOP *rcop;
6950     I32 repl_has_vars = 0;
6951     bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
6952     bool is_compiletime;
6953     bool has_code;
6954     bool isreg    = cBOOL(flags & 1);
6955     bool is_split = cBOOL(flags & 2);
6956
6957     PERL_ARGS_ASSERT_PMRUNTIME;
6958
6959     if (is_trans) {
6960         return pmtrans(o, expr, repl);
6961     }
6962
6963     /* find whether we have any runtime or code elements;
6964      * at the same time, temporarily set the op_next of each DO block;
6965      * then when we LINKLIST, this will cause the DO blocks to be excluded
6966      * from the op_next chain (and from having LINKLIST recursively
6967      * applied to them). We fix up the DOs specially later */
6968
6969     is_compiletime = 1;
6970     has_code = 0;
6971     if (expr->op_type == OP_LIST) {
6972         OP *child;
6973         for (child = cLISTOPx(expr)->op_first; child; child = OpSIBLING(child)) {
6974             if (child->op_type == OP_NULL && (child->op_flags & OPf_SPECIAL)) {
6975                 has_code = 1;
6976                 assert(!child->op_next);
6977                 if (UNLIKELY(!OpHAS_SIBLING(child))) {
6978                     assert(PL_parser && PL_parser->error_count);
6979                     /* This can happen with qr/ (?{(^{})/.  Just fake up
6980                        the op we were expecting to see, to avoid crashing
6981                        elsewhere.  */
6982                     op_sibling_splice(expr, child, 0,
6983                               newSVOP(OP_CONST, 0, &PL_sv_no));
6984                 }
6985                 child->op_next = OpSIBLING(child);
6986             }
6987             else if (child->op_type != OP_CONST && child->op_type != OP_PUSHMARK)
6988             is_compiletime = 0;
6989         }
6990     }
6991     else if (expr->op_type != OP_CONST)
6992         is_compiletime = 0;
6993
6994     LINKLIST(expr);
6995
6996     /* fix up DO blocks; treat each one as a separate little sub;
6997      * also, mark any arrays as LIST/REF */
6998
6999     if (expr->op_type == OP_LIST) {
7000         OP *child;
7001         for (child = cLISTOPx(expr)->op_first; child; child = OpSIBLING(child)) {
7002
7003             if (child->op_type == OP_PADAV || child->op_type == OP_RV2AV) {
7004                 assert( !(child->op_flags  & OPf_WANT));
7005                 /* push the array rather than its contents. The regex
7006                  * engine will retrieve and join the elements later */
7007                 child->op_flags |= (OPf_WANT_LIST | OPf_REF);
7008                 continue;
7009             }
7010
7011             if (!(child->op_type == OP_NULL && (child->op_flags & OPf_SPECIAL)))
7012                 continue;
7013             child->op_next = NULL; /* undo temporary hack from above */
7014             scalar(child);
7015             LINKLIST(child);
7016             if (cLISTOPx(child)->op_first->op_type == OP_LEAVE) {
7017                 LISTOP *leaveop = cLISTOPx(cLISTOPx(child)->op_first);
7018                 /* skip ENTER */
7019                 assert(leaveop->op_first->op_type == OP_ENTER);
7020                 assert(OpHAS_SIBLING(leaveop->op_first));
7021                 child->op_next = OpSIBLING(leaveop->op_first);
7022                 /* skip leave */
7023                 assert(leaveop->op_flags & OPf_KIDS);
7024                 assert(leaveop->op_last->op_next == (OP*)leaveop);
7025                 leaveop->op_next = NULL; /* stop on last op */
7026                 op_null((OP*)leaveop);
7027             }
7028             else {
7029                 /* skip SCOPE */
7030                 OP *scope = cLISTOPx(child)->op_first;
7031                 assert(scope->op_type == OP_SCOPE);
7032                 assert(scope->op_flags & OPf_KIDS);
7033                 scope->op_next = NULL; /* stop on last op */
7034                 op_null(scope);
7035             }
7036
7037             /* XXX optimize_optree() must be called on o before
7038              * CALL_PEEP(), as currently S_maybe_multiconcat() can't
7039              * currently cope with a peephole-optimised optree.
7040              * Calling optimize_optree() here ensures that condition
7041              * is met, but may mean optimize_optree() is applied
7042              * to the same optree later (where hopefully it won't do any
7043              * harm as it can't convert an op to multiconcat if it's
7044              * already been converted */
7045             optimize_optree(child);
7046
7047             /* have to peep the DOs individually as we've removed it from
7048              * the op_next chain */
7049             CALL_PEEP(child);
7050             op_prune_chain_head(&(child->op_next));
7051             if (is_compiletime)
7052                 /* runtime finalizes as part of finalizing whole tree */
7053                 finalize_optree(child);
7054         }
7055     }
7056     else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
7057         assert( !(expr->op_flags  & OPf_WANT));
7058         /* push the array rather than its contents. The regex
7059          * engine will retrieve and join the elements later */
7060         expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
7061     }
7062
7063     PL_hints |= HINT_BLOCK_SCOPE;
7064     pm = cPMOPo;
7065     assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
7066
7067     if (is_compiletime) {
7068         U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
7069         regexp_engine const *eng = current_re_engine();
7070
7071         if (is_split) {
7072             /* make engine handle split ' ' specially */
7073             pm->op_pmflags |= PMf_SPLIT;
7074             rx_flags |= RXf_SPLIT;
7075         }
7076
7077         if (!has_code || !eng->op_comp) {
7078             /* compile-time simple constant pattern */
7079
7080             if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
7081                 /* whoops! we guessed that a qr// had a code block, but we
7082                  * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
7083                  * that isn't required now. Note that we have to be pretty
7084                  * confident that nothing used that CV's pad while the
7085                  * regex was parsed, except maybe op targets for \Q etc.
7086                  * If there were any op targets, though, they should have
7087                  * been stolen by constant folding.
7088                  */
7089 #ifdef DEBUGGING
7090                 SSize_t i = 0;
7091                 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
7092                 while (++i <= AvFILLp(PL_comppad)) {
7093 #  ifdef USE_PAD_RESET
7094                     /* under USE_PAD_RESET, pad swipe replaces a swiped
7095                      * folded constant with a fresh padtmp */
7096                     assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i]));
7097 #  else
7098                     assert(!PL_curpad[i]);
7099 #  endif
7100                 }
7101 #endif
7102                 /* This LEAVE_SCOPE will restore PL_compcv to point to the
7103                  * outer CV (the one whose slab holds the pm op). The
7104                  * inner CV (which holds expr) will be freed later, once
7105                  * all the entries on the parse stack have been popped on
7106                  * return from this function. Which is why its safe to
7107                  * call op_free(expr) below.
7108                  */
7109                 LEAVE_SCOPE(floor);
7110                 pm->op_pmflags &= ~PMf_HAS_CV;
7111             }
7112
7113             /* Skip compiling if parser found an error for this pattern */
7114             if (pm->op_pmflags & PMf_HAS_ERROR) {
7115                 return o;
7116             }
7117
7118             PM_SETRE(pm,
7119                 eng->op_comp
7120                     ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7121                                         rx_flags, pm->op_pmflags)
7122                     : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7123                                         rx_flags, pm->op_pmflags)
7124             );
7125             op_free(expr);
7126         }
7127         else {
7128             /* compile-time pattern that includes literal code blocks */
7129
7130             REGEXP* re;
7131
7132             /* Skip compiling if parser found an error for this pattern */
7133             if (pm->op_pmflags & PMf_HAS_ERROR) {
7134                 return o;
7135             }
7136
7137             re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7138                         rx_flags,
7139                         (pm->op_pmflags |
7140                             ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
7141                     );
7142             PM_SETRE(pm, re);
7143             if (pm->op_pmflags & PMf_HAS_CV) {
7144                 CV *cv;
7145                 /* this QR op (and the anon sub we embed it in) is never
7146                  * actually executed. It's just a placeholder where we can
7147                  * squirrel away expr in op_code_list without the peephole
7148                  * optimiser etc processing it for a second time */
7149                 OP *qr = newPMOP(OP_QR, 0);
7150                 cPMOPx(qr)->op_code_list = expr;
7151
7152                 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
7153                 SvREFCNT_inc_simple_void(PL_compcv);
7154                 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
7155                 ReANY(re)->qr_anoncv = cv;
7156
7157                 /* attach the anon CV to the pad so that
7158                  * pad_fixup_inner_anons() can find it */
7159                 (void)pad_add_anon(cv, o->op_type);
7160                 SvREFCNT_inc_simple_void(cv);
7161             }
7162             else {
7163                 pm->op_code_list = expr;
7164             }
7165         }
7166     }
7167     else {
7168         /* runtime pattern: build chain of regcomp etc ops */
7169         bool reglist;
7170         PADOFFSET cv_targ = 0;
7171
7172         reglist = isreg && expr->op_type == OP_LIST;
7173         if (reglist)
7174             op_null(expr);
7175
7176         if (has_code) {
7177             pm->op_code_list = expr;
7178             /* don't free op_code_list; its ops are embedded elsewhere too */
7179             pm->op_pmflags |= PMf_CODELIST_PRIVATE;
7180         }
7181
7182         if (is_split)
7183             /* make engine handle split ' ' specially */
7184             pm->op_pmflags |= PMf_SPLIT;
7185
7186         /* the OP_REGCMAYBE is a placeholder in the non-threaded case
7187          * to allow its op_next to be pointed past the regcomp and
7188          * preceding stacking ops;
7189          * OP_REGCRESET is there to reset taint before executing the
7190          * stacking ops */
7191         if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
7192             expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
7193
7194         if (pm->op_pmflags & PMf_HAS_CV) {
7195             /* we have a runtime qr with literal code. This means
7196              * that the qr// has been wrapped in a new CV, which
7197              * means that runtime consts, vars etc will have been compiled
7198              * against a new pad. So... we need to execute those ops
7199              * within the environment of the new CV. So wrap them in a call
7200              * to a new anon sub. i.e. for
7201              *
7202              *     qr/a$b(?{...})/,
7203              *
7204              * we build an anon sub that looks like
7205              *
7206              *     sub { "a", $b, '(?{...})' }
7207              *
7208              * and call it, passing the returned list to regcomp.
7209              * Or to put it another way, the list of ops that get executed
7210              * are:
7211              *
7212              *     normal              PMf_HAS_CV
7213              *     ------              -------------------
7214              *                         pushmark (for regcomp)
7215              *                         pushmark (for entersub)
7216              *                         anoncode
7217              *                         srefgen
7218              *                         entersub
7219              *     regcreset                  regcreset
7220              *     pushmark                   pushmark
7221              *     const("a")                 const("a")
7222              *     gvsv(b)                    gvsv(b)
7223              *     const("(?{...})")          const("(?{...})")
7224              *                                leavesub
7225              *     regcomp             regcomp
7226              */
7227
7228             SvREFCNT_inc_simple_void(PL_compcv);
7229             CvLVALUE_on(PL_compcv);
7230             /* these lines are just an unrolled newANONATTRSUB */
7231             expr = newSVOP(OP_ANONCODE, 0,
7232                     MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
7233             cv_targ = expr->op_targ;
7234             expr = newUNOP(OP_REFGEN, 0, expr);
7235
7236             expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), TRUE));
7237         }
7238
7239         rcop = alloc_LOGOP(OP_REGCOMP, scalar(expr), o);
7240         rcop->op_flags |=  ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
7241                            | (reglist ? OPf_STACKED : 0);
7242         rcop->op_targ = cv_targ;
7243
7244         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
7245         if (PL_hints & HINT_RE_EVAL)
7246             S_set_haseval(aTHX);
7247
7248         /* establish postfix order */
7249         if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
7250             LINKLIST(expr);
7251             rcop->op_next = expr;
7252             cUNOPx(expr)->op_first->op_next = (OP*)rcop;
7253         }
7254         else {
7255             rcop->op_next = LINKLIST(expr);
7256             expr->op_next = (OP*)rcop;
7257         }
7258
7259         op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
7260     }
7261
7262     if (repl) {
7263         OP *curop = repl;
7264         bool konst;
7265         /* If we are looking at s//.../e with a single statement, get past
7266            the implicit do{}. */
7267         if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
7268              && cUNOPx(curop)->op_first->op_type == OP_SCOPE
7269              && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
7270          {
7271             OP *sib;
7272             OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
7273             if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
7274              && !OpHAS_SIBLING(sib))
7275                 curop = sib;
7276         }
7277         if (curop->op_type == OP_CONST)
7278             konst = TRUE;
7279         else if (( (curop->op_type == OP_RV2SV ||
7280                     curop->op_type == OP_RV2AV ||
7281                     curop->op_type == OP_RV2HV ||
7282                     curop->op_type == OP_RV2GV)
7283                    && cUNOPx(curop)->op_first
7284                    && cUNOPx(curop)->op_first->op_type == OP_GV )
7285                 || curop->op_type == OP_PADSV
7286                 || curop->op_type == OP_PADAV
7287                 || curop->op_type == OP_PADHV
7288                 || curop->op_type == OP_PADANY) {
7289             repl_has_vars = 1;
7290             konst = TRUE;
7291         }
7292         else konst = FALSE;
7293         if (konst
7294             && !(repl_has_vars
7295                  && (!PM_GETRE(pm)
7296                      || !RX_PRELEN(PM_GETRE(pm))
7297                      || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
7298         {
7299             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
7300             op_prepend_elem(o->op_type, scalar(repl), o);
7301         }
7302         else {
7303             rcop = alloc_LOGOP(OP_SUBSTCONT, scalar(repl), o);
7304             rcop->op_private = 1;
7305
7306             /* establish postfix order */
7307             rcop->op_next = LINKLIST(repl);
7308             repl->op_next = (OP*)rcop;
7309
7310             pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
7311             assert(!(pm->op_pmflags & PMf_ONCE));
7312             pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
7313             rcop->op_next = 0;
7314         }
7315     }
7316
7317     return (OP*)pm;
7318 }
7319
7320 /*
7321 =for apidoc newSVOP
7322
7323 Constructs, checks, and returns an op of any type that involves an
7324 embedded SV.  C<type> is the opcode.  C<flags> gives the eight bits
7325 of C<op_flags>.  C<sv> gives the SV to embed in the op; this function
7326 takes ownership of one reference to it.
7327
7328 =cut
7329 */
7330
7331 OP *
7332 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
7333 {
7334     SVOP *svop;
7335
7336     PERL_ARGS_ASSERT_NEWSVOP;
7337
7338     /* OP_RUNCV is allowed specially so rpeep has room to convert it into an
7339      * OP_CONST */
7340     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
7341         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7342         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
7343         || type == OP_RUNCV
7344         || type == OP_CUSTOM);
7345
7346     NewOp(1101, svop, 1, SVOP);
7347     OpTYPE_set(svop, type);
7348     svop->op_sv = sv;
7349     svop->op_next = (OP*)svop;
7350     svop->op_flags = (U8)flags;
7351     svop->op_private = (U8)(0 | (flags >> 8));
7352     if (PL_opargs[type] & OA_RETSCALAR)
7353         scalar((OP*)svop);
7354     if (PL_opargs[type] & OA_TARGET)
7355         svop->op_targ = pad_alloc(type, SVs_PADTMP);
7356     return CHECKOP(type, svop);
7357 }
7358
7359 /*
7360 =for apidoc newDEFSVOP
7361
7362 Constructs and returns an op to access C<$_>.
7363
7364 =cut
7365 */
7366
7367 OP *
7368 Perl_newDEFSVOP(pTHX)
7369 {
7370         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
7371 }
7372
7373 #ifdef USE_ITHREADS
7374
7375 /*
7376 =for apidoc newPADOP
7377
7378 Constructs, checks, and returns an op of any type that involves a
7379 reference to a pad element.  C<type> is the opcode.  C<flags> gives the
7380 eight bits of C<op_flags>.  A pad slot is automatically allocated, and
7381 is populated with C<sv>; this function takes ownership of one reference
7382 to it.
7383
7384 This function only exists if Perl has been compiled to use ithreads.
7385
7386 =cut
7387 */
7388
7389 OP *
7390 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
7391 {
7392     PADOP *padop;
7393
7394     PERL_ARGS_ASSERT_NEWPADOP;
7395
7396     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
7397         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7398         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
7399         || type == OP_CUSTOM);
7400
7401     NewOp(1101, padop, 1, PADOP);
7402     OpTYPE_set(padop, type);
7403     padop->op_padix =
7404         pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
7405     SvREFCNT_dec(PAD_SVl(padop->op_padix));
7406     PAD_SETSV(padop->op_padix, sv);
7407     assert(sv);
7408     padop->op_next = (OP*)padop;
7409     padop->op_flags = (U8)flags;
7410     if (PL_opargs[type] & OA_RETSCALAR)
7411         scalar((OP*)padop);
7412     if (PL_opargs[type] & OA_TARGET)
7413         padop->op_targ = pad_alloc(type, SVs_PADTMP);
7414     return CHECKOP(type, padop);
7415 }
7416
7417 #endif /* USE_ITHREADS */
7418
7419 /*
7420 =for apidoc newGVOP
7421
7422 Constructs, checks, and returns an op of any type that involves an
7423 embedded reference to a GV.  C<type> is the opcode.  C<flags> gives the
7424 eight bits of C<op_flags>.  C<gv> identifies the GV that the op should
7425 reference; calling this function does not transfer ownership of any
7426 reference to it.
7427
7428 =cut
7429 */
7430
7431 OP *
7432 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
7433 {
7434     PERL_ARGS_ASSERT_NEWGVOP;
7435
7436 #ifdef USE_ITHREADS
7437     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
7438 #else
7439     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
7440 #endif
7441 }
7442
7443 /*
7444 =for apidoc newPVOP
7445
7446 Constructs, checks, and returns an op of any type that involves an
7447 embedded C-level pointer (PV).  C<type> is the opcode.  C<flags> gives
7448 the eight bits of C<op_flags>.  C<pv> supplies the C-level pointer.
7449 Depending on the op type, the memory referenced by C<pv> may be freed
7450 when the op is destroyed.  If the op is of a freeing type, C<pv> must
7451 have been allocated using C<PerlMemShared_malloc>.
7452
7453 =cut
7454 */
7455
7456 OP *
7457 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
7458 {
7459     const bool utf8 = cBOOL(flags & SVf_UTF8);
7460     PVOP *pvop;
7461
7462     flags &= ~SVf_UTF8;
7463
7464     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7465         || type == OP_CUSTOM
7466         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
7467
7468     NewOp(1101, pvop, 1, PVOP);
7469     OpTYPE_set(pvop, type);
7470     pvop->op_pv = pv;
7471     pvop->op_next = (OP*)pvop;
7472     pvop->op_flags = (U8)flags;
7473     pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
7474     if (PL_opargs[type] & OA_RETSCALAR)
7475         scalar((OP*)pvop);
7476     if (PL_opargs[type] & OA_TARGET)
7477         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
7478     return CHECKOP(type, pvop);
7479 }
7480
7481 void
7482 Perl_package(pTHX_ OP *o)
7483 {
7484     SV *const sv = cSVOPo->op_sv;
7485
7486     PERL_ARGS_ASSERT_PACKAGE;
7487
7488     SAVEGENERICSV(PL_curstash);
7489     save_item(PL_curstname);
7490
7491     PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
7492
7493     sv_setsv(PL_curstname, sv);
7494
7495     PL_hints |= HINT_BLOCK_SCOPE;
7496     PL_parser->copline = NOLINE;
7497
7498     op_free(o);
7499 }
7500
7501 void
7502 Perl_package_version( pTHX_ OP *v )
7503 {
7504     U32 savehints = PL_hints;
7505     PERL_ARGS_ASSERT_PACKAGE_VERSION;
7506     PL_hints &= ~HINT_STRICT_VARS;
7507     sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
7508     PL_hints = savehints;
7509     op_free(v);
7510 }
7511
7512 /* Extract the first two components of a "version" object as two 8bit integers
7513  * and return them packed into a single U16 in the format of PL_prevailing_version.
7514  * This function only ever has to cope with version objects already known
7515  * bounded by the current perl version, so we know its components will fit
7516  * (Up until we reach perl version 5.256 anyway) */
7517 static U16 S_extract_shortver(pTHX_ SV *sv)
7518 {
7519     SV *rv;
7520     if(!SvRV(sv) || !SvOBJECT(rv = SvRV(sv)) || !sv_derived_from(sv, "version"))
7521         return 0;
7522
7523     AV *av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rv), "version", 0)));
7524
7525     U16 shortver = 0;
7526
7527     IV major = av_count(av) > 0 ? SvIV(*av_fetch(av, 0, false)) : 0;
7528     if(major > 255)
7529         shortver |= 255 << 8;
7530     else
7531         shortver |= major << 8;
7532
7533     IV minor = av_count(av) > 1 ? SvIV(*av_fetch(av, 1, false)) : 0;
7534     if(minor > 255)
7535         shortver |= 255;
7536     else
7537         shortver |= minor;
7538
7539     return shortver;
7540 }
7541 #define SHORTVER(maj,min) ((maj << 8) | min)
7542
7543 void
7544 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
7545 {
7546     OP *pack;
7547     OP *imop;
7548     OP *veop;
7549     SV *use_version = NULL;
7550
7551     PERL_ARGS_ASSERT_UTILIZE;
7552
7553     if (idop->op_type != OP_CONST)
7554         Perl_croak(aTHX_ "Module name must be constant");
7555
7556     veop = NULL;
7557
7558     if (version) {
7559         SV * const vesv = cSVOPx(version)->op_sv;
7560
7561         if (!arg && !SvNIOKp(vesv)) {
7562             arg = version;
7563         }
7564         else {
7565             OP *pack;
7566             SV *meth;
7567
7568             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
7569                 Perl_croak(aTHX_ "Version number must be a constant number");
7570
7571             /* Make copy of idop so we don't free it twice */
7572             pack = newSVOP(OP_CONST, 0, newSVsv(cSVOPx(idop)->op_sv));
7573
7574             /* Fake up a method call to VERSION */
7575             meth = newSVpvs_share("VERSION");
7576             veop = op_convert_list(OP_ENTERSUB, OPf_STACKED,
7577                             op_append_elem(OP_LIST,
7578                                         op_prepend_elem(OP_LIST, pack, version),
7579                                         newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
7580         }
7581     }
7582
7583     /* Fake up an import/unimport */
7584     if (arg && arg->op_type == OP_STUB) {
7585         imop = arg;             /* no import on explicit () */
7586     }
7587     else if (SvNIOKp(cSVOPx(idop)->op_sv)) {
7588         imop = NULL;            /* use 5.0; */
7589         if (aver)
7590             use_version = cSVOPx(idop)->op_sv;
7591         else
7592             idop->op_private |= OPpCONST_NOVER;
7593     }
7594     else {
7595         SV *meth;
7596
7597         /* Make copy of idop so we don't free it twice */
7598         pack = newSVOP(OP_CONST, 0, newSVsv(cSVOPx(idop)->op_sv));
7599
7600         /* Fake up a method call to import/unimport */
7601         meth = aver
7602             ? newSVpvs_share("import") : newSVpvs_share("unimport");
7603         imop = op_convert_list(OP_ENTERSUB, OPf_STACKED,
7604                        op_append_elem(OP_LIST,
7605                                    op_prepend_elem(OP_LIST, pack, arg),
7606                                    newMETHOP_named(OP_METHOD_NAMED, 0, meth)
7607                        ));
7608     }
7609
7610     /* Fake up the BEGIN {}, which does its thing immediately. */
7611     newATTRSUB(floor,
7612         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
7613         NULL,
7614         NULL,
7615         op_append_elem(OP_LINESEQ,
7616             op_append_elem(OP_LINESEQ,
7617                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
7618                 newSTATEOP(0, NULL, veop)),
7619             newSTATEOP(0, NULL, imop) ));
7620
7621     if (use_version) {
7622         /* Enable the
7623          * feature bundle that corresponds to the required version. */
7624         use_version = sv_2mortal(new_version(use_version));
7625         S_enable_feature_bundle(aTHX_ use_version);
7626
7627         U16 shortver = S_extract_shortver(aTHX_ use_version);
7628
7629         /* If a version >= 5.11.0 is requested, strictures are on by default! */
7630         if (shortver >= SHORTVER(5, 11)) {
7631             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
7632                 PL_hints |= HINT_STRICT_REFS;
7633             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
7634                 PL_hints |= HINT_STRICT_SUBS;
7635             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
7636                 PL_hints |= HINT_STRICT_VARS;
7637
7638             if (shortver >= SHORTVER(5, 35))
7639                 free_and_set_cop_warnings(&PL_compiling, pWARN_ALL);
7640         }
7641         /* otherwise they are off */
7642         else {
7643             if(PL_prevailing_version >= SHORTVER(5, 11))
7644                 deprecate_fatal_in("5.40",
7645                     "Downgrading a use VERSION declaration to below v5.11");
7646
7647             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
7648                 PL_hints &= ~HINT_STRICT_REFS;
7649             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
7650                 PL_hints &= ~HINT_STRICT_SUBS;
7651             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
7652                 PL_hints &= ~HINT_STRICT_VARS;
7653         }
7654
7655         PL_prevailing_version = shortver;
7656     }
7657
7658     /* The "did you use incorrect case?" warning used to be here.
7659      * The problem is that on case-insensitive filesystems one
7660      * might get false positives for "use" (and "require"):
7661      * "use Strict" or "require CARP" will work.  This causes
7662      * portability problems for the script: in case-strict
7663      * filesystems the script will stop working.
7664      *
7665      * The "incorrect case" warning checked whether "use Foo"
7666      * imported "Foo" to your namespace, but that is wrong, too:
7667      * there is no requirement nor promise in the language that
7668      * a Foo.pm should or would contain anything in package "Foo".
7669      *
7670      * There is very little Configure-wise that can be done, either:
7671      * the case-sensitivity of the build filesystem of Perl does not
7672      * help in guessing the case-sensitivity of the runtime environment.
7673      */
7674
7675     PL_hints |= HINT_BLOCK_SCOPE;
7676     PL_parser->copline = NOLINE;
7677     COP_SEQMAX_INC; /* Purely for B::*'s benefit */
7678 }
7679
7680 /*
7681 =for apidoc_section $embedding
7682
7683 =for apidoc      load_module
7684 =for apidoc_item load_module_nocontext
7685
7686 These load the module whose name is pointed to by the string part of C<name>.
7687 Note that the actual module name, not its filename, should be given.
7688 Eg, "Foo::Bar" instead of "Foo/Bar.pm". ver, if specified and not NULL,
7689 provides version semantics similar to C<use Foo::Bar VERSION>. The optional
7690 trailing arguments can be used to specify arguments to the module's C<import()>
7691 method, similar to C<use Foo::Bar VERSION LIST>; their precise handling depends
7692 on the flags. The flags argument is a bitwise-ORed collection of any of
7693 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
7694 (or 0 for no flags).
7695
7696 If C<PERL_LOADMOD_NOIMPORT> is set, the module is loaded as if with an empty
7697 import list, as in C<use Foo::Bar ()>; this is the only circumstance in which
7698 the trailing optional arguments may be omitted entirely. Otherwise, if
7699 C<PERL_LOADMOD_IMPORT_OPS> is set, the trailing arguments must consist of
7700 exactly one C<OP*>, containing the op tree that produces the relevant import
7701 arguments. Otherwise, the trailing arguments must all be C<SV*> values that
7702 will be used as import arguments; and the list must be terminated with C<(SV*)
7703 NULL>. If neither C<PERL_LOADMOD_NOIMPORT> nor C<PERL_LOADMOD_IMPORT_OPS> is
7704 set, the trailing C<NULL> pointer is needed even if no import arguments are
7705 desired. The reference count for each specified C<SV*> argument is
7706 decremented. In addition, the C<name> argument is modified.
7707
7708 If C<PERL_LOADMOD_DENY> is set, the module is loaded as if with C<no> rather
7709 than C<use>.
7710
7711 C<load_module> and C<load_module_nocontext> have the same apparent signature,
7712 but the former hides the fact that it is accessing a thread context parameter.
7713 So use the latter when you get a compilation error about C<pTHX>.
7714
7715 =for apidoc Amnh||PERL_LOADMOD_DENY
7716 =for apidoc Amnh||PERL_LOADMOD_NOIMPORT
7717 =for apidoc Amnh||PERL_LOADMOD_IMPORT_OPS
7718
7719 =for apidoc vload_module
7720 Like C<L</load_module>> but the arguments are an encapsulated argument list.
7721
7722 =cut */
7723
7724 void
7725 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
7726 {
7727     va_list args;
7728
7729     PERL_ARGS_ASSERT_LOAD_MODULE;
7730
7731     va_start(args, ver);
7732     vload_module(flags, name, ver, &args);
7733     va_end(args);
7734 }
7735
7736 #ifdef MULTIPLICITY
7737 void
7738 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
7739 {
7740     dTHX;
7741     va_list args;
7742     PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
7743     va_start(args, ver);
7744     vload_module(flags, name, ver, &args);
7745     va_end(args);
7746 }
7747 #endif
7748
7749 void
7750 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
7751 {
7752     OP *veop, *imop;
7753     OP * modname;
7754     I32 floor;
7755
7756     PERL_ARGS_ASSERT_VLOAD_MODULE;
7757
7758     /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
7759      * that it has a PL_parser to play with while doing that, and also
7760      * that it doesn't mess with any existing parser, by creating a tmp
7761      * new parser with lex_start(). This won't actually be used for much,
7762      * since pp_require() will create another parser for the real work.
7763      * The ENTER/LEAVE pair protect callers from any side effects of use.
7764      *
7765      * start_subparse() creates a new PL_compcv. This means that any ops
7766      * allocated below will be allocated from that CV's op slab, and so
7767      * will be automatically freed if the utilise() fails
7768      */
7769
7770     ENTER;
7771     SAVEVPTR(PL_curcop);
7772     lex_start(NULL, NULL, LEX_START_SAME_FILTER);
7773     floor = start_subparse(FALSE, 0);
7774
7775     modname = newSVOP(OP_CONST, 0, name);
7776     modname->op_private |= OPpCONST_BARE;
7777     if (ver) {
7778         veop = newSVOP(OP_CONST, 0, ver);
7779     }
7780     else
7781         veop = NULL;
7782     if (flags & PERL_LOADMOD_NOIMPORT) {
7783         imop = sawparens(newNULLLIST());
7784     }
7785     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
7786         imop = va_arg(*args, OP*);
7787     }
7788     else {
7789         SV *sv;
7790         imop = NULL;
7791         sv = va_arg(*args, SV*);
7792         while (sv) {
7793             imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
7794             sv = va_arg(*args, SV*);
7795         }
7796     }
7797
7798     utilize(!(flags & PERL_LOADMOD_DENY), floor, veop, modname, imop);
7799     LEAVE;
7800 }
7801
7802 PERL_STATIC_INLINE OP *
7803 S_new_entersubop(pTHX_ GV *gv, OP *arg)
7804 {
7805     return newUNOP(OP_ENTERSUB, OPf_STACKED,
7806                    newLISTOP(OP_LIST, 0, arg,
7807                              newUNOP(OP_RV2CV, 0,
7808                                      newGVOP(OP_GV, 0, gv))));
7809 }
7810
7811 OP *
7812 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
7813 {
7814     OP *doop;
7815     GV *gv;
7816
7817     PERL_ARGS_ASSERT_DOFILE;
7818
7819     if (!force_builtin && (gv = gv_override("do", 2))) {
7820         doop = S_new_entersubop(aTHX_ gv, term);
7821     }
7822     else {
7823         doop = newUNOP(OP_DOFILE, 0, scalar(term));
7824     }
7825     return doop;
7826 }
7827
7828 /*
7829 =for apidoc_section $optree_construction
7830
7831 =for apidoc newSLICEOP
7832
7833 Constructs, checks, and returns an C<lslice> (list slice) op.  C<flags>
7834 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
7835 be set automatically, and, shifted up eight bits, the eight bits of
7836 C<op_private>, except that the bit with value 1 or 2 is automatically
7837 set as required.  C<listval> and C<subscript> supply the parameters of
7838 the slice; they are consumed by this function and become part of the
7839 constructed op tree.
7840
7841 =cut
7842 */
7843
7844 OP *
7845 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
7846 {
7847     return newBINOP(OP_LSLICE, flags,
7848             list(force_list(subscript, TRUE)),
7849             list(force_list(listval,   TRUE)));
7850 }
7851
7852 #define ASSIGN_SCALAR 0
7853 #define ASSIGN_LIST   1
7854 #define ASSIGN_REF    2
7855
7856 /* given the optree o on the LHS of an assignment, determine whether its:
7857  *  ASSIGN_SCALAR   $x  = ...
7858  *  ASSIGN_LIST    ($x) = ...
7859  *  ASSIGN_REF     \$x  = ...
7860  */
7861
7862 STATIC I32
7863 S_assignment_type(pTHX_ const OP *o)
7864 {
7865     unsigned type;
7866     U8 flags;
7867     U8 ret;
7868
7869     if (!o)
7870         return ASSIGN_LIST;
7871
7872     if (o->op_type == OP_SREFGEN)
7873     {
7874         OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
7875         type = kid->op_type;
7876         flags = o->op_flags | kid->op_flags;
7877         if (!(flags & OPf_PARENS)
7878           && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
7879               kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
7880             return ASSIGN_REF;
7881         ret = ASSIGN_REF;
7882     } else {
7883         if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
7884             o = cUNOPo->op_first;
7885         flags = o->op_flags;
7886         type = o->op_type;
7887         ret = ASSIGN_SCALAR;
7888     }
7889
7890     if (type == OP_COND_EXPR) {
7891         OP * const sib = OpSIBLING(cLOGOPo->op_first);
7892         const I32 t = assignment_type(sib);
7893         const I32 f = assignment_type(OpSIBLING(sib));
7894
7895         if (t == ASSIGN_LIST && f == ASSIGN_LIST)
7896             return ASSIGN_LIST;
7897         if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
7898             yyerror("Assignment to both a list and a scalar");
7899         return ASSIGN_SCALAR;
7900     }
7901
7902     if (type == OP_LIST &&
7903         (flags & OPf_WANT) == OPf_WANT_SCALAR &&
7904         o->op_private & OPpLVAL_INTRO)
7905         return ret;
7906
7907     if (type == OP_LIST || flags & OPf_PARENS ||
7908         type == OP_RV2AV || type == OP_RV2HV ||
7909         type == OP_ASLICE || type == OP_HSLICE ||
7910         type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
7911         return ASSIGN_LIST;
7912
7913     if (type == OP_PADAV || type == OP_PADHV)
7914         return ASSIGN_LIST;
7915
7916     if (type == OP_RV2SV)
7917         return ret;
7918
7919     return ret;
7920 }
7921
7922 static OP *
7923 S_newONCEOP(pTHX_ OP *initop, OP *padop)
7924 {
7925     const PADOFFSET target = padop->op_targ;
7926     OP *const other = newOP(OP_PADSV,
7927                             padop->op_flags
7928                             | ((padop->op_private & ~OPpLVAL_INTRO) << 8));
7929     OP *const first = newOP(OP_NULL, 0);
7930     OP *const nullop = newCONDOP(0, first, initop, other);
7931     /* XXX targlex disabled for now; see ticket #124160
7932         newCONDOP(0, first, S_maybe_targlex(aTHX_ initop), other);
7933      */
7934     OP *const condop = first->op_next;
7935
7936     OpTYPE_set(condop, OP_ONCE);
7937     other->op_targ = target;
7938     nullop->op_flags |= OPf_WANT_SCALAR;
7939
7940     /* Store the initializedness of state vars in a separate
7941        pad entry.  */
7942     condop->op_targ =
7943       pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
7944     /* hijacking PADSTALE for uninitialized state variables */
7945     SvPADSTALE_on(PAD_SVl(condop->op_targ));
7946
7947     return nullop;
7948 }
7949
7950 /*
7951 =for apidoc newASSIGNOP
7952
7953 Constructs, checks, and returns an assignment op.  C<left> and C<right>
7954 supply the parameters of the assignment; they are consumed by this
7955 function and become part of the constructed op tree.
7956
7957 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
7958 a suitable conditional optree is constructed.  If C<optype> is the opcode
7959 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
7960 performs the binary operation and assigns the result to the left argument.
7961 Either way, if C<optype> is non-zero then C<flags> has no effect.
7962
7963 If C<optype> is zero, then a plain scalar or list assignment is
7964 constructed.  Which type of assignment it is is automatically determined.
7965 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
7966 will be set automatically, and, shifted up eight bits, the eight bits
7967 of C<op_private>, except that the bit with value 1 or 2 is automatically
7968 set as required.
7969
7970 =cut
7971 */
7972
7973 OP *
7974 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
7975 {
7976     OP *o;
7977     I32 assign_type;
7978
7979     switch (optype) {
7980         case 0: break;
7981         case OP_ANDASSIGN:
7982         case OP_ORASSIGN:
7983         case OP_DORASSIGN:
7984             right = scalar(right);
7985             return newLOGOP(optype, 0,
7986                 op_lvalue(scalar(left), optype),
7987                 newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right));
7988         default:
7989             return newBINOP(optype, OPf_STACKED,
7990                 op_lvalue(scalar(left), optype), scalar(right));
7991     }
7992
7993     if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
7994         OP *state_var_op = NULL;
7995         static const char no_list_state[] = "Initialization of state variables"
7996             " in list currently forbidden";
7997         OP *curop;
7998
7999         if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
8000             left->op_private &= ~ OPpSLICEWARNING;
8001
8002         PL_modcount = 0;
8003         left = op_lvalue(left, OP_AASSIGN);
8004         curop = list(force_list(left, TRUE));
8005         o = newBINOP(OP_AASSIGN, flags, list(force_list(right, TRUE)), curop);
8006         o->op_private = (U8)(0 | (flags >> 8));
8007
8008         if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
8009         {
8010             OP *lop = cLISTOPx(left)->op_first, *vop, *eop;
8011             if (!(left->op_flags & OPf_PARENS) &&
8012                     lop->op_type == OP_PUSHMARK &&
8013                     (vop = OpSIBLING(lop)) &&
8014                     (vop->op_type == OP_PADAV || vop->op_type == OP_PADHV) &&
8015                     !(vop->op_flags & OPf_PARENS) &&
8016                     (vop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) ==
8017                         (OPpLVAL_INTRO|OPpPAD_STATE) &&
8018                     (eop = OpSIBLING(vop)) &&
8019                     eop->op_type == OP_ENTERSUB &&
8020                     !OpHAS_SIBLING(eop)) {
8021                 state_var_op = vop;
8022             } else {
8023                 while (lop) {
8024                     if ((lop->op_type == OP_PADSV ||
8025                          lop->op_type == OP_PADAV ||
8026                          lop->op_type == OP_PADHV ||
8027                          lop->op_type == OP_PADANY)
8028                       && (lop->op_private & OPpPAD_STATE)
8029                     )
8030                         yyerror(no_list_state);
8031                     lop = OpSIBLING(lop);
8032                 }
8033             }
8034         }
8035         else if (  (left->op_private & OPpLVAL_INTRO)
8036                 && (left->op_private & OPpPAD_STATE)
8037                 && (   left->op_type == OP_PADSV
8038                     || left->op_type == OP_PADAV
8039                     || left->op_type == OP_PADHV
8040                     || left->op_type == OP_PADANY)
8041         ) {
8042                 /* All single variable list context state assignments, hence
8043                    state ($a) = ...
8044                    (state $a) = ...
8045                    state @a = ...
8046                    state (@a) = ...
8047                    (state @a) = ...
8048                    state %a = ...
8049                    state (%a) = ...
8050                    (state %a) = ...
8051                 */
8052                 if (left->op_flags & OPf_PARENS)
8053                     yyerror(no_list_state);
8054                 else
8055                     state_var_op = left;
8056         }
8057
8058         /* optimise @a = split(...) into:
8059         * @{expr}:              split(..., @{expr}) (where @a is not flattened)
8060         * @a, my @a, local @a:  split(...)          (where @a is attached to
8061         *                                            the split op itself)
8062         */
8063
8064         if (   right
8065             && right->op_type == OP_SPLIT
8066             /* don't do twice, e.g. @b = (@a = split) */
8067             && !(right->op_private & OPpSPLIT_ASSIGN))
8068         {
8069             OP *gvop = NULL;
8070
8071             if (   (  left->op_type == OP_RV2AV
8072                    && (gvop=cUNOPx(left)->op_first)->op_type==OP_GV)
8073                 || left->op_type == OP_PADAV)
8074             {
8075                 /* @pkg or @lex or local @pkg' or 'my @lex' */
8076                 OP *tmpop;
8077                 if (gvop) {
8078 #ifdef USE_ITHREADS
8079                     cPMOPx(right)->op_pmreplrootu.op_pmtargetoff
8080                         = cPADOPx(gvop)->op_padix;
8081                     cPADOPx(gvop)->op_padix = 0;        /* steal it */
8082 #else
8083                     cPMOPx(right)->op_pmreplrootu.op_pmtargetgv
8084                         = MUTABLE_GV(cSVOPx(gvop)->op_sv);
8085                     cSVOPx(gvop)->op_sv = NULL; /* steal it */
8086 #endif
8087                     right->op_private |=
8088                         left->op_private & OPpOUR_INTRO;
8089                 }
8090                 else {
8091                     cPMOPx(right)->op_pmreplrootu.op_pmtargetoff = left->op_targ;
8092                     left->op_targ = 0;  /* steal it */
8093                     right->op_private |= OPpSPLIT_LEX;
8094                 }
8095                 right->op_private |= left->op_private & OPpLVAL_INTRO;
8096
8097               detach_split:
8098                 tmpop = cUNOPo->op_first;       /* to list (nulled) */
8099                 tmpop = cUNOPx(tmpop)->op_first; /* to pushmark */
8100                 assert(OpSIBLING(tmpop) == right);
8101                 assert(!OpHAS_SIBLING(right));
8102                 /* detach the split subtreee from the o tree,
8103                  * then free the residual o tree */
8104                 op_sibling_splice(cUNOPo->op_first, tmpop, 1, NULL);
8105                 op_free(o);                     /* blow off assign */
8106                 right->op_private |= OPpSPLIT_ASSIGN;
8107                 right->op_flags &= ~OPf_WANT;
8108                         /* "I don't know and I don't care." */
8109                 return right;
8110             }
8111             else if (left->op_type == OP_RV2AV) {
8112                 /* @{expr} */
8113
8114                 OP *pushop = cUNOPx(cBINOPo->op_last)->op_first;
8115                 assert(OpSIBLING(pushop) == left);
8116                 /* Detach the array ...  */
8117                 op_sibling_splice(cBINOPo->op_last, pushop, 1, NULL);
8118                 /* ... and attach it to the split.  */
8119                 op_sibling_splice(right, cLISTOPx(right)->op_last,
8120                                   0, left);
8121                 right->op_flags |= OPf_STACKED;
8122                 /* Detach split and expunge aassign as above.  */
8123                 goto detach_split;
8124             }
8125             else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
8126                     cLISTOPx(right)->op_last->op_type == OP_CONST)
8127             {
8128                 /* convert split(...,0) to split(..., PL_modcount+1) */
8129                 SV ** const svp =
8130                     &cSVOPx(cLISTOPx(right)->op_last)->op_sv;
8131                 SV * const sv = *svp;
8132                 if (SvIOK(sv) && SvIVX(sv) == 0)
8133                 {
8134                   if (right->op_private & OPpSPLIT_IMPLIM) {
8135                     /* our own SV, created in ck_split */
8136                     SvREADONLY_off(sv);
8137                     sv_setiv(sv, PL_modcount+1);
8138                   }
8139                   else {
8140                     /* SV may belong to someone else */
8141                     SvREFCNT_dec(sv);
8142                     *svp = newSViv(PL_modcount+1);
8143                   }
8144                 }
8145             }
8146         }
8147
8148         if (state_var_op)
8149             o = S_newONCEOP(aTHX_ o, state_var_op);
8150         return o;
8151     }
8152     if (assign_type == ASSIGN_REF)
8153         return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
8154     if (!right)
8155         right = newOP(OP_UNDEF, 0);
8156     if (right->op_type == OP_READLINE) {
8157         right->op_flags |= OPf_STACKED;
8158         return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
8159                 scalar(right));
8160     }
8161     else {
8162         o = newBINOP(OP_SASSIGN, flags,
8163             scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
8164     }
8165     return o;
8166 }
8167
8168 /*
8169 =for apidoc newSTATEOP
8170
8171 Constructs a state op (COP).  The state op is normally a C<nextstate> op,
8172 but will be a C<dbstate> op if debugging is enabled for currently-compiled
8173 code.  The state op is populated from C<PL_curcop> (or C<PL_compiling>).
8174 If C<label> is non-null, it supplies the name of a label to attach to
8175 the state op; this function takes ownership of the memory pointed at by
8176 C<label>, and will free it.  C<flags> gives the eight bits of C<op_flags>
8177 for the state op.
8178
8179 If C<o> is null, the state op is returned.  Otherwise the state op is
8180 combined with C<o> into a C<lineseq> list op, which is returned.  C<o>
8181 is consumed by this function and becomes part of the returned op tree.
8182
8183 =cut
8184 */
8185
8186 OP *
8187 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
8188 {
8189     const U32 seq = intro_my();
8190     const U32 utf8 = flags & SVf_UTF8;
8191     COP *cop;
8192
8193     assert(PL_parser);
8194     PL_parser->parsed_sub = 0;
8195
8196     flags &= ~SVf_UTF8;
8197
8198     NewOp(1101, cop, 1, COP);
8199     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
8200         OpTYPE_set(cop, OP_DBSTATE);
8201     }
8202     else {
8203         OpTYPE_set(cop, OP_NEXTSTATE);
8204     }
8205     cop->op_flags = (U8)flags;
8206     CopHINTS_set(cop, PL_hints);
8207 #ifdef VMS
8208     if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
8209 #endif
8210     cop->op_next = (OP*)cop;
8211
8212     cop->cop_seq = seq;
8213     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
8214     CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
8215     if (label) {
8216         Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
8217
8218         PL_hints |= HINT_BLOCK_SCOPE;
8219         /* It seems that we need to defer freeing this pointer, as other parts
8220            of the grammar end up wanting to copy it after this op has been
8221            created. */
8222         SAVEFREEPV(label);
8223     }
8224
8225     if (PL_parser->preambling != NOLINE) {
8226         CopLINE_set(cop, PL_parser->preambling);
8227         PL_parser->copline = NOLINE;
8228     }
8229     else if (PL_parser->copline == NOLINE)
8230         CopLINE_set(cop, CopLINE(PL_curcop));
8231     else {
8232         CopLINE_set(cop, PL_parser->copline);
8233         PL_parser->copline = NOLINE;
8234     }
8235 #ifdef USE_ITHREADS
8236     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
8237 #else
8238     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
8239 #endif
8240     CopSTASH_set(cop, PL_curstash);
8241
8242     if (cop->op_type == OP_DBSTATE) {
8243         /* this line can have a breakpoint - store the cop in IV */
8244         AV *av = CopFILEAVx(PL_curcop);
8245         if (av) {
8246             SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
8247             if (svp && *svp != &PL_sv_undef ) {
8248                 (void)SvIOK_on(*svp);
8249                 SvIV_set(*svp, PTR2IV(cop));
8250             }
8251         }
8252     }
8253
8254     if (flags & OPf_SPECIAL)
8255         op_null((OP*)cop);
8256     return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
8257 }
8258
8259 /*
8260 =for apidoc newLOGOP
8261
8262 Constructs, checks, and returns a logical (flow control) op.  C<type>
8263 is the opcode.  C<flags> gives the eight bits of C<op_flags>, except
8264 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
8265 the eight bits of C<op_private>, except that the bit with value 1 is
8266 automatically set.  C<first> supplies the expression controlling the
8267 flow, and C<other> supplies the side (alternate) chain of ops; they are
8268 consumed by this function and become part of the constructed op tree.
8269
8270 =cut
8271 */
8272
8273 OP *
8274 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
8275 {
8276     PERL_ARGS_ASSERT_NEWLOGOP;
8277
8278     return new_logop(type, flags, &first, &other);
8279 }
8280
8281
8282 /* See if the optree o contains a single OP_CONST (plus possibly
8283  * surrounding enter/nextstate/null etc). If so, return it, else return
8284  * NULL.
8285  */
8286
8287 STATIC OP *
8288 S_search_const(pTHX_ OP *o)
8289 {
8290     PERL_ARGS_ASSERT_SEARCH_CONST;
8291
8292   redo:
8293     switch (o->op_type) {
8294         case OP_CONST:
8295             return o;
8296         case OP_NULL:
8297             if (o->op_flags & OPf_KIDS) {
8298                 o = cUNOPo->op_first;
8299                 goto redo;
8300             }
8301             break;
8302         case OP_LEAVE:
8303         case OP_SCOPE:
8304         case OP_LINESEQ:
8305         {
8306             OP *kid;
8307             if (!(o->op_flags & OPf_KIDS))
8308                 return NULL;
8309             kid = cLISTOPo->op_first;
8310
8311             do {
8312                 switch (kid->op_type) {
8313                     case OP_ENTER:
8314                     case OP_NULL:
8315                     case OP_NEXTSTATE:
8316                         kid = OpSIBLING(kid);
8317                         break;
8318                     default:
8319                         if (kid != cLISTOPo->op_last)
8320                             return NULL;
8321                         goto last;
8322                 }
8323             } while (kid);
8324
8325             if (!kid)
8326                 kid = cLISTOPo->op_last;
8327           last:
8328              o = kid;
8329              goto redo;
8330         }
8331     }
8332
8333     return NULL;
8334 }
8335
8336
8337 STATIC OP *
8338 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
8339 {
8340     LOGOP *logop;
8341     OP *o;
8342     OP *first;
8343     OP *other;
8344     OP *cstop = NULL;
8345     int prepend_not = 0;
8346
8347     PERL_ARGS_ASSERT_NEW_LOGOP;
8348
8349     first = *firstp;
8350     other = *otherp;
8351
8352     /* [perl #59802]: Warn about things like "return $a or $b", which
8353        is parsed as "(return $a) or $b" rather than "return ($a or
8354        $b)".  NB: This also applies to xor, which is why we do it
8355        here.
8356      */
8357     switch (first->op_type) {
8358     case OP_NEXT:
8359     case OP_LAST:
8360     case OP_REDO:
8361         /* XXX: Perhaps we should emit a stronger warning for these.
8362            Even with the high-precedence operator they don't seem to do
8363            anything sensible.
8364
8365            But until we do, fall through here.
8366          */
8367     case OP_RETURN:
8368     case OP_EXIT:
8369     case OP_DIE:
8370     case OP_GOTO:
8371         /* XXX: Currently we allow people to "shoot themselves in the
8372            foot" by explicitly writing "(return $a) or $b".
8373
8374            Warn unless we are looking at the result from folding or if
8375            the programmer explicitly grouped the operators like this.
8376            The former can occur with e.g.
8377
8378                 use constant FEATURE => ( $] >= ... );
8379                 sub { not FEATURE and return or do_stuff(); }
8380          */
8381         if (!first->op_folded && !(first->op_flags & OPf_PARENS))
8382             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
8383                            "Possible precedence issue with control flow operator");
8384         /* XXX: Should we optimze this to "return $a;" (i.e. remove
8385            the "or $b" part)?
8386         */
8387         break;
8388     }
8389
8390     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
8391         return newBINOP(type, flags, scalar(first), scalar(other));
8392
8393     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
8394         || type == OP_CUSTOM);
8395
8396     scalarboolean(first);
8397
8398     /* search for a constant op that could let us fold the test */
8399     if ((cstop = search_const(first))) {
8400         if (cstop->op_private & OPpCONST_STRICT)
8401             no_bareword_allowed(cstop);
8402         else if ((cstop->op_private & OPpCONST_BARE))
8403                 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
8404         if ((type == OP_AND &&  SvTRUE(cSVOPx(cstop)->op_sv)) ||
8405             (type == OP_OR  && !SvTRUE(cSVOPx(cstop)->op_sv)) ||
8406             (type == OP_DOR && !SvOK(cSVOPx(cstop)->op_sv))) {
8407             /* Elide the (constant) lhs, since it can't affect the outcome */
8408             *firstp = NULL;
8409             if (other->op_type == OP_CONST)
8410                 other->op_private |= OPpCONST_SHORTCIRCUIT;
8411             op_free(first);
8412             if (other->op_type == OP_LEAVE)
8413                 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
8414             else if (other->op_type == OP_MATCH
8415                   || other->op_type == OP_SUBST
8416                   || other->op_type == OP_TRANSR
8417                   || other->op_type == OP_TRANS)
8418                 /* Mark the op as being unbindable with =~ */
8419                 other->op_flags |= OPf_SPECIAL;
8420
8421             other->op_folded = 1;
8422             return other;
8423         }
8424         else {
8425             /* Elide the rhs, since the outcome is entirely determined by
8426              * the (constant) lhs */
8427
8428             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
8429             const OP *o2 = other;
8430             if ( ! (o2->op_type == OP_LIST
8431                     && (( o2 = cUNOPx(o2)->op_first))
8432                     && o2->op_type == OP_PUSHMARK
8433                     && (( o2 = OpSIBLING(o2))) )
8434             )
8435                 o2 = other;
8436             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
8437                         || o2->op_type == OP_PADHV)
8438                 && o2->op_private & OPpLVAL_INTRO
8439                 && !(o2->op_private & OPpPAD_STATE))
8440             {
8441         Perl_croak(aTHX_ "This use of my() in false conditional is "
8442                           "no longer allowed");
8443             }
8444
8445             *otherp = NULL;
8446             if (cstop->op_type == OP_CONST)
8447                 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
8448             op_free(other);
8449             return first;
8450         }
8451     }
8452     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
8453         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
8454     {
8455         const OP * const k1 = cUNOPx(first)->op_first;
8456         const OP * const k2 = OpSIBLING(k1);
8457         OPCODE warnop = 0;
8458         switch (first->op_type)
8459         {
8460         case OP_NULL:
8461             if (k2 && k2->op_type == OP_READLINE
8462                   && (k2->op_flags & OPf_STACKED)
8463                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8464             {
8465                 warnop = k2->op_type;
8466             }
8467             break;
8468
8469         case OP_SASSIGN:
8470             if (k1->op_type == OP_READDIR
8471                   || k1->op_type == OP_GLOB
8472                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8473                  || k1->op_type == OP_EACH
8474                  || k1->op_type == OP_AEACH)
8475             {
8476                 warnop = ((k1->op_type == OP_NULL)
8477                           ? (OPCODE)k1->op_targ : k1->op_type);
8478             }
8479             break;
8480         }
8481         if (warnop) {
8482             const line_t oldline = CopLINE(PL_curcop);
8483             /* This ensures that warnings are reported at the first line
8484                of the construction, not the last.  */
8485             CopLINE_set(PL_curcop, PL_parser->copline);
8486             Perl_warner(aTHX_ packWARN(WARN_MISC),
8487                  "Value of %s%s can be \"0\"; test with defined()",
8488                  PL_op_desc[warnop],
8489                  ((warnop == OP_READLINE || warnop == OP_GLOB)
8490                   ? " construct" : "() operator"));
8491             CopLINE_set(PL_curcop, oldline);
8492         }
8493     }
8494
8495     /* optimize AND and OR ops that have NOTs as children */
8496     if (first->op_type == OP_NOT
8497         && (first->op_flags & OPf_KIDS)
8498         && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
8499             || (other->op_type == OP_NOT))  /* if (!$x && !$y) { } */
8500         ) {
8501         if (type == OP_AND || type == OP_OR) {
8502             if (type == OP_AND)
8503                 type = OP_OR;
8504             else
8505                 type = OP_AND;
8506             op_null(first);
8507             if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
8508                 op_null(other);
8509                 prepend_not = 1; /* prepend a NOT op later */
8510             }
8511         }
8512     }
8513
8514     logop = alloc_LOGOP(type, first, LINKLIST(other));
8515     logop->op_flags |= (U8)flags;
8516     logop->op_private = (U8)(1 | (flags >> 8));
8517
8518     /* establish postfix order */
8519     logop->op_next = LINKLIST(first);
8520     first->op_next = (OP*)logop;
8521     assert(!OpHAS_SIBLING(first));
8522     op_sibling_splice((OP*)logop, first, 0, other);
8523
8524     CHECKOP(type,logop);
8525
8526     o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
8527                 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
8528                 (OP*)logop);
8529     other->op_next = o;
8530
8531     return o;
8532 }
8533
8534 /*
8535 =for apidoc newCONDOP
8536
8537 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
8538 op.  C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
8539 will be set automatically, and, shifted up eight bits, the eight bits of
8540 C<op_private>, except that the bit with value 1 is automatically set.
8541 C<first> supplies the expression selecting between the two branches,
8542 and C<trueop> and C<falseop> supply the branches; they are consumed by
8543 this function and become part of the constructed op tree.
8544
8545 =cut
8546 */
8547
8548 OP *
8549 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
8550 {
8551     LOGOP *logop;
8552     OP *start;
8553     OP *o;
8554     OP *cstop;
8555
8556     PERL_ARGS_ASSERT_NEWCONDOP;
8557
8558     if (!falseop)
8559         return newLOGOP(OP_AND, 0, first, trueop);
8560     if (!trueop)
8561         return newLOGOP(OP_OR, 0, first, falseop);
8562
8563     scalarboolean(first);
8564     if ((cstop = search_const(first))) {
8565         /* Left or right arm of the conditional?  */
8566         const bool left = SvTRUE(cSVOPx(cstop)->op_sv);
8567         OP *live = left ? trueop : falseop;
8568         OP *const dead = left ? falseop : trueop;
8569         if (cstop->op_private & OPpCONST_BARE &&
8570             cstop->op_private & OPpCONST_STRICT) {
8571             no_bareword_allowed(cstop);
8572         }
8573         op_free(first);
8574         op_free(dead);
8575         if (live->op_type == OP_LEAVE)
8576             live = newUNOP(OP_NULL, OPf_SPECIAL, live);
8577         else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
8578               || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
8579             /* Mark the op as being unbindable with =~ */
8580             live->op_flags |= OPf_SPECIAL;
8581         live->op_folded = 1;
8582         return live;
8583     }
8584     logop = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop));
8585     logop->op_flags |= (U8)flags;
8586     logop->op_private = (U8)(1 | (flags >> 8));
8587     logop->op_next = LINKLIST(falseop);
8588
8589     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
8590             logop);
8591
8592     /* establish postfix order */
8593     start = LINKLIST(first);
8594     first->op_next = (OP*)logop;
8595
8596     /* make first, trueop, falseop siblings */
8597     op_sibling_splice((OP*)logop, first,  0, trueop);
8598     op_sibling_splice((OP*)logop, trueop, 0, falseop);
8599
8600     o = newUNOP(OP_NULL, 0, (OP*)logop);
8601
8602     trueop->op_next = falseop->op_next = o;
8603
8604     o->op_next = start;
8605     return o;
8606 }
8607
8608 /*
8609 =for apidoc newTRYCATCHOP
8610
8611 Constructs and returns a conditional execution statement that implements
8612 the C<try>/C<catch> semantics.  First the op tree in C<tryblock> is executed,
8613 inside a context that traps exceptions.  If an exception occurs then the
8614 optree in C<catchblock> is executed, with the trapped exception set into the
8615 lexical variable given by C<catchvar> (which must be an op of type
8616 C<OP_PADSV>).  All the optrees are consumed by this function and become part
8617 of the returned op tree.
8618
8619 The C<flags> argument is currently ignored.
8620
8621 =cut
8622  */
8623
8624 OP *
8625 Perl_newTRYCATCHOP(pTHX_ I32 flags, OP *tryblock, OP *catchvar, OP *catchblock)
8626 {
8627     OP *o, *catchop;
8628
8629     PERL_ARGS_ASSERT_NEWTRYCATCHOP;
8630     assert(catchvar->op_type == OP_PADSV);
8631
8632     PERL_UNUSED_ARG(flags);
8633
8634     /* The returned optree is shaped as:
8635      *   LISTOP leavetrycatch
8636      *       LOGOP entertrycatch
8637      *       LISTOP poptry
8638      *           $tryblock here
8639      *       LOGOP catch
8640      *           $catchblock here
8641      */
8642
8643     if(tryblock->op_type != OP_LINESEQ)
8644         tryblock = op_convert_list(OP_LINESEQ, 0, tryblock);
8645     OpTYPE_set(tryblock, OP_POPTRY);
8646
8647     /* Manually construct a naked LOGOP.
8648      * Normally if we call newLOGOP the returned value is a UNOP(OP_NULL)
8649      * containing the LOGOP we wanted as its op_first */
8650     catchop = (OP *)alloc_LOGOP(OP_CATCH, newOP(OP_NULL, 0), catchblock);
8651     OpMORESIB_set(cUNOPx(catchop)->op_first, catchblock);
8652     OpLASTSIB_set(catchblock, catchop);
8653
8654     /* Inject the catchvar's pad offset into the OP_CATCH targ */
8655     cLOGOPx(catchop)->op_targ = catchvar->op_targ;
8656     op_free(catchvar);
8657
8658     /* Build the optree structure */
8659     o = newLISTOP(OP_LIST, 0, tryblock, catchop);
8660     o = op_convert_list(OP_ENTERTRYCATCH, 0, o);
8661
8662     return o;
8663 }
8664
8665 /*
8666 =for apidoc newRANGE
8667
8668 Constructs and returns a C<range> op, with subordinate C<flip> and
8669 C<flop> ops.  C<flags> gives the eight bits of C<op_flags> for the
8670 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
8671 for both the C<flip> and C<range> ops, except that the bit with value
8672 1 is automatically set.  C<left> and C<right> supply the expressions
8673 controlling the endpoints of the range; they are consumed by this function
8674 and become part of the constructed op tree.
8675
8676 =cut
8677 */
8678
8679 OP *
8680 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
8681 {
8682     LOGOP *range;
8683     OP *flip;
8684     OP *flop;
8685     OP *leftstart;
8686     OP *o;
8687
8688     PERL_ARGS_ASSERT_NEWRANGE;
8689
8690     range = alloc_LOGOP(OP_RANGE, left, LINKLIST(right));
8691     range->op_flags = OPf_KIDS;
8692     leftstart = LINKLIST(left);
8693     range->op_private = (U8)(1 | (flags >> 8));
8694
8695     /* make left and right siblings */
8696     op_sibling_splice((OP*)range, left, 0, right);
8697
8698     range->op_next = (OP*)range;
8699     flip = newUNOP(OP_FLIP, flags, (OP*)range);
8700     flop = newUNOP(OP_FLOP, 0, flip);
8701     o = newUNOP(OP_NULL, 0, flop);
8702     LINKLIST(flop);
8703     range->op_next = leftstart;
8704
8705     left->op_next = flip;
8706     right->op_next = flop;
8707
8708     range->op_targ =
8709         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
8710     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
8711     flip->op_targ =
8712         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
8713     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
8714     SvPADTMP_on(PAD_SV(flip->op_targ));
8715
8716     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
8717     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
8718
8719     /* check barewords before they might be optimized aways */
8720     if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
8721         no_bareword_allowed(left);
8722     if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
8723         no_bareword_allowed(right);
8724
8725     flip->op_next = o;
8726     if (!flip->op_private || !flop->op_private)
8727         LINKLIST(o);            /* blow off optimizer unless constant */
8728
8729     return o;
8730 }
8731
8732 /*
8733 =for apidoc newLOOPOP
8734
8735 Constructs, checks, and returns an op tree expressing a loop.  This is
8736 only a loop in the control flow through the op tree; it does not have
8737 the heavyweight loop structure that allows exiting the loop by C<last>
8738 and suchlike.  C<flags> gives the eight bits of C<op_flags> for the
8739 top-level op, except that some bits will be set automatically as required.
8740 C<expr> supplies the expression controlling loop iteration, and C<block>
8741 supplies the body of the loop; they are consumed by this function and
8742 become part of the constructed op tree.  C<debuggable> is currently
8743 unused and should always be 1.
8744
8745 =cut
8746 */
8747
8748 OP *
8749 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
8750 {
8751     OP* listop;
8752     OP* o;
8753     const bool once = block && block->op_flags & OPf_SPECIAL &&
8754                       block->op_type == OP_NULL;
8755
8756     PERL_UNUSED_ARG(debuggable);
8757
8758     if (expr) {
8759         if (once && (
8760               (expr->op_type == OP_CONST && !SvTRUE(cSVOPx(expr)->op_sv))
8761            || (  expr->op_type == OP_NOT
8762               && cUNOPx(expr)->op_first->op_type == OP_CONST
8763               && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
8764               )
8765            ))
8766             /* Return the block now, so that S_new_logop does not try to
8767                fold it away. */
8768         {
8769             op_free(expr);
8770             return block;       /* do {} while 0 does once */
8771         }
8772
8773         if (expr->op_type == OP_READLINE
8774             || expr->op_type == OP_READDIR
8775             || expr->op_type == OP_GLOB
8776             || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
8777             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
8778             expr = newUNOP(OP_DEFINED, 0,
8779                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
8780         } else if (expr->op_flags & OPf_KIDS) {
8781             const OP * const k1 = cUNOPx(expr)->op_first;
8782             const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
8783             switch (expr->op_type) {
8784               case OP_NULL:
8785                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
8786                       && (k2->op_flags & OPf_STACKED)
8787                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8788                     expr = newUNOP(OP_DEFINED, 0, expr);
8789                 break;
8790
8791               case OP_SASSIGN:
8792                 if (k1 && (k1->op_type == OP_READDIR
8793                       || k1->op_type == OP_GLOB
8794                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8795                      || k1->op_type == OP_EACH
8796                      || k1->op_type == OP_AEACH))
8797                     expr = newUNOP(OP_DEFINED, 0, expr);
8798                 break;
8799             }
8800         }
8801     }
8802
8803     /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
8804      * op, in listop. This is wrong. [perl #27024] */
8805     if (!block)
8806         block = newOP(OP_NULL, 0);
8807     listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
8808     o = new_logop(OP_AND, 0, &expr, &listop);
8809
8810     if (once) {
8811         ASSUME(listop);
8812     }
8813
8814     if (listop)
8815         cLISTOPx(listop)->op_last->op_next = LINKLIST(o);
8816
8817     if (once && o != listop)
8818     {
8819         assert(cUNOPo->op_first->op_type == OP_AND
8820             || cUNOPo->op_first->op_type == OP_OR);
8821         o->op_next = cLOGOPx(cUNOPo->op_first)->op_other;
8822     }
8823
8824     if (o == listop)
8825         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
8826
8827     o->op_flags |= flags;
8828     o = op_scope(o);
8829     o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
8830     return o;
8831 }
8832
8833 /*
8834 =for apidoc newWHILEOP
8835
8836 Constructs, checks, and returns an op tree expressing a C<while> loop.
8837 This is a heavyweight loop, with structure that allows exiting the loop
8838 by C<last> and suchlike.
8839
8840 C<loop> is an optional preconstructed C<enterloop> op to use in the
8841 loop; if it is null then a suitable op will be constructed automatically.
8842 C<expr> supplies the loop's controlling expression.  C<block> supplies the
8843 main body of the loop, and C<cont> optionally supplies a C<continue> block
8844 that operates as a second half of the body.  All of these optree inputs
8845 are consumed by this function and become part of the constructed op tree.
8846
8847 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
8848 op and, shifted up eight bits, the eight bits of C<op_private> for
8849 the C<leaveloop> op, except that (in both cases) some bits will be set
8850 automatically.  C<debuggable> is currently unused and should always be 1.
8851 C<has_my> can be supplied as true to force the
8852 loop body to be enclosed in its own scope.
8853
8854 =cut
8855 */
8856
8857 OP *
8858 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
8859         OP *expr, OP *block, OP *cont, I32 has_my)
8860 {
8861     OP *redo;
8862     OP *next = NULL;
8863     OP *listop;
8864     OP *o;
8865     U8 loopflags = 0;
8866
8867     PERL_UNUSED_ARG(debuggable);
8868
8869     if (expr) {
8870         if (expr->op_type == OP_READLINE
8871          || expr->op_type == OP_READDIR
8872          || expr->op_type == OP_GLOB
8873          || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
8874                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
8875             expr = newUNOP(OP_DEFINED, 0,
8876                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
8877         } else if (expr->op_flags & OPf_KIDS) {
8878             const OP * const k1 = cUNOPx(expr)->op_first;
8879             const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
8880             switch (expr->op_type) {
8881               case OP_NULL:
8882                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
8883                       && (k2->op_flags & OPf_STACKED)
8884                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8885                     expr = newUNOP(OP_DEFINED, 0, expr);
8886                 break;
8887
8888               case OP_SASSIGN:
8889                 if (k1 && (k1->op_type == OP_READDIR
8890                       || k1->op_type == OP_GLOB
8891                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8892                      || k1->op_type == OP_EACH
8893                      || k1->op_type == OP_AEACH))
8894                     expr = newUNOP(OP_DEFINED, 0, expr);
8895                 break;
8896             }
8897         }
8898     }
8899
8900     if (!block)
8901         block = newOP(OP_NULL, 0);
8902     else if (cont || has_my) {
8903         block = op_scope(block);
8904     }
8905
8906     if (cont) {
8907         next = LINKLIST(cont);
8908     }
8909     if (expr) {
8910         OP * const unstack = newOP(OP_UNSTACK, 0);
8911         if (!next)
8912             next = unstack;
8913         cont = op_append_elem(OP_LINESEQ, cont, unstack);
8914     }
8915
8916     assert(block);
8917     listop = op_append_list(OP_LINESEQ, block, cont);
8918     assert(listop);
8919     redo = LINKLIST(listop);
8920
8921     if (expr) {
8922         scalar(listop);
8923         o = new_logop(OP_AND, 0, &expr, &listop);
8924         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
8925             op_free((OP*)loop);
8926             return expr;                /* listop already freed by new_logop */
8927         }
8928         if (listop)
8929             cLISTOPx(listop)->op_last->op_next =
8930                 (o == listop ? redo : LINKLIST(o));
8931     }
8932     else
8933         o = listop;
8934
8935     if (!loop) {
8936         NewOp(1101,loop,1,LOOP);
8937         OpTYPE_set(loop, OP_ENTERLOOP);
8938         loop->op_private = 0;
8939         loop->op_next = (OP*)loop;
8940     }
8941
8942     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
8943
8944     loop->op_redoop = redo;
8945     loop->op_lastop = o;
8946     o->op_private |= loopflags;
8947
8948     if (next)
8949         loop->op_nextop = next;
8950     else
8951         loop->op_nextop = o;
8952
8953     o->op_flags |= flags;
8954     o->op_private |= (flags >> 8);
8955     return o;
8956 }
8957
8958 /*
8959 =for apidoc newFOROP
8960
8961 Constructs, checks, and returns an op tree expressing a C<foreach>
8962 loop (iteration through a list of values).  This is a heavyweight loop,
8963 with structure that allows exiting the loop by C<last> and suchlike.
8964
8965 C<sv> optionally supplies the variable(s) that will be aliased to each
8966 item in turn; if null, it defaults to C<$_>.
8967 C<expr> supplies the list of values to iterate over.  C<block> supplies
8968 the main body of the loop, and C<cont> optionally supplies a C<continue>
8969 block that operates as a second half of the body.  All of these optree
8970 inputs are consumed by this function and become part of the constructed
8971 op tree.
8972
8973 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
8974 op and, shifted up eight bits, the eight bits of C<op_private> for
8975 the C<leaveloop> op, except that (in both cases) some bits will be set
8976 automatically.
8977
8978 =cut
8979 */
8980
8981 OP *
8982 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
8983 {
8984     LOOP *loop;
8985     OP *iter;
8986     PADOFFSET padoff = 0;
8987     PADOFFSET how_many_more = 0;
8988     I32 iterflags = 0;
8989     I32 iterpflags = 0;
8990     bool parens = 0;
8991
8992     PERL_ARGS_ASSERT_NEWFOROP;
8993
8994     if (sv) {
8995         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
8996             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
8997             OpTYPE_set(sv, OP_RV2GV);
8998
8999             /* The op_type check is needed to prevent a possible segfault
9000              * if the loop variable is undeclared and 'strict vars' is in
9001              * effect. This is illegal but is nonetheless parsed, so we
9002              * may reach this point with an OP_CONST where we're expecting
9003              * an OP_GV.
9004              */
9005             if (cUNOPx(sv)->op_first->op_type == OP_GV
9006              && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
9007                 iterpflags |= OPpITER_DEF;
9008         }
9009         else if (sv->op_type == OP_PADSV) { /* private variable */
9010             if (sv->op_flags & OPf_PARENS) {
9011                 /* handle degenerate 1-var form of "for my ($x, ...)" */
9012                 sv->op_private |= OPpLVAL_INTRO;
9013                 parens = 1;
9014             }
9015             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
9016             padoff = sv->op_targ;
9017             sv->op_targ = 0;
9018             op_free(sv);
9019             sv = NULL;
9020             PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
9021         }
9022         else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
9023             NOOP;
9024         else if (sv->op_type == OP_LIST) {
9025             LISTOP *list = cLISTOPx(sv);
9026             OP *pushmark = list->op_first;
9027             OP *first_padsv;
9028             UNOP *padsv;
9029             PADOFFSET i;
9030
9031             iterpflags = OPpLVAL_INTRO; /* for my ($k, $v) () */
9032             parens = 1;
9033
9034             if (!pushmark || pushmark->op_type != OP_PUSHMARK) {
9035                 Perl_croak(aTHX_ "panic: newFORLOOP, found %s, expecting pushmark",
9036                            pushmark ? PL_op_desc[pushmark->op_type] : "NULL");
9037             }
9038             first_padsv = OpSIBLING(pushmark);
9039             if (!first_padsv || first_padsv->op_type != OP_PADSV) {
9040                 Perl_croak(aTHX_ "panic: newFORLOOP, found %s, expecting padsv",
9041                            first_padsv ? PL_op_desc[first_padsv->op_type] : "NULL");
9042             }
9043             padoff = first_padsv->op_targ;
9044
9045             /* There should be at least one more PADSV to find, and the ops
9046                should have consecutive values in targ: */
9047             padsv = cUNOPx(OpSIBLING(first_padsv));
9048             do {
9049                 if (!padsv || padsv->op_type != OP_PADSV) {
9050                     Perl_croak(aTHX_ "panic: newFORLOOP, found %s at %zd, expecting padsv",
9051                                padsv ? PL_op_desc[padsv->op_type] : "NULL",
9052                                how_many_more);
9053                 }
9054                 ++how_many_more;
9055                 if (padsv->op_targ != padoff + how_many_more) {
9056                     Perl_croak(aTHX_ "panic: newFORLOOP, padsv at %zd targ is %zd, not %zd",
9057                                how_many_more, padsv->op_targ, padoff + how_many_more);
9058                 }
9059
9060                 padsv = cUNOPx(OpSIBLING(padsv));
9061             } while (padsv);
9062
9063             /* OK, this optree has the shape that we expected. So now *we*
9064                "claim" the Pad slots: */
9065             first_padsv->op_targ = 0;
9066             PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
9067
9068             i = padoff;
9069
9070             padsv = cUNOPx(OpSIBLING(first_padsv));
9071             do {
9072                 ++i;
9073                 padsv->op_targ = 0;
9074                 PAD_COMPNAME_GEN_set(i, PERL_INT_MAX);
9075
9076                 padsv = cUNOPx(OpSIBLING(padsv));
9077             } while (padsv);
9078
9079             op_free(sv);
9080             sv = NULL;
9081         }
9082         else
9083             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
9084         if (padoff) {
9085             PADNAME * const pn = PAD_COMPNAME(padoff);
9086             const char * const name = PadnamePV(pn);
9087
9088             if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
9089                 iterpflags |= OPpITER_DEF;
9090         }
9091     }
9092     else {
9093         sv = newGVOP(OP_GV, 0, PL_defgv);
9094         iterpflags |= OPpITER_DEF;
9095     }
9096
9097     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
9098         expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), TRUE), OP_GREPSTART);
9099         iterflags |= OPf_STACKED;
9100     }
9101     else if (expr->op_type == OP_NULL &&
9102              (expr->op_flags & OPf_KIDS) &&
9103              cBINOPx(expr)->op_first->op_type == OP_FLOP)
9104     {
9105         /* Basically turn for($x..$y) into the same as for($x,$y), but we
9106          * set the STACKED flag to indicate that these values are to be
9107          * treated as min/max values by 'pp_enteriter'.
9108          */
9109         const UNOP* const flip = cUNOPx(cUNOPx(cBINOPx(expr)->op_first)->op_first);
9110         LOGOP* const range = cLOGOPx(flip->op_first);
9111         OP* const left  = range->op_first;
9112         OP* const right = OpSIBLING(left);
9113         LISTOP* listop;
9114
9115         range->op_flags &= ~OPf_KIDS;
9116         /* detach range's children */
9117         op_sibling_splice((OP*)range, NULL, -1, NULL);
9118
9119         listop = cLISTOPx(newLISTOP(OP_LIST, 0, left, right));
9120         listop->op_first->op_next = range->op_next;
9121         left->op_next = range->op_other;
9122         right->op_next = (OP*)listop;
9123         listop->op_next = listop->op_first;
9124
9125         op_free(expr);
9126         expr = (OP*)(listop);
9127         op_null(expr);
9128         iterflags |= OPf_STACKED;
9129     }
9130     else {
9131         expr = op_lvalue(force_list(expr, TRUE), OP_GREPSTART);
9132     }
9133
9134     loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
9135                                   op_append_elem(OP_LIST, list(expr),
9136                                                  scalar(sv)));
9137     assert(!loop->op_next);
9138     /* for my  $x () sets OPpLVAL_INTRO;
9139      * for our $x () sets OPpOUR_INTRO */
9140     loop->op_private = (U8)iterpflags;
9141
9142     /* upgrade loop from a LISTOP to a LOOPOP;
9143      * keep it in-place if there's space */
9144     if (loop->op_slabbed
9145         &&    OpSLOT(loop)->opslot_size
9146             < SIZE_TO_PSIZE(sizeof(LOOP) + OPSLOT_HEADER))
9147     {
9148         /* no space; allocate new op */
9149         LOOP *tmp;
9150         NewOp(1234,tmp,1,LOOP);
9151         Copy(loop,tmp,1,LISTOP);
9152         assert(loop->op_last->op_sibparent == (OP*)loop);
9153         OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
9154         S_op_destroy(aTHX_ (OP*)loop);
9155         loop = tmp;
9156     }
9157     else if (!loop->op_slabbed)
9158     {
9159         /* loop was malloc()ed */
9160         loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
9161         OpLASTSIB_set(loop->op_last, (OP*)loop);
9162     }
9163     loop->op_targ = padoff;
9164     if (parens)
9165         /* hint to deparser that this:  for my (...) ... */
9166         loop->op_flags |= OPf_PARENS;
9167     iter = newOP(OP_ITER, 0);
9168     iter->op_targ = how_many_more;
9169     return newWHILEOP(flags, 1, loop, iter, block, cont, 0);
9170 }
9171
9172 /*
9173 =for apidoc newLOOPEX
9174
9175 Constructs, checks, and returns a loop-exiting op (such as C<goto>
9176 or C<last>).  C<type> is the opcode.  C<label> supplies the parameter
9177 determining the target of the op; it is consumed by this function and
9178 becomes part of the constructed op tree.
9179
9180 =cut
9181 */
9182
9183 OP*
9184 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
9185 {
9186     OP *o = NULL;
9187
9188     PERL_ARGS_ASSERT_NEWLOOPEX;
9189
9190     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
9191         || type == OP_CUSTOM);
9192
9193     if (type != OP_GOTO) {
9194         /* "last()" means "last" */
9195         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
9196             o = newOP(type, OPf_SPECIAL);
9197         }
9198     }
9199     else {
9200         /* Check whether it's going to be a goto &function */
9201         if (label->op_type == OP_ENTERSUB
9202                 && !(label->op_flags & OPf_STACKED))
9203             label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
9204     }
9205
9206     /* Check for a constant argument */
9207     if (label->op_type == OP_CONST) {
9208             SV * const sv = cSVOPx(label)->op_sv;
9209             STRLEN l;
9210             const char *s = SvPV_const(sv,l);
9211             if (l == strlen(s)) {
9212                 o = newPVOP(type,
9213                             SvUTF8(cSVOPx(label)->op_sv),
9214                             savesharedpv(
9215                                 SvPV_nolen_const(cSVOPx(label)->op_sv)));
9216             }
9217     }
9218
9219     /* If we have already created an op, we do not need the label. */
9220     if (o)
9221                 op_free(label);
9222     else o = newUNOP(type, OPf_STACKED, label);
9223
9224     PL_hints |= HINT_BLOCK_SCOPE;
9225     return o;
9226 }
9227
9228 /* if the condition is a literal array or hash
9229    (or @{ ... } etc), make a reference to it.
9230  */
9231 STATIC OP *
9232 S_ref_array_or_hash(pTHX_ OP *cond)
9233 {
9234     if (cond
9235     && (cond->op_type == OP_RV2AV
9236     ||  cond->op_type == OP_PADAV
9237     ||  cond->op_type == OP_RV2HV
9238     ||  cond->op_type == OP_PADHV))
9239
9240         return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
9241
9242     else if(cond
9243     && (cond->op_type == OP_ASLICE
9244     ||  cond->op_type == OP_KVASLICE
9245     ||  cond->op_type == OP_HSLICE
9246     ||  cond->op_type == OP_KVHSLICE)) {
9247
9248         /* anonlist now needs a list from this op, was previously used in
9249          * scalar context */
9250         cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
9251         cond->op_flags |= OPf_WANT_LIST;
9252
9253         return newANONLIST(op_lvalue(cond, OP_ANONLIST));
9254     }
9255
9256     else
9257         return cond;
9258 }
9259
9260 /* These construct the optree fragments representing given()
9261    and when() blocks.
9262
9263    entergiven and enterwhen are LOGOPs; the op_other pointer
9264    points up to the associated leave op. We need this so we
9265    can put it in the context and make break/continue work.
9266    (Also, of course, pp_enterwhen will jump straight to
9267    op_other if the match fails.)
9268  */
9269
9270 STATIC OP *
9271 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
9272                    I32 enter_opcode, I32 leave_opcode,
9273                    PADOFFSET entertarg)
9274 {
9275     LOGOP *enterop;
9276     OP *o;
9277
9278     PERL_ARGS_ASSERT_NEWGIVWHENOP;
9279     PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
9280
9281     enterop = alloc_LOGOP(enter_opcode, block, NULL);
9282     enterop->op_targ = 0;
9283     enterop->op_private = 0;
9284
9285     o = newUNOP(leave_opcode, 0, (OP *) enterop);
9286
9287     if (cond) {
9288         /* prepend cond if we have one */
9289         op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
9290
9291         o->op_next = LINKLIST(cond);
9292         cond->op_next = (OP *) enterop;
9293     }
9294     else {
9295         /* This is a default {} block */
9296         enterop->op_flags |= OPf_SPECIAL;
9297         o      ->op_flags |= OPf_SPECIAL;
9298
9299         o->op_next = (OP *) enterop;
9300     }
9301
9302     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
9303                                        entergiven and enterwhen both
9304                                        use ck_null() */
9305
9306     enterop->op_next = LINKLIST(block);
9307     block->op_next = enterop->op_other = o;
9308
9309     return o;
9310 }
9311
9312
9313 /* For the purposes of 'when(implied_smartmatch)'
9314  *              versus 'when(boolean_expression)',
9315  * does this look like a boolean operation? For these purposes
9316    a boolean operation is:
9317      - a subroutine call [*]
9318      - a logical connective
9319      - a comparison operator
9320      - a filetest operator, with the exception of -s -M -A -C
9321      - defined(), exists() or eof()
9322      - /$re/ or $foo =~ /$re/
9323
9324    [*] possibly surprising
9325  */
9326 STATIC bool
9327 S_looks_like_bool(pTHX_ const OP *o)
9328 {
9329     PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
9330
9331     switch(o->op_type) {
9332         case OP_OR:
9333         case OP_DOR:
9334             return looks_like_bool(cLOGOPo->op_first);
9335
9336         case OP_AND:
9337         {
9338             OP* sibl = OpSIBLING(cLOGOPo->op_first);
9339             ASSUME(sibl);
9340             return (
9341                 looks_like_bool(cLOGOPo->op_first)
9342              && looks_like_bool(sibl));
9343         }
9344
9345         case OP_NULL:
9346         case OP_SCALAR:
9347             return (
9348                 o->op_flags & OPf_KIDS
9349             && looks_like_bool(cUNOPo->op_first));
9350
9351         case OP_ENTERSUB:
9352
9353         case OP_NOT:    case OP_XOR:
9354
9355         case OP_EQ:     case OP_NE:     case OP_LT:
9356         case OP_GT:     case OP_LE:     case OP_GE:
9357
9358         case OP_I_EQ:   case OP_I_NE:   case OP_I_LT:
9359         case OP_I_GT:   case OP_I_LE:   case OP_I_GE:
9360
9361         case OP_SEQ:    case OP_SNE:    case OP_SLT:
9362         case OP_SGT:    case OP_SLE:    case OP_SGE:
9363
9364         case OP_SMARTMATCH:
9365
9366         case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
9367         case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
9368         case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
9369         case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
9370         case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
9371         case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
9372         case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
9373         case OP_FTTEXT:   case OP_FTBINARY:
9374
9375         case OP_DEFINED: case OP_EXISTS:
9376         case OP_MATCH:   case OP_EOF:
9377
9378         case OP_FLOP:
9379
9380             return TRUE;
9381
9382         case OP_INDEX:
9383         case OP_RINDEX:
9384             /* optimised-away (index() != -1) or similar comparison */
9385             if (o->op_private & OPpTRUEBOOL)
9386                 return TRUE;
9387             return FALSE;
9388
9389         case OP_CONST:
9390             /* Detect comparisons that have been optimized away */
9391             if (cSVOPo->op_sv == &PL_sv_yes
9392             ||  cSVOPo->op_sv == &PL_sv_no)
9393
9394                 return TRUE;
9395             else
9396                 return FALSE;
9397         /* FALLTHROUGH */
9398         default:
9399             return FALSE;
9400     }
9401 }
9402
9403
9404 /*
9405 =for apidoc newGIVENOP
9406
9407 Constructs, checks, and returns an op tree expressing a C<given> block.
9408 C<cond> supplies the expression to whose value C<$_> will be locally
9409 aliased, and C<block> supplies the body of the C<given> construct; they
9410 are consumed by this function and become part of the constructed op tree.
9411 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
9412
9413 =cut
9414 */
9415
9416 OP *
9417 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
9418 {
9419     PERL_ARGS_ASSERT_NEWGIVENOP;
9420     PERL_UNUSED_ARG(defsv_off);
9421
9422     assert(!defsv_off);
9423     return newGIVWHENOP(
9424         ref_array_or_hash(cond),
9425         block,
9426         OP_ENTERGIVEN, OP_LEAVEGIVEN,
9427         0);
9428 }
9429
9430 /*
9431 =for apidoc newWHENOP
9432
9433 Constructs, checks, and returns an op tree expressing a C<when> block.
9434 C<cond> supplies the test expression, and C<block> supplies the block
9435 that will be executed if the test evaluates to true; they are consumed
9436 by this function and become part of the constructed op tree.  C<cond>
9437 will be interpreted DWIMically, often as a comparison against C<$_>,
9438 and may be null to generate a C<default> block.
9439
9440 =cut
9441 */
9442
9443 OP *
9444 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
9445 {
9446     const bool cond_llb = (!cond || looks_like_bool(cond));
9447     OP *cond_op;
9448
9449     PERL_ARGS_ASSERT_NEWWHENOP;
9450
9451     if (cond_llb)
9452         cond_op = cond;
9453     else {
9454         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
9455                 newDEFSVOP(),
9456                 scalar(ref_array_or_hash(cond)));
9457     }
9458
9459     return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
9460 }
9461
9462 /*
9463 =for apidoc newDEFEROP
9464
9465 Constructs and returns a deferred-block statement that implements the
9466 C<defer> semantics.  The C<block> optree is consumed by this function and
9467 becomes part of the returned optree.
9468
9469 The C<flags> argument carries additional flags to set on the returned op,
9470 including the C<op_private> field.
9471
9472 =cut
9473  */
9474
9475 OP *
9476 Perl_newDEFEROP(pTHX_ I32 flags, OP *block)
9477 {
9478     OP *o, *start, *blockfirst;
9479
9480     PERL_ARGS_ASSERT_NEWDEFEROP;
9481
9482     start = LINKLIST(block);
9483
9484     /* Hide the block inside an OP_NULL with no exection */
9485     block = newUNOP(OP_NULL, 0, block);
9486     block->op_next = block;
9487
9488     o = (OP *)alloc_LOGOP(OP_PUSHDEFER, block, start);
9489     o->op_flags |= OPf_WANT_VOID | (U8)(flags);
9490     o->op_private = (U8)(flags >> 8);
9491
9492     /* Terminate the block */
9493     blockfirst = cUNOPx(block)->op_first;
9494     assert(blockfirst->op_type == OP_SCOPE || blockfirst->op_type == OP_LEAVE);
9495     blockfirst->op_next = NULL;
9496
9497     return o;
9498 }
9499
9500 /*
9501 =for apidoc op_wrap_finally
9502
9503 Wraps the given C<block> optree fragment in its own scoped block, arranging
9504 for the C<finally> optree fragment to be invoked when leaving that block for
9505 any reason. Both optree fragments are consumed and the combined result is
9506 returned.
9507
9508 =cut
9509 */
9510
9511 OP *
9512 Perl_op_wrap_finally(pTHX_ OP *block, OP *finally)
9513 {
9514     PERL_ARGS_ASSERT_OP_WRAP_FINALLY;
9515
9516     /* TODO: If block is already an ENTER/LEAVE-wrapped line sequence we can
9517      * just splice the DEFEROP in at the top, for efficiency.
9518      */
9519
9520     OP *o = newLISTOP(OP_LINESEQ, 0, newDEFEROP((OPpDEFER_FINALLY << 8), finally), block);
9521     o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
9522     OpTYPE_set(o, OP_LEAVE);
9523
9524     return o;
9525 }
9526
9527 /* must not conflict with SVf_UTF8 */
9528 #define CV_CKPROTO_CURSTASH     0x1
9529
9530 void
9531 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
9532                     const STRLEN len, const U32 flags)
9533 {
9534     SV *name = NULL, *msg;
9535     const char * cvp = SvROK(cv)
9536                         ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
9537                            ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
9538                            : ""
9539                         : CvPROTO(cv);
9540     STRLEN clen = CvPROTOLEN(cv), plen = len;
9541
9542     PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
9543
9544     if (p == NULL && cvp == NULL)
9545         return;
9546
9547     if (!ckWARN_d(WARN_PROTOTYPE))
9548         return;
9549
9550     if (p && cvp) {
9551         p = S_strip_spaces(aTHX_ p, &plen);
9552         cvp = S_strip_spaces(aTHX_ cvp, &clen);
9553         if ((flags & SVf_UTF8) == SvUTF8(cv)) {
9554             if (plen == clen && memEQ(cvp, p, plen))
9555                 return;
9556         } else {
9557             if (flags & SVf_UTF8) {
9558                 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
9559                     return;
9560             }
9561             else {
9562                 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
9563                     return;
9564             }
9565         }
9566     }
9567
9568     msg = sv_newmortal();
9569
9570     if (gv)
9571     {
9572         if (isGV(gv))
9573             gv_efullname3(name = sv_newmortal(), gv, NULL);
9574         else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
9575             name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
9576         else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
9577             name = newSVhek_mortal(HvNAME_HEK(PL_curstash));
9578             sv_catpvs(name, "::");
9579             if (SvROK(gv)) {
9580                 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
9581                 assert (CvNAMED(SvRV_const(gv)));
9582                 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
9583             }
9584             else sv_catsv(name, (SV *)gv);
9585         }
9586         else name = (SV *)gv;
9587     }
9588     sv_setpvs(msg, "Prototype mismatch:");
9589     if (name)
9590         Perl_sv_catpvf(aTHX_ msg, " sub %" SVf, SVfARG(name));
9591     if (cvp)
9592         Perl_sv_catpvf(aTHX_ msg, " (%" UTF8f ")",
9593             UTF8fARG(SvUTF8(cv),clen,cvp)
9594         );
9595     else
9596         sv_catpvs(msg, ": none");
9597     sv_catpvs(msg, " vs ");
9598     if (p)
9599         Perl_sv_catpvf(aTHX_ msg, "(%" UTF8f ")", UTF8fARG(flags & SVf_UTF8,len,p));
9600     else
9601         sv_catpvs(msg, "none");
9602     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%" SVf, SVfARG(msg));
9603 }
9604
9605 static void const_sv_xsub(pTHX_ CV* cv);
9606 static void const_av_xsub(pTHX_ CV* cv);
9607
9608 /*
9609
9610 =for apidoc_section $optree_manipulation
9611
9612 =for apidoc cv_const_sv
9613
9614 If C<cv> is a constant sub eligible for inlining, returns the constant
9615 value returned by the sub.  Otherwise, returns C<NULL>.
9616
9617 Constant subs can be created with C<newCONSTSUB> or as described in
9618 L<perlsub/"Constant Functions">.
9619
9620 =cut
9621 */
9622 SV *
9623 Perl_cv_const_sv(const CV *const cv)
9624 {
9625     SV *sv;
9626     if (!cv)
9627         return NULL;
9628     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
9629         return NULL;
9630     sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
9631     if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
9632     return sv;
9633 }
9634
9635 SV *
9636 Perl_cv_const_sv_or_av(const CV * const cv)
9637 {
9638     if (!cv)
9639         return NULL;
9640     if (SvROK(cv)) return SvRV((SV *)cv);
9641     assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
9642     return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
9643 }
9644
9645 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
9646  * Can be called in 2 ways:
9647  *
9648  * !allow_lex
9649  *      look for a single OP_CONST with attached value: return the value
9650  *
9651  * allow_lex && !CvCONST(cv);
9652  *
9653  *      examine the clone prototype, and if contains only a single
9654  *      OP_CONST, return the value; or if it contains a single PADSV ref-
9655  *      erencing an outer lexical, turn on CvCONST to indicate the CV is
9656  *      a candidate for "constizing" at clone time, and return NULL.
9657  */
9658
9659 static SV *
9660 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
9661 {
9662     SV *sv = NULL;
9663     bool padsv = FALSE;
9664
9665     assert(o);
9666     assert(cv);
9667
9668     for (; o; o = o->op_next) {
9669         const OPCODE type = o->op_type;
9670
9671         if (type == OP_NEXTSTATE || type == OP_LINESEQ
9672              || type == OP_NULL
9673              || type == OP_PUSHMARK)
9674                 continue;
9675         if (type == OP_DBSTATE)
9676                 continue;
9677         if (type == OP_LEAVESUB)
9678             break;
9679         if (sv)
9680             return NULL;
9681         if (type == OP_CONST && cSVOPo->op_sv)
9682             sv = cSVOPo->op_sv;
9683         else if (type == OP_UNDEF && !o->op_private) {
9684             sv = newSV_type(SVt_NULL);
9685             SAVEFREESV(sv);
9686         }
9687         else if (allow_lex && type == OP_PADSV) {
9688                 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEf_OUTER)
9689                 {
9690                     sv = &PL_sv_undef; /* an arbitrary non-null value */
9691                     padsv = TRUE;
9692                 }
9693                 else
9694                     return NULL;
9695         }
9696         else {
9697             return NULL;
9698         }
9699     }
9700     if (padsv) {
9701         CvCONST_on(cv);
9702         return NULL;
9703     }
9704     return sv;
9705 }
9706
9707 static void
9708 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
9709                         PADNAME * const name, SV ** const const_svp)
9710 {
9711     assert (cv);
9712     assert (o || name);
9713     assert (const_svp);
9714     if (!block) {
9715         if (CvFLAGS(PL_compcv)) {
9716             /* might have had built-in attrs applied */
9717             const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
9718             if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
9719              && ckWARN(WARN_MISC))
9720             {
9721                 /* protect against fatal warnings leaking compcv */
9722                 SAVEFREESV(PL_compcv);
9723                 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
9724                 SvREFCNT_inc_simple_void_NN(PL_compcv);
9725             }
9726             CvFLAGS(cv) |=
9727                 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
9728                   & ~(CVf_LVALUE * pureperl));
9729         }
9730         return;
9731     }
9732
9733     /* redundant check for speed: */
9734     if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
9735         const line_t oldline = CopLINE(PL_curcop);
9736         SV *namesv = o
9737             ? cSVOPo->op_sv
9738             : newSVpvn_flags( PadnamePV(name)+1,PadnameLEN(name)-1,
9739                (PadnameUTF8(name)) ? SVf_UTF8|SVs_TEMP : SVs_TEMP
9740               );
9741         if (PL_parser && PL_parser->copline != NOLINE)
9742             /* This ensures that warnings are reported at the first
9743                line of a redefinition, not the last.  */
9744             CopLINE_set(PL_curcop, PL_parser->copline);
9745         /* protect against fatal warnings leaking compcv */
9746         SAVEFREESV(PL_compcv);
9747         report_redefined_cv(namesv, cv, const_svp);
9748         SvREFCNT_inc_simple_void_NN(PL_compcv);
9749         CopLINE_set(PL_curcop, oldline);
9750     }
9751     SAVEFREESV(cv);
9752     return;
9753 }
9754
9755 CV *
9756 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
9757 {
9758     CV **spot;
9759     SV **svspot;
9760     const char *ps;
9761     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
9762     U32 ps_utf8 = 0;
9763     CV *cv = NULL;
9764     CV *compcv = PL_compcv;
9765     SV *const_sv;
9766     PADNAME *name;
9767     PADOFFSET pax = o->op_targ;
9768     CV *outcv = CvOUTSIDE(PL_compcv);
9769     CV *clonee = NULL;
9770     HEK *hek = NULL;
9771     bool reusable = FALSE;
9772     OP *start = NULL;
9773 #ifdef PERL_DEBUG_READONLY_OPS
9774     OPSLAB *slab = NULL;
9775 #endif
9776
9777     PERL_ARGS_ASSERT_NEWMYSUB;
9778
9779     PL_hints |= HINT_BLOCK_SCOPE;
9780
9781     /* Find the pad slot for storing the new sub.
9782        We cannot use PL_comppad, as it is the pad owned by the new sub.  We
9783        need to look in CvOUTSIDE and find the pad belonging to the enclos-
9784        ing sub.  And then we need to dig deeper if this is a lexical from
9785        outside, as in:
9786            my sub foo; sub { sub foo { } }
9787      */
9788   redo:
9789     name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
9790     if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
9791         pax = PARENT_PAD_INDEX(name);
9792         outcv = CvOUTSIDE(outcv);
9793         assert(outcv);
9794         goto redo;
9795     }
9796     svspot =
9797         &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
9798                         [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
9799     spot = (CV **)svspot;
9800
9801     if (!(PL_parser && PL_parser->error_count))
9802         move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name), 0);
9803
9804     if (proto) {
9805         assert(proto->op_type == OP_CONST);
9806         ps = SvPV_const(cSVOPx(proto)->op_sv, ps_len);
9807         ps_utf8 = SvUTF8(cSVOPx(proto)->op_sv);
9808     }
9809     else
9810         ps = NULL;
9811
9812     if (proto)
9813         SAVEFREEOP(proto);
9814     if (attrs)
9815         SAVEFREEOP(attrs);
9816
9817     if (PL_parser && PL_parser->error_count) {
9818         op_free(block);
9819         SvREFCNT_dec(PL_compcv);
9820         PL_compcv = 0;
9821         goto done;
9822     }
9823
9824     if (CvDEPTH(outcv) && CvCLONE(compcv)) {
9825         cv = *spot;
9826         svspot = (SV **)(spot = &clonee);
9827     }
9828     else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
9829         cv = *spot;
9830     else {
9831         assert (SvTYPE(*spot) == SVt_PVCV);
9832         if (CvNAMED(*spot))
9833             hek = CvNAME_HEK(*spot);
9834         else {
9835             U32 hash;
9836             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
9837             CvNAME_HEK_set(*spot, hek =
9838                 share_hek(
9839                     PadnamePV(name)+1,
9840                     (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
9841                     hash
9842                 )
9843             );
9844             CvLEXICAL_on(*spot);
9845         }
9846         cv = PadnamePROTOCV(name);
9847         svspot = (SV **)(spot = &PadnamePROTOCV(name));
9848     }
9849
9850     if (block) {
9851         /* This makes sub {}; work as expected.  */
9852         if (block->op_type == OP_STUB) {
9853             const line_t l = PL_parser->copline;
9854             op_free(block);
9855             block = newSTATEOP(0, NULL, 0);
9856             PL_parser->copline = l;
9857         }
9858         block = CvLVALUE(compcv)
9859              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
9860                    ? newUNOP(OP_LEAVESUBLV, 0,
9861                              op_lvalue(voidnonfinal(block), OP_LEAVESUBLV))
9862                    : newUNOP(OP_LEAVESUB, 0, voidnonfinal(block));
9863         start = LINKLIST(block);
9864         block->op_next = 0;
9865         if (ps && !*ps && !attrs && !CvLVALUE(compcv))
9866             const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
9867         else
9868             const_sv = NULL;
9869     }
9870     else
9871         const_sv = NULL;
9872
9873     if (cv) {
9874         const bool exists = CvROOT(cv) || CvXSUB(cv);
9875
9876         /* if the subroutine doesn't exist and wasn't pre-declared
9877          * with a prototype, assume it will be AUTOLOADed,
9878          * skipping the prototype check
9879          */
9880         if (exists || SvPOK(cv))
9881             cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
9882                                  ps_utf8);
9883         /* already defined? */
9884         if (exists) {
9885             S_already_defined(aTHX_ cv, block, NULL, name, &const_sv);
9886             if (block)
9887                 cv = NULL;
9888             else {
9889                 if (attrs)
9890                     goto attrs;
9891                 /* just a "sub foo;" when &foo is already defined */
9892                 SAVEFREESV(compcv);
9893                 goto done;
9894             }
9895         }
9896         else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
9897             cv = NULL;
9898             reusable = TRUE;
9899         }
9900     }
9901
9902     if (const_sv) {
9903         SvREFCNT_inc_simple_void_NN(const_sv);
9904         SvFLAGS(const_sv) |= SVs_PADTMP;
9905         if (cv) {
9906             assert(!CvROOT(cv) && !CvCONST(cv));
9907             cv_forget_slab(cv);
9908         }
9909         else {
9910             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9911             CvFILE_set_from_cop(cv, PL_curcop);
9912             CvSTASH_set(cv, PL_curstash);
9913             *spot = cv;
9914         }
9915         SvPVCLEAR(MUTABLE_SV(cv));  /* prototype is "" */
9916         CvXSUBANY(cv).any_ptr = const_sv;
9917         CvXSUB(cv) = const_sv_xsub;
9918         CvCONST_on(cv);
9919         CvISXSUB_on(cv);
9920         PoisonPADLIST(cv);
9921         CvFLAGS(cv) |= CvNOWARN_AMBIGUOUS(compcv);
9922         op_free(block);
9923         SvREFCNT_dec(compcv);
9924         PL_compcv = NULL;
9925         goto setname;
9926     }
9927
9928     /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
9929        determine whether this sub definition is in the same scope as its
9930        declaration.  If this sub definition is inside an inner named pack-
9931        age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
9932        the package sub.  So check PadnameOUTER(name) too.
9933      */
9934     if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
9935         assert(!CvWEAKOUTSIDE(compcv));
9936         SvREFCNT_dec(CvOUTSIDE(compcv));
9937         CvWEAKOUTSIDE_on(compcv);
9938     }
9939     /* XXX else do we have a circular reference? */
9940
9941     if (cv) {   /* must reuse cv in case stub is referenced elsewhere */
9942         /* transfer PL_compcv to cv */
9943         if (block) {
9944             bool free_file = CvFILE(cv) && CvDYNFILE(cv);
9945             cv_flags_t preserved_flags =
9946                 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
9947             PADLIST *const temp_padl = CvPADLIST(cv);
9948             CV *const temp_cv = CvOUTSIDE(cv);
9949             const cv_flags_t other_flags =
9950                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
9951             OP * const cvstart = CvSTART(cv);
9952
9953             SvPOK_off(cv);
9954             CvFLAGS(cv) =
9955                 CvFLAGS(compcv) | preserved_flags;
9956             CvOUTSIDE(cv) = CvOUTSIDE(compcv);
9957             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
9958             CvPADLIST_set(cv, CvPADLIST(compcv));
9959             CvOUTSIDE(compcv) = temp_cv;
9960             CvPADLIST_set(compcv, temp_padl);
9961             CvSTART(cv) = CvSTART(compcv);
9962             CvSTART(compcv) = cvstart;
9963             CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
9964             CvFLAGS(compcv) |= other_flags;
9965
9966             if (free_file) {
9967                 Safefree(CvFILE(cv));
9968                 CvFILE(cv) = NULL;
9969             }
9970
9971             /* inner references to compcv must be fixed up ... */
9972             pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
9973             if (PERLDB_INTER)/* Advice debugger on the new sub. */
9974                 ++PL_sub_generation;
9975         }
9976         else {
9977             /* Might have had built-in attributes applied -- propagate them. */
9978             CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
9979         }
9980         /* ... before we throw it away */
9981         SvREFCNT_dec(compcv);
9982         PL_compcv = compcv = cv;
9983     }
9984     else {
9985         cv = compcv;
9986         *spot = cv;
9987     }
9988
9989   setname:
9990     CvLEXICAL_on(cv);
9991     if (!CvNAME_HEK(cv)) {
9992         if (hek) (void)share_hek_hek(hek);
9993         else {
9994             U32 hash;
9995             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
9996             hek = share_hek(PadnamePV(name)+1,
9997                       (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
9998                       hash);
9999         }
10000         CvNAME_HEK_set(cv, hek);
10001     }
10002
10003     if (const_sv)
10004         goto clone;
10005
10006     if (CvFILE(cv) && CvDYNFILE(cv))
10007         Safefree(CvFILE(cv));
10008     CvFILE_set_from_cop(cv, PL_curcop);
10009     CvSTASH_set(cv, PL_curstash);
10010
10011     if (ps) {
10012         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
10013         if (ps_utf8)
10014             SvUTF8_on(MUTABLE_SV(cv));
10015     }
10016
10017     if (block) {
10018         /* If we assign an optree to a PVCV, then we've defined a
10019          * subroutine that the debugger could be able to set a breakpoint
10020          * in, so signal to pp_entereval that it should not throw away any
10021          * saved lines at scope exit.  */
10022
10023         PL_breakable_sub_gen++;
10024         CvROOT(cv) = block;
10025         /* The cv no longer needs to hold a refcount on the slab, as CvROOT
10026            itself has a refcount. */
10027         CvSLABBED_off(cv);
10028         OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
10029 #ifdef PERL_DEBUG_READONLY_OPS
10030         slab = (OPSLAB *)CvSTART(cv);
10031 #endif
10032         S_process_optree(aTHX_ cv, block, start);
10033     }
10034
10035   attrs:
10036     if (attrs) {
10037         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
10038         apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
10039     }
10040
10041     if (block) {
10042         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
10043             SV * const tmpstr = sv_newmortal();
10044             GV * const db_postponed = gv_fetchpvs("DB::postponed",
10045                                                   GV_ADDMULTI, SVt_PVHV);
10046             HV *hv;
10047             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
10048                                           CopFILE(PL_curcop),
10049                                           (long)PL_subline,
10050                                           (long)CopLINE(PL_curcop));
10051             if (HvNAME_HEK(PL_curstash)) {
10052                 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
10053                 sv_catpvs(tmpstr, "::");
10054             }
10055             else
10056                 sv_setpvs(tmpstr, "__ANON__::");
10057
10058             sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
10059                             PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
10060             (void)hv_store_ent(GvHV(PL_DBsub), tmpstr, sv, 0);
10061             hv = GvHVn(db_postponed);
10062             if (HvTOTALKEYS(hv) > 0 && hv_exists_ent(hv, tmpstr, 0)) {
10063                 CV * const pcv = GvCV(db_postponed);
10064                 if (pcv) {
10065                     dSP;
10066                     PUSHMARK(SP);
10067                     XPUSHs(tmpstr);
10068                     PUTBACK;
10069                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
10070                 }
10071             }
10072         }
10073     }
10074
10075   clone:
10076     if (clonee) {
10077         assert(CvDEPTH(outcv));
10078         spot = (CV **)
10079             &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
10080         if (reusable)
10081             cv_clone_into(clonee, *spot);
10082         else *spot = cv_clone(clonee);
10083         SvREFCNT_dec_NN(clonee);
10084         cv = *spot;
10085     }
10086
10087     if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
10088         PADOFFSET depth = CvDEPTH(outcv);
10089         while (--depth) {
10090             SV *oldcv;
10091             svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
10092             oldcv = *svspot;
10093             *svspot = SvREFCNT_inc_simple_NN(cv);
10094             SvREFCNT_dec(oldcv);
10095         }
10096     }
10097
10098   done:
10099     if (PL_parser)
10100         PL_parser->copline = NOLINE;
10101     LEAVE_SCOPE(floor);
10102 #ifdef PERL_DEBUG_READONLY_OPS
10103     if (slab)
10104         Slab_to_ro(slab);
10105 #endif
10106     op_free(o);
10107     return cv;
10108 }
10109
10110 /*
10111 =for apidoc newATTRSUB_x
10112
10113 Construct a Perl subroutine, also performing some surrounding jobs.
10114
10115 This function is expected to be called in a Perl compilation context,
10116 and some aspects of the subroutine are taken from global variables
10117 associated with compilation.  In particular, C<PL_compcv> represents
10118 the subroutine that is currently being compiled.  It must be non-null
10119 when this function is called, and some aspects of the subroutine being
10120 constructed are taken from it.  The constructed subroutine may actually
10121 be a reuse of the C<PL_compcv> object, but will not necessarily be so.
10122
10123 If C<block> is null then the subroutine will have no body, and for the
10124 time being it will be an error to call it.  This represents a forward
10125 subroutine declaration such as S<C<sub foo ($$);>>.  If C<block> is
10126 non-null then it provides the Perl code of the subroutine body, which
10127 will be executed when the subroutine is called.  This body includes
10128 any argument unwrapping code resulting from a subroutine signature or
10129 similar.  The pad use of the code must correspond to the pad attached
10130 to C<PL_compcv>.  The code is not expected to include a C<leavesub> or
10131 C<leavesublv> op; this function will add such an op.  C<block> is consumed
10132 by this function and will become part of the constructed subroutine.
10133
10134 C<proto> specifies the subroutine's prototype, unless one is supplied
10135 as an attribute (see below).  If C<proto> is null, then the subroutine
10136 will not have a prototype.  If C<proto> is non-null, it must point to a
10137 C<const> op whose value is a string, and the subroutine will have that
10138 string as its prototype.  If a prototype is supplied as an attribute, the
10139 attribute takes precedence over C<proto>, but in that case C<proto> should
10140 preferably be null.  In any case, C<proto> is consumed by this function.
10141
10142 C<attrs> supplies attributes to be applied the subroutine.  A handful of
10143 attributes take effect by built-in means, being applied to C<PL_compcv>
10144 immediately when seen.  Other attributes are collected up and attached
10145 to the subroutine by this route.  C<attrs> may be null to supply no
10146 attributes, or point to a C<const> op for a single attribute, or point
10147 to a C<list> op whose children apart from the C<pushmark> are C<const>
10148 ops for one or more attributes.  Each C<const> op must be a string,
10149 giving the attribute name optionally followed by parenthesised arguments,
10150 in the manner in which attributes appear in Perl source.  The attributes
10151 will be applied to the sub by this function.  C<attrs> is consumed by
10152 this function.
10153
10154 If C<o_is_gv> is false and C<o> is null, then the subroutine will
10155 be anonymous.  If C<o_is_gv> is false and C<o> is non-null, then C<o>
10156 must point to a C<const> OP, which will be consumed by this function,
10157 and its string value supplies a name for the subroutine.  The name may
10158 be qualified or unqualified, and if it is unqualified then a default
10159 stash will be selected in some manner.  If C<o_is_gv> is true, then C<o>
10160 doesn't point to an C<OP> at all, but is instead a cast pointer to a C<GV>
10161 by which the subroutine will be named.
10162
10163 If there is already a subroutine of the specified name, then the new
10164 sub will either replace the existing one in the glob or be merged with
10165 the existing one.  A warning may be generated about redefinition.
10166
10167 If the subroutine has one of a few special names, such as C<BEGIN> or
10168 C<END>, then it will be claimed by the appropriate queue for automatic
10169 running of phase-related subroutines.  In this case the relevant glob will
10170 be left not containing any subroutine, even if it did contain one before.
10171 In the case of C<BEGIN>, the subroutine will be executed and the reference
10172 to it disposed of before this function returns.
10173
10174 The function returns a pointer to the constructed subroutine.  If the sub
10175 is anonymous then ownership of one counted reference to the subroutine
10176 is transferred to the caller.  If the sub is named then the caller does
10177 not get ownership of a reference.  In most such cases, where the sub
10178 has a non-phase name, the sub will be alive at the point it is returned
10179 by virtue of being contained in the glob that names it.  A phase-named
10180 subroutine will usually be alive by virtue of the reference owned by the
10181 phase's automatic run queue.  But a C<BEGIN> subroutine, having already
10182 been executed, will quite likely have been destroyed already by the
10183 time this function returns, making it erroneous for the caller to make
10184 any use of the returned pointer.  It is the caller's responsibility to
10185 ensure that it knows which of these situations applies.
10186
10187 =for apidoc newATTRSUB
10188 Construct a Perl subroutine, also performing some surrounding jobs.
10189
10190 This is the same as L<perlintern/C<newATTRSUB_x>> with its C<o_is_gv> parameter set to
10191 FALSE.  This means that if C<o> is null, the new sub will be anonymous; otherwise
10192 the name will be derived from C<o> in the way described (as with all other
10193 details) in L<perlintern/C<newATTRSUB_x>>.
10194
10195 =for apidoc newSUB
10196 Like C<L</newATTRSUB>>, but without attributes.
10197
10198 =cut
10199 */
10200
10201 /* _x = extended */
10202 CV *
10203 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
10204                             OP *block, bool o_is_gv)
10205 {
10206     GV *gv;
10207     const char *ps;
10208     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
10209     U32 ps_utf8 = 0;
10210     CV *cv = NULL;     /* the previous CV with this name, if any */
10211     SV *const_sv;
10212     const bool ec = PL_parser && PL_parser->error_count;
10213     /* If the subroutine has no body, no attributes, and no builtin attributes
10214        then it's just a sub declaration, and we may be able to get away with
10215        storing with a placeholder scalar in the symbol table, rather than a
10216        full CV.  If anything is present then it will take a full CV to
10217        store it.  */
10218     const I32 gv_fetch_flags
10219         = ec ? GV_NOADD_NOINIT :
10220         (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
10221         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
10222     STRLEN namlen = 0;
10223     const char * const name =
10224          o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
10225     bool has_name;
10226     bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
10227     bool evanescent = FALSE;
10228     OP *start = NULL;
10229 #ifdef PERL_DEBUG_READONLY_OPS
10230     OPSLAB *slab = NULL;
10231 #endif
10232
10233     if (o_is_gv) {
10234         gv = (GV*)o;
10235         o = NULL;
10236         has_name = TRUE;
10237     } else if (name) {
10238         /* Try to optimise and avoid creating a GV.  Instead, the CV’s name
10239            hek and CvSTASH pointer together can imply the GV.  If the name
10240            contains a package name, then GvSTASH(CvGV(cv)) may differ from
10241            CvSTASH, so forego the optimisation if we find any.
10242            Also, we may be called from load_module at run time, so
10243            PL_curstash (which sets CvSTASH) may not point to the stash the
10244            sub is stored in.  */
10245         /* XXX This optimization is currently disabled for packages other
10246                than main, since there was too much CPAN breakage.  */
10247         const I32 flags =
10248            ec ? GV_NOADD_NOINIT
10249               :   (IN_PERL_RUNTIME && PL_curstash != CopSTASH(PL_curcop))
10250                || PL_curstash != PL_defstash
10251                || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
10252                     ? gv_fetch_flags
10253                     : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
10254         gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
10255         has_name = TRUE;
10256     } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
10257         SV * const sv = sv_newmortal();
10258         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%" IVdf "]",
10259                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
10260                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
10261         gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
10262         has_name = TRUE;
10263     } else if (PL_curstash) {
10264         gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
10265         has_name = FALSE;
10266     } else {
10267         gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
10268         has_name = FALSE;
10269     }
10270
10271     if (!ec) {
10272         if (isGV(gv)) {
10273             move_proto_attr(&proto, &attrs, gv, 0);
10274         } else {
10275             assert(cSVOPo);
10276             move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv, 1);
10277         }
10278     }
10279
10280     if (proto) {
10281         assert(proto->op_type == OP_CONST);
10282         ps = SvPV_const(cSVOPx(proto)->op_sv, ps_len);
10283         ps_utf8 = SvUTF8(cSVOPx(proto)->op_sv);
10284     }
10285     else
10286         ps = NULL;
10287
10288     if (o)
10289         SAVEFREEOP(o);
10290     if (proto)
10291         SAVEFREEOP(proto);
10292     if (attrs)
10293         SAVEFREEOP(attrs);
10294
10295     if (ec) {
10296         op_free(block);
10297
10298         if (name)
10299             SvREFCNT_dec(PL_compcv);
10300         else
10301             cv = PL_compcv;
10302
10303         PL_compcv = 0;
10304         if (name && block) {
10305             const char *s = (char *) my_memrchr(name, ':', namlen);
10306             s = s ? s+1 : name;
10307             if (strEQ(s, "BEGIN")) {
10308                 if (PL_in_eval & EVAL_KEEPERR)
10309                     Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
10310                 else {
10311                     SV * const errsv = ERRSV;
10312                     /* force display of errors found but not reported */
10313                     sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
10314                     Perl_croak_nocontext("%" SVf, SVfARG(errsv));
10315                 }
10316             }
10317         }
10318         goto done;
10319     }
10320
10321     if (!block && SvTYPE(gv) != SVt_PVGV) {
10322         /* If we are not defining a new sub and the existing one is not a
10323            full GV + CV... */
10324         if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
10325             /* We are applying attributes to an existing sub, so we need it
10326                upgraded if it is a constant.  */
10327             if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
10328                 gv_init_pvn(gv, PL_curstash, name, namlen,
10329                             SVf_UTF8 * name_is_utf8);
10330         }
10331         else {                  /* Maybe prototype now, and had at maximum
10332                                    a prototype or const/sub ref before.  */
10333             if (SvTYPE(gv) > SVt_NULL) {
10334                 cv_ckproto_len_flags((const CV *)gv,
10335                                     o ? (const GV *)cSVOPo->op_sv : NULL, ps,
10336                                     ps_len, ps_utf8);
10337             }
10338
10339             if (!SvROK(gv)) {
10340                 if (ps) {
10341                     sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
10342                     if (ps_utf8)
10343                         SvUTF8_on(MUTABLE_SV(gv));
10344                 }
10345                 else
10346                     sv_setiv(MUTABLE_SV(gv), -1);
10347             }
10348
10349             SvREFCNT_dec(PL_compcv);
10350             cv = PL_compcv = NULL;
10351             goto done;
10352         }
10353     }
10354
10355     cv = (!name || (isGV(gv) && GvCVGEN(gv)))
10356         ? NULL
10357         : isGV(gv)
10358             ? GvCV(gv)
10359             : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
10360                 ? (CV *)SvRV(gv)
10361                 : NULL;
10362
10363     if (block) {
10364         assert(PL_parser);
10365         /* This makes sub {}; work as expected.  */
10366         if (block->op_type == OP_STUB) {
10367             const line_t l = PL_parser->copline;
10368             op_free(block);
10369             block = newSTATEOP(0, NULL, 0);
10370             PL_parser->copline = l;
10371         }
10372         block = CvLVALUE(PL_compcv)
10373              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
10374                     && (!isGV(gv) || !GvASSUMECV(gv)))
10375                    ? newUNOP(OP_LEAVESUBLV, 0,
10376                              op_lvalue(voidnonfinal(block), OP_LEAVESUBLV))
10377                    : newUNOP(OP_LEAVESUB, 0, voidnonfinal(block));
10378         start = LINKLIST(block);
10379         block->op_next = 0;
10380         if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
10381             const_sv =
10382                 S_op_const_sv(aTHX_ start, PL_compcv,
10383                                         cBOOL(CvCLONE(PL_compcv)));
10384         else
10385             const_sv = NULL;
10386     }
10387     else
10388         const_sv = NULL;
10389
10390     if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
10391         cv_ckproto_len_flags((const CV *)gv,
10392                              o ? (const GV *)cSVOPo->op_sv : NULL, ps,
10393                              ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
10394         if (SvROK(gv)) {
10395             /* All the other code for sub redefinition warnings expects the
10396                clobbered sub to be a CV.  Instead of making all those code
10397                paths more complex, just inline the RV version here.  */
10398             const line_t oldline = CopLINE(PL_curcop);
10399             assert(IN_PERL_COMPILETIME);
10400             if (PL_parser && PL_parser->copline != NOLINE)
10401                 /* This ensures that warnings are reported at the first
10402                    line of a redefinition, not the last.  */
10403                 CopLINE_set(PL_curcop, PL_parser->copline);
10404             /* protect against fatal warnings leaking compcv */
10405             SAVEFREESV(PL_compcv);
10406
10407             if (ckWARN(WARN_REDEFINE)
10408              || (  ckWARN_d(WARN_REDEFINE)
10409                 && (  !const_sv || SvRV(gv) == const_sv
10410                    || sv_cmp(SvRV(gv), const_sv)  ))) {
10411                 assert(cSVOPo);
10412                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10413                           "Constant subroutine %" SVf " redefined",
10414                           SVfARG(cSVOPo->op_sv));
10415             }
10416
10417             SvREFCNT_inc_simple_void_NN(PL_compcv);
10418             CopLINE_set(PL_curcop, oldline);
10419             SvREFCNT_dec(SvRV(gv));
10420         }
10421     }
10422
10423     if (cv) {
10424         const bool exists = CvROOT(cv) || CvXSUB(cv);
10425
10426         /* if the subroutine doesn't exist and wasn't pre-declared
10427          * with a prototype, assume it will be AUTOLOADed,
10428          * skipping the prototype check
10429          */
10430         if (exists || SvPOK(cv))
10431             cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
10432         /* already defined (or promised)? */
10433         if (exists || (isGV(gv) && GvASSUMECV(gv))) {
10434             S_already_defined(aTHX_ cv, block, o, NULL, &const_sv);
10435             if (block)
10436                 cv = NULL;
10437             else {
10438                 if (attrs)
10439                     goto attrs;
10440                 /* just a "sub foo;" when &foo is already defined */
10441                 SAVEFREESV(PL_compcv);
10442                 goto done;
10443             }
10444         }
10445     }
10446
10447     if (const_sv) {
10448         SvREFCNT_inc_simple_void_NN(const_sv);
10449         SvFLAGS(const_sv) |= SVs_PADTMP;
10450         if (cv) {
10451             assert(!CvROOT(cv) && !CvCONST(cv));
10452             cv_forget_slab(cv);
10453             SvPVCLEAR(MUTABLE_SV(cv));  /* prototype is "" */
10454             CvXSUBANY(cv).any_ptr = const_sv;
10455             CvXSUB(cv) = const_sv_xsub;
10456             CvCONST_on(cv);
10457             CvISXSUB_on(cv);
10458             PoisonPADLIST(cv);
10459             CvFLAGS(cv) |= CvNOWARN_AMBIGUOUS(PL_compcv);
10460         }
10461         else {
10462             if (isGV(gv) || CvNOWARN_AMBIGUOUS(PL_compcv)) {
10463                 if (name && isGV(gv))
10464                     GvCV_set(gv, NULL);
10465                 cv = newCONSTSUB_flags(
10466                     NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
10467                     const_sv
10468                 );
10469                 assert(cv);
10470                 assert(SvREFCNT((SV*)cv) != 0);
10471                 CvFLAGS(cv) |= CvNOWARN_AMBIGUOUS(PL_compcv);
10472             }
10473             else {
10474                 if (!SvROK(gv)) {
10475                     SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
10476                     prepare_SV_for_RV((SV *)gv);
10477                     SvOK_off((SV *)gv);
10478                     SvROK_on(gv);
10479                 }
10480                 SvRV_set(gv, const_sv);
10481             }
10482         }
10483         op_free(block);
10484         SvREFCNT_dec(PL_compcv);
10485         PL_compcv = NULL;
10486         goto done;
10487     }
10488
10489     /* don't copy new BEGIN CV to old BEGIN CV - RT #129099 */
10490     if (name && cv && *name == 'B' && strEQ(name, "BEGIN"))
10491         cv = NULL;
10492
10493     if (cv) {                           /* must reuse cv if autoloaded */
10494         /* transfer PL_compcv to cv */
10495         if (block) {
10496             bool free_file = CvFILE(cv) && CvDYNFILE(cv);
10497             cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
10498             PADLIST *const temp_av = CvPADLIST(cv);
10499             CV *const temp_cv = CvOUTSIDE(cv);
10500             const cv_flags_t other_flags =
10501                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
10502             OP * const cvstart = CvSTART(cv);
10503
10504             if (isGV(gv)) {
10505                 CvGV_set(cv,gv);
10506                 assert(!CvCVGV_RC(cv));
10507                 assert(CvGV(cv) == gv);
10508             }
10509             else {
10510                 U32 hash;
10511                 PERL_HASH(hash, name, namlen);
10512                 CvNAME_HEK_set(cv,
10513                                share_hek(name,
10514                                          name_is_utf8
10515                                             ? -(SSize_t)namlen
10516                                             :  (SSize_t)namlen,
10517                                          hash));
10518             }
10519
10520             SvPOK_off(cv);
10521             CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
10522                                              | CvNAMED(cv);
10523             CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
10524             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
10525             CvPADLIST_set(cv,CvPADLIST(PL_compcv));
10526             CvOUTSIDE(PL_compcv) = temp_cv;
10527             CvPADLIST_set(PL_compcv, temp_av);
10528             CvSTART(cv) = CvSTART(PL_compcv);
10529             CvSTART(PL_compcv) = cvstart;
10530             CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
10531             CvFLAGS(PL_compcv) |= other_flags;
10532
10533             if (free_file) {
10534                 Safefree(CvFILE(cv));
10535             }
10536             CvFILE_set_from_cop(cv, PL_curcop);
10537             CvSTASH_set(cv, PL_curstash);
10538
10539             /* inner references to PL_compcv must be fixed up ... */
10540             pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
10541             if (PERLDB_INTER)/* Advice debugger on the new sub. */
10542                 ++PL_sub_generation;
10543         }
10544         else {
10545             /* Might have had built-in attributes applied -- propagate them. */
10546             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
10547         }
10548         /* ... before we throw it away */
10549         SvREFCNT_dec(PL_compcv);
10550         PL_compcv = cv;
10551     }
10552     else {
10553         cv = PL_compcv;
10554         if (name && isGV(gv)) {
10555             GvCV_set(gv, cv);
10556             GvCVGEN(gv) = 0;
10557             if (HvENAME_HEK(GvSTASH(gv)))
10558                 /* sub Foo::bar { (shift)+1 } */
10559                 gv_method_changed(gv);
10560         }
10561         else if (name) {
10562             if (!SvROK(gv)) {
10563                 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
10564                 prepare_SV_for_RV((SV *)gv);
10565                 SvOK_off((SV *)gv);
10566                 SvROK_on(gv);
10567             }
10568             SvRV_set(gv, (SV *)cv);
10569             if (HvENAME_HEK(PL_curstash))
10570                 mro_method_changed_in(PL_curstash);
10571         }
10572     }
10573     assert(cv);
10574     assert(SvREFCNT((SV*)cv) != 0);
10575
10576     if (!CvHASGV(cv)) {
10577         if (isGV(gv))
10578             CvGV_set(cv, gv);
10579         else {
10580             U32 hash;
10581             PERL_HASH(hash, name, namlen);
10582             CvNAME_HEK_set(cv, share_hek(name,
10583                                          name_is_utf8
10584                                             ? -(SSize_t)namlen
10585                                             :  (SSize_t)namlen,
10586                                          hash));
10587         }
10588         CvFILE_set_from_cop(cv, PL_curcop);
10589         CvSTASH_set(cv, PL_curstash);
10590     }
10591
10592     if (ps) {
10593         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
10594         if ( ps_utf8 )
10595             SvUTF8_on(MUTABLE_SV(cv));
10596     }
10597
10598     if (block) {
10599         /* If we assign an optree to a PVCV, then we've defined a
10600          * subroutine that the debugger could be able to set a breakpoint
10601          * in, so signal to pp_entereval that it should not throw away any
10602          * saved lines at scope exit.  */
10603
10604         PL_breakable_sub_gen++;
10605         CvROOT(cv) = block;
10606         /* The cv no longer needs to hold a refcount on the slab, as CvROOT
10607            itself has a refcount. */
10608         CvSLABBED_off(cv);
10609         OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
10610 #ifdef PERL_DEBUG_READONLY_OPS
10611         slab = (OPSLAB *)CvSTART(cv);
10612 #endif
10613         S_process_optree(aTHX_ cv, block, start);
10614     }
10615
10616   attrs:
10617     if (attrs) {
10618         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
10619         HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
10620                         ? GvSTASH(CvGV(cv))
10621                         : PL_curstash;
10622         if (!name)
10623             SAVEFREESV(cv);
10624         apply_attrs(stash, MUTABLE_SV(cv), attrs);
10625         if (!name)
10626             SvREFCNT_inc_simple_void_NN(cv);
10627     }
10628
10629     if (block && has_name) {
10630         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
10631             SV * const tmpstr = cv_name(cv,NULL,0);
10632             GV * const db_postponed = gv_fetchpvs("DB::postponed",
10633                                                   GV_ADDMULTI, SVt_PVHV);
10634             HV *hv;
10635             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
10636                                           CopFILE(PL_curcop),
10637                                           (long)PL_subline,
10638                                           (long)CopLINE(PL_curcop));
10639             (void)hv_store_ent(GvHV(PL_DBsub), tmpstr, sv, 0);
10640             hv = GvHVn(db_postponed);
10641             if (HvTOTALKEYS(hv) > 0 && hv_exists_ent(hv, tmpstr, 0)) {
10642                 CV * const pcv = GvCV(db_postponed);
10643                 if (pcv) {
10644                     dSP;
10645                     PUSHMARK(SP);
10646                     XPUSHs(tmpstr);
10647                     PUTBACK;
10648                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
10649                 }
10650             }
10651         }
10652
10653         if (name) {
10654             if (PL_parser && PL_parser->error_count)
10655                 clear_special_blocks(name, gv, cv);
10656             else
10657                 evanescent =
10658                     process_special_blocks(floor, name, gv, cv);
10659         }
10660     }
10661     assert(cv);
10662
10663   done:
10664     assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
10665     if (PL_parser)
10666         PL_parser->copline = NOLINE;
10667     LEAVE_SCOPE(floor);
10668
10669     assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
10670     if (!evanescent) {
10671 #ifdef PERL_DEBUG_READONLY_OPS
10672     if (slab)
10673         Slab_to_ro(slab);
10674 #endif
10675     if (cv && name && block && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
10676         pad_add_weakref(cv);
10677     }
10678     return cv;
10679 }
10680
10681 STATIC void
10682 S_clear_special_blocks(pTHX_ const char *const fullname,
10683                        GV *const gv, CV *const cv) {
10684     const char *colon;
10685     const char *name;
10686
10687     PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
10688
10689     colon = strrchr(fullname,':');
10690     name = colon ? colon + 1 : fullname;
10691
10692     if ((*name == 'B' && strEQ(name, "BEGIN"))
10693         || (*name == 'E' && strEQ(name, "END"))
10694         || (*name == 'U' && strEQ(name, "UNITCHECK"))
10695         || (*name == 'C' && strEQ(name, "CHECK"))
10696         || (*name == 'I' && strEQ(name, "INIT"))) {
10697         if (!isGV(gv)) {
10698             (void)CvGV(cv);
10699             assert(isGV(gv));
10700         }
10701         GvCV_set(gv, NULL);
10702         SvREFCNT_dec_NN(MUTABLE_SV(cv));
10703     }
10704 }
10705
10706 /* Returns true if the sub has been freed.  */
10707 STATIC bool
10708 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
10709                          GV *const gv,
10710                          CV *const cv)
10711 {
10712     const char *const colon = strrchr(fullname,':');
10713     const char *const name = colon ? colon + 1 : fullname;
10714
10715     PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
10716
10717     if (*name == 'B') {
10718         if (strEQ(name, "BEGIN")) {
10719             const I32 oldscope = PL_scopestack_ix;
10720             dSP;
10721             (void)CvGV(cv);
10722             if (floor) LEAVE_SCOPE(floor);
10723             ENTER;
10724
10725             SAVEVPTR(PL_curcop);
10726             if (PL_curcop == &PL_compiling) {
10727                 /* Avoid pushing the "global" &PL_compiling onto the
10728                  * context stack. For example, a stack trace inside
10729                  * nested use's would show all calls coming from whoever
10730                  * most recently updated PL_compiling.cop_file and
10731                  * cop_line.  So instead, temporarily set PL_curcop to a
10732                  * private copy of &PL_compiling. PL_curcop will soon be
10733                  * set to point back to &PL_compiling anyway but only
10734                  * after the temp value has been pushed onto the context
10735                  * stack as blk_oldcop.
10736                  * This is slightly hacky, but necessary. Note also
10737                  * that in the brief window before PL_curcop is set back
10738                  * to PL_compiling, IN_PERL_COMPILETIME/IN_PERL_RUNTIME
10739                  * will give the wrong answer.
10740                  */
10741                 PL_curcop = (COP*)newSTATEOP(PL_compiling.op_flags, NULL, NULL);
10742                 CopLINE_set(PL_curcop, CopLINE(&PL_compiling));
10743                 SAVEFREEOP(PL_curcop);
10744             }
10745
10746             PUSHSTACKi(PERLSI_REQUIRE);
10747             SAVECOPFILE(&PL_compiling);
10748             SAVECOPLINE(&PL_compiling);
10749
10750             DEBUG_x( dump_sub(gv) );
10751             Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
10752             GvCV_set(gv,0);             /* cv has been hijacked */
10753             call_list(oldscope, PL_beginav);
10754
10755             POPSTACK;
10756             LEAVE;
10757             return !PL_savebegin;
10758         }
10759         else
10760             return FALSE;
10761     } else {
10762         if (*name == 'E') {
10763             if (strEQ(name, "END")) {
10764                 DEBUG_x( dump_sub(gv) );
10765                 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
10766             } else
10767                 return FALSE;
10768         } else if (*name == 'U') {
10769             if (strEQ(name, "UNITCHECK")) {
10770                 /* It's never too late to run a unitcheck block */
10771                 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
10772             }
10773             else
10774                 return FALSE;
10775         } else if (*name == 'C') {
10776             if (strEQ(name, "CHECK")) {
10777                 if (PL_main_start)
10778                     /* diag_listed_as: Too late to run %s block */
10779                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
10780                                    "Too late to run CHECK block");
10781                 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
10782             }
10783             else
10784                 return FALSE;
10785         } else if (*name == 'I') {
10786             if (strEQ(name, "INIT")) {
10787                 if (PL_main_start)
10788                     /* diag_listed_as: Too late to run %s block */
10789                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
10790                                    "Too late to run INIT block");
10791                 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
10792             }
10793             else
10794                 return FALSE;
10795         } else
10796             return FALSE;
10797         DEBUG_x( dump_sub(gv) );
10798         (void)CvGV(cv);
10799         GvCV_set(gv,0);         /* cv has been hijacked */
10800         return FALSE;
10801     }
10802 }
10803
10804 /*
10805 =for apidoc newCONSTSUB
10806
10807 Behaves like L</newCONSTSUB_flags>, except that C<name> is nul-terminated
10808 rather than of counted length, and no flags are set.  (This means that
10809 C<name> is always interpreted as Latin-1.)
10810
10811 =cut
10812 */
10813
10814 CV *
10815 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
10816 {
10817     return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
10818 }
10819
10820 /*
10821 =for apidoc newCONSTSUB_flags
10822
10823 Construct a constant subroutine, also performing some surrounding
10824 jobs.  A scalar constant-valued subroutine is eligible for inlining
10825 at compile-time, and in Perl code can be created by S<C<sub FOO () {
10826 123 }>>.  Other kinds of constant subroutine have other treatment.
10827
10828 The subroutine will have an empty prototype and will ignore any arguments
10829 when called.  Its constant behaviour is determined by C<sv>.  If C<sv>
10830 is null, the subroutine will yield an empty list.  If C<sv> points to a
10831 scalar, the subroutine will always yield that scalar.  If C<sv> points
10832 to an array, the subroutine will always yield a list of the elements of
10833 that array in list context, or the number of elements in the array in
10834 scalar context.  This function takes ownership of one counted reference
10835 to the scalar or array, and will arrange for the object to live as long
10836 as the subroutine does.  If C<sv> points to a scalar then the inlining
10837 assumes that the value of the scalar will never change, so the caller
10838 must ensure that the scalar is not subsequently written to.  If C<sv>
10839 points to an array then no such assumption is made, so it is ostensibly
10840 safe to mutate the array or its elements, but whether this is really
10841 supported has not been determined.
10842
10843 The subroutine will have C<CvFILE> set according to C<PL_curcop>.
10844 Other aspects of the subroutine will be left in their default state.
10845 The caller is free to mutate the subroutine beyond its initial state
10846 after this function has returned.
10847
10848 If C<name> is null then the subroutine will be anonymous, with its
10849 C<CvGV> referring to an C<__ANON__> glob.  If C<name> is non-null then the
10850 subroutine will be named accordingly, referenced by the appropriate glob.
10851 C<name> is a string of length C<len> bytes giving a sigilless symbol
10852 name, in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1
10853 otherwise.  The name may be either qualified or unqualified.  If the
10854 name is unqualified then it defaults to being in the stash specified by
10855 C<stash> if that is non-null, or to C<PL_curstash> if C<stash> is null.
10856 The symbol is always added to the stash if necessary, with C<GV_ADDMULTI>
10857 semantics.
10858
10859 C<flags> should not have bits set other than C<SVf_UTF8>.
10860
10861 If there is already a subroutine of the specified name, then the new sub
10862 will replace the existing one in the glob.  A warning may be generated
10863 about the redefinition.
10864
10865 If the subroutine has one of a few special names, such as C<BEGIN> or
10866 C<END>, then it will be claimed by the appropriate queue for automatic
10867 running of phase-related subroutines.  In this case the relevant glob will
10868 be left not containing any subroutine, even if it did contain one before.
10869 Execution of the subroutine will likely be a no-op, unless C<sv> was
10870 a tied array or the caller modified the subroutine in some interesting
10871 way before it was executed.  In the case of C<BEGIN>, the treatment is
10872 buggy: the sub will be executed when only half built, and may be deleted
10873 prematurely, possibly causing a crash.
10874
10875 The function returns a pointer to the constructed subroutine.  If the sub
10876 is anonymous then ownership of one counted reference to the subroutine
10877 is transferred to the caller.  If the sub is named then the caller does
10878 not get ownership of a reference.  In most such cases, where the sub
10879 has a non-phase name, the sub will be alive at the point it is returned
10880 by virtue of being contained in the glob that names it.  A phase-named
10881 subroutine will usually be alive by virtue of the reference owned by
10882 the phase's automatic run queue.  A C<BEGIN> subroutine may have been
10883 destroyed already by the time this function returns, but currently bugs
10884 occur in that case before the caller gets control.  It is the caller's
10885 responsibility to ensure that it knows which of these situations applies.
10886
10887 =cut
10888 */
10889
10890 CV *
10891 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
10892                              U32 flags, SV *sv)
10893 {
10894     CV* cv;
10895     const char *const file = CopFILE(PL_curcop);
10896
10897     ENTER;
10898
10899     if (IN_PERL_RUNTIME) {
10900         /* at runtime, it's not safe to manipulate PL_curcop: it may be
10901          * an op shared between threads. Use a non-shared COP for our
10902          * dirty work */
10903          SAVEVPTR(PL_curcop);
10904          SAVECOMPILEWARNINGS();
10905          PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
10906          PL_curcop = &PL_compiling;
10907     }
10908     SAVECOPLINE(PL_curcop);
10909     CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
10910
10911     SAVEHINTS();
10912     PL_hints &= ~HINT_BLOCK_SCOPE;
10913
10914     if (stash) {
10915         SAVEGENERICSV(PL_curstash);
10916         PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
10917     }
10918
10919     /* Protect sv against leakage caused by fatal warnings. */
10920     if (sv) SAVEFREESV(sv);
10921
10922     /* file becomes the CvFILE. For an XS, it's usually static storage,
10923        and so doesn't get free()d.  (It's expected to be from the C pre-
10924        processor __FILE__ directive). But we need a dynamically allocated one,
10925        and we need it to get freed.  */
10926     cv = newXS_len_flags(name, len,
10927                          sv && SvTYPE(sv) == SVt_PVAV
10928                              ? const_av_xsub
10929                              : const_sv_xsub,
10930                          file ? file : "", "",
10931                          &sv, XS_DYNAMIC_FILENAME | flags);
10932     assert(cv);
10933     assert(SvREFCNT((SV*)cv) != 0);
10934     CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
10935     CvCONST_on(cv);
10936
10937     LEAVE;
10938
10939     return cv;
10940 }
10941
10942 /*
10943 =for apidoc newXS
10944
10945 Used by C<xsubpp> to hook up XSUBs as Perl subs.  C<filename> needs to be
10946 static storage, as it is used directly as CvFILE(), without a copy being made.
10947
10948 =cut
10949 */
10950
10951 CV *
10952 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
10953 {
10954     PERL_ARGS_ASSERT_NEWXS;
10955     return newXS_len_flags(
10956         name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
10957     );
10958 }
10959
10960 CV *
10961 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
10962                  const char *const filename, const char *const proto,
10963                  U32 flags)
10964 {
10965     PERL_ARGS_ASSERT_NEWXS_FLAGS;
10966     return newXS_len_flags(
10967        name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
10968     );
10969 }
10970
10971 CV *
10972 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
10973 {
10974     PERL_ARGS_ASSERT_NEWXS_DEFFILE;
10975     return newXS_len_flags(
10976         name, strlen(name), subaddr, NULL, NULL, NULL, 0
10977     );
10978 }
10979
10980 /*
10981 =for apidoc newXS_len_flags
10982
10983 Construct an XS subroutine, also performing some surrounding jobs.
10984
10985 The subroutine will have the entry point C<subaddr>.  It will have
10986 the prototype specified by the nul-terminated string C<proto>, or
10987 no prototype if C<proto> is null.  The prototype string is copied;
10988 the caller can mutate the supplied string afterwards.  If C<filename>
10989 is non-null, it must be a nul-terminated filename, and the subroutine
10990 will have its C<CvFILE> set accordingly.  By default C<CvFILE> is set to
10991 point directly to the supplied string, which must be static.  If C<flags>
10992 has the C<XS_DYNAMIC_FILENAME> bit set, then a copy of the string will
10993 be taken instead.
10994
10995 Other aspects of the subroutine will be left in their default state.
10996 If anything else needs to be done to the subroutine for it to function
10997 correctly, it is the caller's responsibility to do that after this
10998 function has constructed it.  However, beware of the subroutine
10999 potentially being destroyed before this function returns, as described
11000 below.
11001
11002 If C<name> is null then the subroutine will be anonymous, with its
11003 C<CvGV> referring to an C<__ANON__> glob.  If C<name> is non-null then the
11004 subroutine will be named accordingly, referenced by the appropriate glob.
11005 C<name> is a string of length C<len> bytes giving a sigilless symbol name,
11006 in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1 otherwise.
11007 The name may be either qualified or unqualified, with the stash defaulting
11008 in the same manner as for C<gv_fetchpvn_flags>.  C<flags> may contain
11009 flag bits understood by C<gv_fetchpvn_flags> with the same meaning as
11010 they have there, such as C<GV_ADDWARN>.  The symbol is always added to
11011 the stash if necessary, with C<GV_ADDMULTI> semantics.
11012
11013 If there is already a subroutine of the specified name, then the new sub
11014 will replace the existing one in the glob.  A warning may be generated
11015 about the redefinition.  If the old subroutine was C<CvCONST> then the
11016 decision about whether to warn is influenced by an expectation about
11017 whether the new subroutine will become a constant of similar value.
11018 That expectation is determined by C<const_svp>.  (Note that the call to
11019 this function doesn't make the new subroutine C<CvCONST> in any case;
11020 that is left to the caller.)  If C<const_svp> is null then it indicates
11021 that the new subroutine will not become a constant.  If C<const_svp>
11022 is non-null then it indicates that the new subroutine will become a
11023 constant, and it points to an C<SV*> that provides the constant value
11024 that the subroutine will have.
11025
11026 If the subroutine has one of a few special names, such as C<BEGIN> or
11027 C<END>, then it will be claimed by the appropriate queue for automatic
11028 running of phase-related subroutines.  In this case the relevant glob will
11029 be left not containing any subroutine, even if it did contain one before.
11030 In the case of C<BEGIN>, the subroutine will be executed and the reference
11031 to it disposed of before this function returns, and also before its
11032 prototype is set.  If a C<BEGIN> subroutine would not be sufficiently
11033 constructed by this function to be ready for execution then the caller
11034 must prevent this happening by giving the subroutine a different name.
11035
11036 The function returns a pointer to the constructed subroutine.  If the sub
11037 is anonymous then ownership of one counted reference to the subroutine
11038 is transferred to the caller.  If the sub is named then the caller does
11039 not get ownership of a reference.  In most such cases, where the sub
11040 has a non-phase name, the sub will be alive at the point it is returned
11041 by virtue of being contained in the glob that names it.  A phase-named
11042 subroutine will usually be alive by virtue of the reference owned by the
11043 phase's automatic run queue.  But a C<BEGIN> subroutine, having already
11044 been executed, will quite likely have been destroyed already by the
11045 time this function returns, making it erroneous for the caller to make
11046 any use of the returned pointer.  It is the caller's responsibility to
11047 ensure that it knows which of these situations applies.
11048
11049 =cut
11050 */
11051
11052 CV *
11053 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
11054                            XSUBADDR_t subaddr, const char *const filename,
11055                            const char *const proto, SV **const_svp,
11056                            U32 flags)
11057 {
11058     CV *cv;
11059     bool interleave = FALSE;
11060     bool evanescent = FALSE;
11061
11062     PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
11063
11064     {
11065         GV * const gv = gv_fetchpvn(
11066                             name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
11067                             name ? len : PL_curstash ? sizeof("__ANON__") - 1:
11068                                 sizeof("__ANON__::__ANON__") - 1,
11069                             GV_ADDMULTI | flags, SVt_PVCV);
11070
11071         if ((cv = (name ? GvCV(gv) : NULL))) {
11072             if (GvCVGEN(gv)) {
11073                 /* just a cached method */
11074                 SvREFCNT_dec(cv);
11075                 cv = NULL;
11076             }
11077             else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
11078                 /* already defined (or promised) */
11079                 /* Redundant check that allows us to avoid creating an SV
11080                    most of the time: */
11081                 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
11082                     report_redefined_cv(newSVpvn_flags(
11083                                          name,len,(flags&SVf_UTF8)|SVs_TEMP
11084                                         ),
11085                                         cv, const_svp);
11086                 }
11087                 interleave = TRUE;
11088                 ENTER;
11089                 SAVEFREESV(cv);
11090                 cv = NULL;
11091             }
11092         }
11093
11094         if (cv)                         /* must reuse cv if autoloaded */
11095             cv_undef(cv);
11096         else {
11097             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
11098             if (name) {
11099                 GvCV_set(gv,cv);
11100                 GvCVGEN(gv) = 0;
11101                 if (HvENAME_HEK(GvSTASH(gv)))
11102                     gv_method_changed(gv); /* newXS */
11103             }
11104         }
11105         assert(cv);
11106         assert(SvREFCNT((SV*)cv) != 0);
11107
11108         CvGV_set(cv, gv);
11109         if(filename) {
11110             /* XSUBs can't be perl lang/perl5db.pl debugged
11111             if (PERLDB_LINE_OR_SAVESRC)
11112                 (void)gv_fetchfile(filename); */
11113             assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
11114             if (flags & XS_DYNAMIC_FILENAME) {
11115                 CvDYNFILE_on(cv);
11116                 CvFILE(cv) = savepv(filename);
11117             } else {
11118             /* NOTE: not copied, as it is expected to be an external constant string */
11119                 CvFILE(cv) = (char *)filename;
11120             }
11121         } else {
11122             assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
11123             CvFILE(cv) = (char*)PL_xsubfilename;
11124         }
11125         CvISXSUB_on(cv);
11126         CvXSUB(cv) = subaddr;
11127 #ifndef MULTIPLICITY
11128         CvHSCXT(cv) = &PL_stack_sp;
11129 #else
11130         PoisonPADLIST(cv);
11131 #endif
11132
11133         if (name)
11134             evanescent = process_special_blocks(0, name, gv, cv);
11135         else
11136             CvANON_on(cv);
11137     } /* <- not a conditional branch */
11138
11139     assert(cv);
11140     assert(evanescent || SvREFCNT((SV*)cv) != 0);
11141
11142     if (!evanescent) sv_setpv(MUTABLE_SV(cv), proto);
11143     if (interleave) LEAVE;
11144     assert(evanescent || SvREFCNT((SV*)cv) != 0);
11145     return cv;
11146 }
11147
11148 /* Add a stub CV to a typeglob.
11149  * This is the implementation of a forward declaration, 'sub foo';'
11150  */
11151
11152 CV *
11153 Perl_newSTUB(pTHX_ GV *gv, bool fake)
11154 {
11155     CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
11156     GV *cvgv;
11157     PERL_ARGS_ASSERT_NEWSTUB;
11158     assert(!GvCVu(gv));
11159     GvCV_set(gv, cv);
11160     GvCVGEN(gv) = 0;
11161     if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
11162         gv_method_changed(gv);
11163     if (SvFAKE(gv)) {
11164         cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
11165         SvFAKE_off(cvgv);
11166     }
11167     else cvgv = gv;
11168     CvGV_set(cv, cvgv);
11169     CvFILE_set_from_cop(cv, PL_curcop);
11170     CvSTASH_set(cv, PL_curstash);
11171     GvMULTI_on(gv);
11172     return cv;
11173 }
11174
11175 void
11176 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
11177 {
11178     CV *cv;
11179     GV *gv;
11180     OP *root;
11181     OP *start;
11182
11183     if (PL_parser && PL_parser->error_count) {
11184         op_free(block);
11185         goto finish;
11186     }
11187
11188     gv = o
11189         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
11190         : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
11191
11192     GvMULTI_on(gv);
11193     if ((cv = GvFORM(gv))) {
11194         if (ckWARN(WARN_REDEFINE)) {
11195             const line_t oldline = CopLINE(PL_curcop);
11196             if (PL_parser && PL_parser->copline != NOLINE)
11197                 CopLINE_set(PL_curcop, PL_parser->copline);
11198             if (o) {
11199                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
11200                             "Format %" SVf " redefined", SVfARG(cSVOPo->op_sv));
11201             } else {
11202                 /* diag_listed_as: Format %s redefined */
11203                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
11204                             "Format STDOUT redefined");
11205             }
11206             CopLINE_set(PL_curcop, oldline);
11207         }
11208         SvREFCNT_dec(cv);
11209     }
11210     cv = PL_compcv;
11211     GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
11212     CvGV_set(cv, gv);
11213     CvFILE_set_from_cop(cv, PL_curcop);
11214
11215
11216     root = newUNOP(OP_LEAVEWRITE, 0, voidnonfinal(block));
11217     CvROOT(cv) = root;
11218     start = LINKLIST(root);
11219     root->op_next = 0;
11220     S_process_optree(aTHX_ cv, root, start);
11221     cv_forget_slab(cv);
11222
11223   finish:
11224     op_free(o);
11225     if (PL_parser)
11226         PL_parser->copline = NOLINE;
11227     LEAVE_SCOPE(floor);
11228     PL_compiling.cop_seq = 0;
11229 }
11230
11231 OP *
11232 Perl_newANONLIST(pTHX_ OP *o)
11233 {
11234     return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
11235 }
11236
11237 OP *
11238 Perl_newANONHASH(pTHX_ OP *o)
11239 {
11240     return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
11241 }
11242
11243 OP *
11244 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
11245 {
11246     return newANONATTRSUB(floor, proto, NULL, block);
11247 }
11248
11249 OP *
11250 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
11251 {
11252     SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
11253     OP * anoncode =
11254         newSVOP(OP_ANONCODE, 0,
11255                 cv);
11256     if (CvANONCONST(cv))
11257         anoncode = newUNOP(OP_ANONCONST, 0,
11258                            op_convert_list(OP_ENTERSUB,
11259                                            OPf_STACKED|OPf_WANT_SCALAR,
11260                                            anoncode));
11261     return newUNOP(OP_REFGEN, 0, anoncode);
11262 }
11263
11264 OP *
11265 Perl_oopsAV(pTHX_ OP *o)
11266 {
11267
11268     PERL_ARGS_ASSERT_OOPSAV;
11269
11270     switch (o->op_type) {
11271     case OP_PADSV:
11272     case OP_PADHV:
11273         OpTYPE_set(o, OP_PADAV);
11274         return ref(o, OP_RV2AV);
11275
11276     case OP_RV2SV:
11277     case OP_RV2HV:
11278         OpTYPE_set(o, OP_RV2AV);
11279         ref(o, OP_RV2AV);
11280         break;
11281
11282     default:
11283         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
11284         break;
11285     }
11286     return o;
11287 }
11288
11289 OP *
11290 Perl_oopsHV(pTHX_ OP *o)
11291 {
11292
11293     PERL_ARGS_ASSERT_OOPSHV;
11294
11295     switch (o->op_type) {
11296     case OP_PADSV:
11297     case OP_PADAV:
11298         OpTYPE_set(o, OP_PADHV);
11299         return ref(o, OP_RV2HV);
11300
11301     case OP_RV2SV:
11302     case OP_RV2AV:
11303         OpTYPE_set(o, OP_RV2HV);
11304         /* rv2hv steals the bottom bit for its own uses */
11305         o->op_private &= ~OPpARG1_MASK;
11306         ref(o, OP_RV2HV);
11307         break;
11308
11309     default:
11310         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
11311         break;
11312     }
11313     return o;
11314 }
11315
11316 OP *
11317 Perl_newAVREF(pTHX_ OP *o)
11318 {
11319
11320     PERL_ARGS_ASSERT_NEWAVREF;
11321
11322     if (o->op_type == OP_PADANY) {
11323         OpTYPE_set(o, OP_PADAV);
11324         return o;
11325     }
11326     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
11327         Perl_croak(aTHX_ "Can't use an array as a reference");
11328     }
11329     return newUNOP(OP_RV2AV, 0, scalar(o));
11330 }
11331
11332 OP *
11333 Perl_newGVREF(pTHX_ I32 type, OP *o)
11334 {
11335     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
11336         return newUNOP(OP_NULL, 0, o);
11337
11338     if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED &&
11339         ((PL_opargs[type] >> OASHIFT) & 7) == OA_FILEREF &&
11340         o->op_type == OP_CONST && (o->op_private & OPpCONST_BARE)) {
11341         no_bareword_filehandle(SvPVX(cSVOPo_sv));
11342     }
11343
11344     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
11345 }
11346
11347 OP *
11348 Perl_newHVREF(pTHX_ OP *o)
11349 {
11350
11351     PERL_ARGS_ASSERT_NEWHVREF;
11352
11353     if (o->op_type == OP_PADANY) {
11354         OpTYPE_set(o, OP_PADHV);
11355         return o;
11356     }
11357     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
11358         Perl_croak(aTHX_ "Can't use a hash as a reference");
11359     }
11360     return newUNOP(OP_RV2HV, 0, scalar(o));
11361 }
11362
11363 OP *
11364 Perl_newCVREF(pTHX_ I32 flags, OP *o)
11365 {
11366     if (o->op_type == OP_PADANY) {
11367         OpTYPE_set(o, OP_PADCV);
11368     }
11369     return newUNOP(OP_RV2CV, flags, scalar(o));
11370 }
11371
11372 OP *
11373 Perl_newSVREF(pTHX_ OP *o)
11374 {
11375
11376     PERL_ARGS_ASSERT_NEWSVREF;
11377
11378     if (o->op_type == OP_PADANY) {
11379         OpTYPE_set(o, OP_PADSV);
11380         scalar(o);
11381         return o;
11382     }
11383     return newUNOP(OP_RV2SV, 0, scalar(o));
11384 }
11385
11386 /* Check routines. See the comments at the top of this file for details
11387  * on when these are called */
11388
11389 OP *
11390 Perl_ck_anoncode(pTHX_ OP *o)
11391 {
11392     PERL_ARGS_ASSERT_CK_ANONCODE;
11393
11394     cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
11395     cSVOPo->op_sv = NULL;
11396     return o;
11397 }
11398
11399 static void
11400 S_io_hints(pTHX_ OP *o)
11401 {
11402 #if O_BINARY != 0 || O_TEXT != 0
11403     HV * const table =
11404         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
11405     if (table) {
11406         SV **svp = hv_fetchs(table, "open_IN", FALSE);
11407         if (svp && *svp) {
11408             STRLEN len = 0;
11409             const char *d = SvPV_const(*svp, len);
11410             const I32 mode = mode_from_discipline(d, len);
11411             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
11412 #  if O_BINARY != 0
11413             if (mode & O_BINARY)
11414                 o->op_private |= OPpOPEN_IN_RAW;
11415 #  endif
11416 #  if O_TEXT != 0
11417             if (mode & O_TEXT)
11418                 o->op_private |= OPpOPEN_IN_CRLF;
11419 #  endif
11420         }
11421
11422         svp = hv_fetchs(table, "open_OUT", FALSE);
11423         if (svp && *svp) {
11424             STRLEN len = 0;
11425             const char *d = SvPV_const(*svp, len);
11426             const I32 mode = mode_from_discipline(d, len);
11427             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
11428 #  if O_BINARY != 0
11429             if (mode & O_BINARY)
11430                 o->op_private |= OPpOPEN_OUT_RAW;
11431 #  endif
11432 #  if O_TEXT != 0
11433             if (mode & O_TEXT)
11434                 o->op_private |= OPpOPEN_OUT_CRLF;
11435 #  endif
11436         }
11437     }
11438 #else
11439     PERL_UNUSED_CONTEXT;
11440     PERL_UNUSED_ARG(o);
11441 #endif
11442 }
11443
11444 OP *
11445 Perl_ck_backtick(pTHX_ OP *o)
11446 {
11447     GV *gv;
11448     OP *newop = NULL;
11449     OP *sibl;
11450     PERL_ARGS_ASSERT_CK_BACKTICK;
11451     o = ck_fun(o);
11452     /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
11453     if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
11454      && (gv = gv_override("readpipe",8)))
11455     {
11456         /* detach rest of siblings from o and its first child */
11457         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
11458         newop = S_new_entersubop(aTHX_ gv, sibl);
11459     }
11460     else if (!(o->op_flags & OPf_KIDS))
11461         newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
11462     if (newop) {
11463         op_free(o);
11464         return newop;
11465     }
11466     S_io_hints(aTHX_ o);
11467     return o;
11468 }
11469
11470 OP *
11471 Perl_ck_bitop(pTHX_ OP *o)
11472 {
11473     PERL_ARGS_ASSERT_CK_BITOP;
11474
11475     /* get rid of arg count and indicate if in the scope of 'use integer' */
11476     o->op_private = (PL_hints & HINT_INTEGER) ? OPpUSEINT : 0;
11477
11478     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
11479             && OP_IS_INFIX_BIT(o->op_type))
11480     {
11481         const OP * const left = cBINOPo->op_first;
11482         const OP * const right = OpSIBLING(left);
11483         if ((OP_IS_NUMCOMPARE(left->op_type) &&
11484                 (left->op_flags & OPf_PARENS) == 0) ||
11485             (OP_IS_NUMCOMPARE(right->op_type) &&
11486                 (right->op_flags & OPf_PARENS) == 0))
11487             Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
11488                           "Possible precedence problem on bitwise %s operator",
11489                            o->op_type ==  OP_BIT_OR
11490                          ||o->op_type == OP_NBIT_OR  ? "|"
11491                         :  o->op_type ==  OP_BIT_AND
11492                          ||o->op_type == OP_NBIT_AND ? "&"
11493                         :  o->op_type ==  OP_BIT_XOR
11494                          ||o->op_type == OP_NBIT_XOR ? "^"
11495                         :  o->op_type == OP_SBIT_OR  ? "|."
11496                         :  o->op_type == OP_SBIT_AND ? "&." : "^."
11497                            );
11498     }
11499     return o;
11500 }
11501
11502 PERL_STATIC_INLINE bool
11503 is_dollar_bracket(pTHX_ const OP * const o)
11504 {
11505     const OP *kid;
11506     PERL_UNUSED_CONTEXT;
11507     return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
11508         && (kid = cUNOPx(o)->op_first)
11509         && kid->op_type == OP_GV
11510         && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
11511 }
11512
11513 /* for lt, gt, le, ge, eq, ne and their i_ variants */
11514
11515 OP *
11516 Perl_ck_cmp(pTHX_ OP *o)
11517 {
11518     bool is_eq;
11519     bool neg;
11520     bool reverse;
11521     bool iv0;
11522     OP *indexop, *constop, *start;
11523     SV *sv;
11524     IV iv;
11525
11526     PERL_ARGS_ASSERT_CK_CMP;
11527
11528     is_eq = (   o->op_type == OP_EQ
11529              || o->op_type == OP_NE
11530              || o->op_type == OP_I_EQ
11531              || o->op_type == OP_I_NE);
11532
11533     if (!is_eq && ckWARN(WARN_SYNTAX)) {
11534         const OP *kid = cUNOPo->op_first;
11535         if (kid &&
11536             (
11537                 (   is_dollar_bracket(aTHX_ kid)
11538                  && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
11539                 )
11540              || (   kid->op_type == OP_CONST
11541                  && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
11542                 )
11543            )
11544         )
11545             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11546                         "$[ used in %s (did you mean $] ?)", OP_DESC(o));
11547     }
11548
11549     /* convert (index(...) == -1) and variations into
11550      *   (r)index/BOOL(,NEG)
11551      */
11552
11553     reverse = FALSE;
11554
11555     indexop = cUNOPo->op_first;
11556     constop = OpSIBLING(indexop);
11557     start = NULL;
11558     if (indexop->op_type == OP_CONST) {
11559         constop = indexop;
11560         indexop = OpSIBLING(constop);
11561         start = constop;
11562         reverse = TRUE;
11563     }
11564
11565     if (indexop->op_type != OP_INDEX && indexop->op_type != OP_RINDEX)
11566         return o;
11567
11568     /* ($lex = index(....)) == -1 */
11569     if (indexop->op_private & OPpTARGET_MY)
11570         return o;
11571
11572     if (constop->op_type != OP_CONST)
11573         return o;
11574
11575     sv = cSVOPx_sv(constop);
11576     if (!(sv && SvIOK_notUV(sv)))
11577         return o;
11578
11579     iv = SvIVX(sv);
11580     if (iv != -1 && iv != 0)
11581         return o;
11582     iv0 = (iv == 0);
11583
11584     if (o->op_type == OP_LT || o->op_type == OP_I_LT) {
11585         if (!(iv0 ^ reverse))
11586             return o;
11587         neg = iv0;
11588     }
11589     else if (o->op_type == OP_LE || o->op_type == OP_I_LE) {
11590         if (iv0 ^ reverse)
11591             return o;
11592         neg = !iv0;
11593     }
11594     else if (o->op_type == OP_GE || o->op_type == OP_I_GE) {
11595         if (!(iv0 ^ reverse))
11596             return o;
11597         neg = !iv0;
11598     }
11599     else if (o->op_type == OP_GT || o->op_type == OP_I_GT) {
11600         if (iv0 ^ reverse)
11601             return o;
11602         neg = iv0;
11603     }
11604     else if (o->op_type == OP_EQ || o->op_type == OP_I_EQ) {
11605         if (iv0)
11606             return o;
11607         neg = TRUE;
11608     }
11609     else {
11610         assert(o->op_type == OP_NE || o->op_type == OP_I_NE);
11611         if (iv0)
11612             return o;
11613         neg = FALSE;
11614     }
11615
11616     indexop->op_flags &= ~OPf_PARENS;
11617     indexop->op_flags |= (o->op_flags & OPf_PARENS);
11618     indexop->op_private |= OPpTRUEBOOL;
11619     if (neg)
11620         indexop->op_private |= OPpINDEX_BOOLNEG;
11621     /* cut out the index op and free the eq,const ops */
11622     (void)op_sibling_splice(o, start, 1, NULL);
11623     op_free(o);
11624
11625     return indexop;
11626 }
11627
11628
11629 OP *
11630 Perl_ck_concat(pTHX_ OP *o)
11631 {
11632     const OP * const kid = cUNOPo->op_first;
11633
11634     PERL_ARGS_ASSERT_CK_CONCAT;
11635     PERL_UNUSED_CONTEXT;
11636
11637     /* reuse the padtmp returned by the concat child */
11638     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
11639             !(kUNOP->op_first->op_flags & OPf_MOD))
11640     {
11641         o->op_flags |= OPf_STACKED;
11642         o->op_private |= OPpCONCAT_NESTED;
11643     }
11644     return o;
11645 }
11646
11647 OP *
11648 Perl_ck_spair(pTHX_ OP *o)
11649 {
11650
11651     PERL_ARGS_ASSERT_CK_SPAIR;
11652
11653     if (o->op_flags & OPf_KIDS) {
11654         OP* newop;
11655         OP* kid;
11656         OP* kidkid;
11657         const OPCODE type = o->op_type;
11658         o = modkids(ck_fun(o), type);
11659         kid    = cUNOPo->op_first;
11660         kidkid = kUNOP->op_first;
11661         newop = OpSIBLING(kidkid);
11662         if (newop) {
11663             const OPCODE type = newop->op_type;
11664             if (OpHAS_SIBLING(newop))
11665                 return o;
11666             if (o->op_type == OP_REFGEN
11667              && (  type == OP_RV2CV
11668                 || (  !(newop->op_flags & OPf_PARENS)
11669                    && (  type == OP_RV2AV || type == OP_PADAV
11670                       || type == OP_RV2HV || type == OP_PADHV))))
11671                 NOOP; /* OK (allow srefgen for \@a and \%h) */
11672             else if (OP_GIMME(newop,0) != G_SCALAR)
11673                 return o;
11674         }
11675         /* excise first sibling */
11676         op_sibling_splice(kid, NULL, 1, NULL);
11677         op_free(kidkid);
11678     }
11679     /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
11680      * and OP_CHOMP into OP_SCHOMP */
11681     o->op_ppaddr = PL_ppaddr[++o->op_type];
11682     return ck_fun(o);
11683 }
11684
11685 OP *
11686 Perl_ck_delete(pTHX_ OP *o)
11687 {
11688     PERL_ARGS_ASSERT_CK_DELETE;
11689
11690     o = ck_fun(o);
11691     o->op_private = 0;
11692     if (o->op_flags & OPf_KIDS) {
11693         OP * const kid = cUNOPo->op_first;
11694         switch (kid->op_type) {
11695         case OP_ASLICE:
11696             o->op_flags |= OPf_SPECIAL;
11697             /* FALLTHROUGH */
11698         case OP_HSLICE:
11699             o->op_private |= OPpSLICE;
11700             break;
11701         case OP_AELEM:
11702             o->op_flags |= OPf_SPECIAL;
11703             /* FALLTHROUGH */
11704         case OP_HELEM:
11705             break;
11706         case OP_KVASLICE:
11707             o->op_flags |= OPf_SPECIAL;
11708             /* FALLTHROUGH */
11709         case OP_KVHSLICE:
11710             o->op_private |= OPpKVSLICE;
11711             break;
11712         default:
11713             Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
11714                              "element or slice");
11715         }
11716         if (kid->op_private & OPpLVAL_INTRO)
11717             o->op_private |= OPpLVAL_INTRO;
11718         op_null(kid);
11719     }
11720     return o;
11721 }
11722
11723 OP *
11724 Perl_ck_eof(pTHX_ OP *o)
11725 {
11726     PERL_ARGS_ASSERT_CK_EOF;
11727
11728     if (o->op_flags & OPf_KIDS) {
11729         OP *kid;
11730         if (cLISTOPo->op_first->op_type == OP_STUB) {
11731             OP * const newop
11732                 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
11733             op_free(o);
11734             o = newop;
11735         }
11736         o = ck_fun(o);
11737         kid = cLISTOPo->op_first;
11738         if (kid->op_type == OP_RV2GV)
11739             kid->op_private |= OPpALLOW_FAKE;
11740     }
11741     return o;
11742 }
11743
11744
11745 OP *
11746 Perl_ck_eval(pTHX_ OP *o)
11747 {
11748
11749     PERL_ARGS_ASSERT_CK_EVAL;
11750
11751     PL_hints |= HINT_BLOCK_SCOPE;
11752     if (o->op_flags & OPf_KIDS) {
11753         SVOP * const kid = cSVOPx(cUNOPo->op_first);
11754         assert(kid);
11755
11756         if (o->op_type == OP_ENTERTRY) {
11757             LOGOP *enter;
11758
11759             /* cut whole sibling chain free from o */
11760             op_sibling_splice(o, NULL, -1, NULL);
11761             op_free(o);
11762
11763             enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL);
11764
11765             /* establish postfix order */
11766             enter->op_next = (OP*)enter;
11767
11768             o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
11769             OpTYPE_set(o, OP_LEAVETRY);
11770             enter->op_other = o;
11771             return o;
11772         }
11773         else {
11774             scalar((OP*)kid);
11775             S_set_haseval(aTHX);
11776         }
11777     }
11778     else {
11779         const U8 priv = o->op_private;
11780         op_free(o);
11781         /* the newUNOP will recursively call ck_eval(), which will handle
11782          * all the stuff at the end of this function, like adding
11783          * OP_HINTSEVAL
11784          */
11785         return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
11786     }
11787     o->op_targ = (PADOFFSET)PL_hints;
11788     if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
11789     if ((PL_hints & HINT_LOCALIZE_HH) != 0
11790      && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
11791         /* Store a copy of %^H that pp_entereval can pick up. */
11792         HV *hh = hv_copy_hints_hv(GvHV(PL_hintgv));
11793         OP *hhop;
11794         STOREFEATUREBITSHH(hh);
11795         hhop = newSVOP(OP_HINTSEVAL, 0, MUTABLE_SV(hh));
11796         /* append hhop to only child  */
11797         op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
11798
11799         o->op_private |= OPpEVAL_HAS_HH;
11800     }
11801     if (!(o->op_private & OPpEVAL_BYTES)
11802          && FEATURE_UNIEVAL_IS_ENABLED)
11803             o->op_private |= OPpEVAL_UNICODE;
11804     return o;
11805 }
11806
11807 OP *
11808 Perl_ck_trycatch(pTHX_ OP *o)
11809 {
11810     LOGOP *enter;
11811     OP *to_free = NULL;
11812     OP *trykid, *catchkid;
11813     OP *catchroot, *catchstart;
11814
11815     PERL_ARGS_ASSERT_CK_TRYCATCH;
11816
11817     trykid = cUNOPo->op_first;
11818     if(trykid->op_type == OP_NULL || trykid->op_type == OP_PUSHMARK) {
11819         to_free = trykid;
11820         trykid = OpSIBLING(trykid);
11821     }
11822     catchkid = OpSIBLING(trykid);
11823
11824     assert(trykid->op_type == OP_POPTRY);
11825     assert(catchkid->op_type == OP_CATCH);
11826
11827     /* cut whole sibling chain free from o */
11828     op_sibling_splice(o, NULL, -1, NULL);
11829     if(to_free)
11830         op_free(to_free);
11831     op_free(o);
11832
11833     enter = alloc_LOGOP(OP_ENTERTRYCATCH, NULL, NULL);
11834
11835     /* establish postfix order */
11836     enter->op_next = (OP*)enter;
11837
11838     o = op_prepend_elem(OP_LINESEQ, (OP*)enter, trykid);
11839     op_append_elem(OP_LINESEQ, (OP*)o, catchkid);
11840
11841     OpTYPE_set(o, OP_LEAVETRYCATCH);
11842
11843     /* The returned optree is actually threaded up slightly nonobviously in
11844      * terms of its ->op_next pointers.
11845      *
11846      * This way, if the tryblock dies, its retop points at the OP_CATCH, but
11847      * if it does not then its leavetry skips over that and continues
11848      * execution past it.
11849      */
11850
11851     /* First, link up the actual body of the catch block */
11852     catchroot = OpSIBLING(cUNOPx(catchkid)->op_first);
11853     catchstart = LINKLIST(catchroot);
11854     cLOGOPx(catchkid)->op_other = catchstart;
11855
11856     o->op_next = LINKLIST(o);
11857
11858     /* die within try block should jump to the catch */
11859     enter->op_other = catchkid;
11860
11861     /* after try block that doesn't die, just skip straight to leavetrycatch */
11862     trykid->op_next = o;
11863
11864     /* after catch block, skip back up to the leavetrycatch */
11865     catchroot->op_next = o;
11866
11867     return o;
11868 }
11869
11870 OP *
11871 Perl_ck_exec(pTHX_ OP *o)
11872 {
11873     PERL_ARGS_ASSERT_CK_EXEC;
11874
11875     if (o->op_flags & OPf_STACKED) {
11876         OP *kid;
11877         o = ck_fun(o);
11878         kid = OpSIBLING(cUNOPo->op_first);
11879         if (kid->op_type == OP_RV2GV)
11880             op_null(kid);
11881     }
11882     else
11883         o = listkids(o);
11884     return o;
11885 }
11886
11887 OP *
11888 Perl_ck_exists(pTHX_ OP *o)
11889 {
11890     PERL_ARGS_ASSERT_CK_EXISTS;
11891
11892     o = ck_fun(o);
11893     if (o->op_flags & OPf_KIDS) {
11894         OP * const kid = cUNOPo->op_first;
11895         if (kid->op_type == OP_ENTERSUB) {
11896             (void) ref(kid, o->op_type);
11897             if (kid->op_type != OP_RV2CV
11898                         && !(PL_parser && PL_parser->error_count))
11899                 Perl_croak(aTHX_
11900                           "exists argument is not a subroutine name");
11901             o->op_private |= OPpEXISTS_SUB;
11902         }
11903         else if (kid->op_type == OP_AELEM)
11904             o->op_flags |= OPf_SPECIAL;
11905         else if (kid->op_type != OP_HELEM)
11906             Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
11907                              "element or a subroutine");
11908         op_null(kid);
11909     }
11910     return o;
11911 }
11912
11913 OP *
11914 Perl_ck_rvconst(pTHX_ OP *o)
11915 {
11916     SVOP * const kid = cSVOPx(cUNOPo->op_first);
11917
11918     PERL_ARGS_ASSERT_CK_RVCONST;
11919
11920     if (o->op_type == OP_RV2HV)
11921         /* rv2hv steals the bottom bit for its own uses */
11922         o->op_private &= ~OPpARG1_MASK;
11923
11924     o->op_private |= (PL_hints & HINT_STRICT_REFS);
11925
11926     if (kid->op_type == OP_CONST) {
11927         int iscv;
11928         GV *gv;
11929         SV * const kidsv = kid->op_sv;
11930
11931         /* Is it a constant from cv_const_sv()? */
11932         if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
11933             return o;
11934         }
11935         if (SvTYPE(kidsv) == SVt_PVAV) return o;
11936         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
11937             const char *badthing;
11938             switch (o->op_type) {
11939             case OP_RV2SV:
11940                 badthing = "a SCALAR";
11941                 break;
11942             case OP_RV2AV:
11943                 badthing = "an ARRAY";
11944                 break;
11945             case OP_RV2HV:
11946                 badthing = "a HASH";
11947                 break;
11948             default:
11949                 badthing = NULL;
11950                 break;
11951             }
11952             if (badthing)
11953                 Perl_croak(aTHX_
11954                            "Can't use bareword (\"%" SVf "\") as %s ref while \"strict refs\" in use",
11955                            SVfARG(kidsv), badthing);
11956         }
11957         /*
11958          * This is a little tricky.  We only want to add the symbol if we
11959          * didn't add it in the lexer.  Otherwise we get duplicate strict
11960          * warnings.  But if we didn't add it in the lexer, we must at
11961          * least pretend like we wanted to add it even if it existed before,
11962          * or we get possible typo warnings.  OPpCONST_ENTERED says
11963          * whether the lexer already added THIS instance of this symbol.
11964          */
11965         iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
11966         gv = gv_fetchsv(kidsv,
11967                 o->op_type == OP_RV2CV
11968                         && o->op_private & OPpMAY_RETURN_CONSTANT
11969                     ? GV_NOEXPAND
11970                     : iscv | !(kid->op_private & OPpCONST_ENTERED),
11971                 iscv
11972                     ? SVt_PVCV
11973                     : o->op_type == OP_RV2SV
11974                         ? SVt_PV
11975                         : o->op_type == OP_RV2AV
11976                             ? SVt_PVAV
11977                             : o->op_type == OP_RV2HV
11978                                 ? SVt_PVHV
11979                                 : SVt_PVGV);
11980         if (gv) {
11981             if (!isGV(gv)) {
11982                 assert(iscv);
11983                 assert(SvROK(gv));
11984                 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
11985                   && SvTYPE(SvRV(gv)) != SVt_PVCV)
11986                     gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
11987             }
11988             OpTYPE_set(kid, OP_GV);
11989             SvREFCNT_dec(kid->op_sv);
11990 #ifdef USE_ITHREADS
11991             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
11992             STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
11993             kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
11994             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
11995             PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
11996 #else
11997             kid->op_sv = SvREFCNT_inc_simple_NN(gv);
11998 #endif
11999             kid->op_private = 0;
12000             /* FAKE globs in the symbol table cause weird bugs (#77810) */
12001             SvFAKE_off(gv);
12002         }
12003     }
12004     return o;
12005 }
12006
12007 OP *
12008 Perl_ck_ftst(pTHX_ OP *o)
12009 {
12010     const I32 type = o->op_type;
12011
12012     PERL_ARGS_ASSERT_CK_FTST;
12013
12014     if (o->op_flags & OPf_REF) {
12015         NOOP;
12016     }
12017     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
12018         SVOP * const kid = cSVOPx(cUNOPo->op_first);
12019         const OPCODE kidtype = kid->op_type;
12020
12021         if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
12022          && !kid->op_folded) {
12023             if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED) {
12024                 no_bareword_filehandle(SvPVX(kSVOP_sv));
12025             }
12026             OP * const newop = newGVOP(type, OPf_REF,
12027                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
12028             op_free(o);
12029             return newop;
12030         }
12031
12032         if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
12033             SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
12034             if (name) {
12035                 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
12036                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
12037                             array_passed_to_stat, name);
12038             }
12039             else {
12040                 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
12041                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
12042             }
12043        }
12044         scalar((OP *) kid);
12045         if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
12046             o->op_private |= OPpFT_ACCESS;
12047         if (OP_IS_FILETEST(type)
12048             && OP_IS_FILETEST(kidtype)
12049         ) {
12050             o->op_private |= OPpFT_STACKED;
12051             kid->op_private |= OPpFT_STACKING;
12052             if (kidtype == OP_FTTTY && (
12053                    !(kid->op_private & OPpFT_STACKED)
12054                 || kid->op_private & OPpFT_AFTER_t
12055                ))
12056                 o->op_private |= OPpFT_AFTER_t;
12057         }
12058     }
12059     else {
12060         op_free(o);
12061         if (type == OP_FTTTY)
12062             o = newGVOP(type, OPf_REF, PL_stdingv);
12063         else
12064             o = newUNOP(type, 0, newDEFSVOP());
12065     }
12066     return o;
12067 }
12068
12069 OP *
12070 Perl_ck_fun(pTHX_ OP *o)
12071 {
12072     const int type = o->op_type;
12073     I32 oa = PL_opargs[type] >> OASHIFT;
12074
12075     PERL_ARGS_ASSERT_CK_FUN;
12076
12077     if (o->op_flags & OPf_STACKED) {
12078         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
12079             oa &= ~OA_OPTIONAL;
12080         else
12081             return no_fh_allowed(o);
12082     }
12083
12084     if (o->op_flags & OPf_KIDS) {
12085         OP *prev_kid = NULL;
12086         OP *kid = cLISTOPo->op_first;
12087         I32 numargs = 0;
12088         bool seen_optional = FALSE;
12089
12090         if (kid->op_type == OP_PUSHMARK ||
12091             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
12092         {
12093             prev_kid = kid;
12094             kid = OpSIBLING(kid);
12095         }
12096         if (kid && kid->op_type == OP_COREARGS) {
12097             bool optional = FALSE;
12098             while (oa) {
12099                 numargs++;
12100                 if (oa & OA_OPTIONAL) optional = TRUE;
12101                 oa = oa >> 4;
12102             }
12103             if (optional) o->op_private |= numargs;
12104             return o;
12105         }
12106
12107         while (oa) {
12108             if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
12109                 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
12110                     kid = newDEFSVOP();
12111                     /* append kid to chain */
12112                     op_sibling_splice(o, prev_kid, 0, kid);
12113                 }
12114                 seen_optional = TRUE;
12115             }
12116             if (!kid) break;
12117
12118             numargs++;
12119             switch (oa & 7) {
12120             case OA_SCALAR:
12121                 /* list seen where single (scalar) arg expected? */
12122                 if (numargs == 1 && !(oa >> 4)
12123                     && kid->op_type == OP_LIST && type != OP_SCALAR)
12124                 {
12125                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
12126                 }
12127                 if (type != OP_DELETE) scalar(kid);
12128                 break;
12129             case OA_LIST:
12130                 if (oa < 16) {
12131                     kid = 0;
12132                     continue;
12133                 }
12134                 else
12135                     list(kid);
12136                 break;
12137             case OA_AVREF:
12138                 if ((type == OP_PUSH || type == OP_UNSHIFT)
12139                     && !OpHAS_SIBLING(kid))
12140                     Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
12141                                    "Useless use of %s with no values",
12142                                    PL_op_desc[type]);
12143
12144                 if (kid->op_type == OP_CONST
12145                       && (  !SvROK(cSVOPx_sv(kid))
12146                          || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV  )
12147                         )
12148                     bad_type_pv(numargs, "array", o, kid);
12149                 else if (kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV
12150                          || kid->op_type == OP_RV2GV) {
12151                     bad_type_pv(1, "array", o, kid);
12152                 }
12153                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
12154                     yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
12155                                          PL_op_desc[type]), 0);
12156                 }
12157                 else {
12158                     op_lvalue(kid, type);
12159                 }
12160                 break;
12161             case OA_HVREF:
12162                 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
12163                     bad_type_pv(numargs, "hash", o, kid);
12164                 op_lvalue(kid, type);
12165                 break;
12166             case OA_CVREF:
12167                 {
12168                     /* replace kid with newop in chain */
12169                     OP * const newop =
12170                         S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
12171                     newop->op_next = newop;
12172                     kid = newop;
12173                 }
12174                 break;
12175             case OA_FILEREF:
12176                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
12177                     if (kid->op_type == OP_CONST &&
12178                         (kid->op_private & OPpCONST_BARE))
12179                     {
12180                         OP * const newop = newGVOP(OP_GV, 0,
12181                             gv_fetchsv(kSVOP->op_sv, GV_ADD, SVt_PVIO));
12182                         /* a first argument is handled by toke.c, ideally we'd
12183                          just check here but several ops don't use ck_fun() */
12184                         if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED) {
12185                             no_bareword_filehandle(SvPVX(kSVOP_sv));
12186                         }
12187                         /* replace kid with newop in chain */
12188                         op_sibling_splice(o, prev_kid, 1, newop);
12189                         op_free(kid);
12190                         kid = newop;
12191                     }
12192                     else if (kid->op_type == OP_READLINE) {
12193                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
12194                         bad_type_pv(numargs, "HANDLE", o, kid);
12195                     }
12196                     else {
12197                         I32 flags = OPf_SPECIAL;
12198                         I32 priv = 0;
12199                         PADOFFSET targ = 0;
12200
12201                         /* is this op a FH constructor? */
12202                         if (is_handle_constructor(o,numargs)) {
12203                             const char *name = NULL;
12204                             STRLEN len = 0;
12205                             U32 name_utf8 = 0;
12206                             bool want_dollar = TRUE;
12207
12208                             flags = 0;
12209                             /* Set a flag to tell rv2gv to vivify
12210                              * need to "prove" flag does not mean something
12211                              * else already - NI-S 1999/05/07
12212                              */
12213                             priv = OPpDEREF;
12214                             if (kid->op_type == OP_PADSV) {
12215                                 PADNAME * const pn
12216                                     = PAD_COMPNAME_SV(kid->op_targ);
12217                                 name = PadnamePV (pn);
12218                                 len  = PadnameLEN(pn);
12219                                 name_utf8 = PadnameUTF8(pn);
12220                             }
12221                             else if (kid->op_type == OP_RV2SV
12222                                      && kUNOP->op_first->op_type == OP_GV)
12223                             {
12224                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
12225                                 name = GvNAME(gv);
12226                                 len = GvNAMELEN(gv);
12227                                 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
12228                             }
12229                             else if (kid->op_type == OP_AELEM
12230                                      || kid->op_type == OP_HELEM)
12231                             {
12232                                  OP *firstop;
12233                                  OP *op = kBINOP->op_first;
12234                                  name = NULL;
12235                                  if (op) {
12236                                       SV *tmpstr = NULL;
12237                                       const char * const a =
12238                                            kid->op_type == OP_AELEM ?
12239                                            "[]" : "{}";
12240                                       if (((op->op_type == OP_RV2AV) ||
12241                                            (op->op_type == OP_RV2HV)) &&
12242                                           (firstop = cUNOPx(op)->op_first) &&
12243                                           (firstop->op_type == OP_GV)) {
12244                                            /* packagevar $a[] or $h{} */
12245                                            GV * const gv = cGVOPx_gv(firstop);
12246                                            if (gv)
12247                                                 tmpstr =
12248                                                      Perl_newSVpvf(aTHX_
12249                                                                    "%s%c...%c",
12250                                                                    GvNAME(gv),
12251                                                                    a[0], a[1]);
12252                                       }
12253                                       else if (op->op_type == OP_PADAV
12254                                                || op->op_type == OP_PADHV) {
12255                                            /* lexicalvar $a[] or $h{} */
12256                                            const char * const padname =
12257                                                 PAD_COMPNAME_PV(op->op_targ);
12258                                            if (padname)
12259                                                 tmpstr =
12260                                                      Perl_newSVpvf(aTHX_
12261                                                                    "%s%c...%c",
12262                                                                    padname + 1,
12263                                                                    a[0], a[1]);
12264                                       }
12265                                       if (tmpstr) {
12266                                            name = SvPV_const(tmpstr, len);
12267                                            name_utf8 = SvUTF8(tmpstr);
12268                                            sv_2mortal(tmpstr);
12269                                       }
12270                                  }
12271                                  if (!name) {
12272                                       name = "__ANONIO__";
12273                                       len = 10;
12274                                       want_dollar = FALSE;
12275                                  }
12276                                  op_lvalue(kid, type);
12277                             }
12278                             if (name) {
12279                                 SV *namesv;
12280                                 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
12281                                 namesv = PAD_SVl(targ);
12282                                 if (want_dollar && *name != '$')
12283                                     sv_setpvs(namesv, "$");
12284                                 else
12285                                     SvPVCLEAR(namesv);
12286                                 sv_catpvn(namesv, name, len);
12287                                 if ( name_utf8 ) SvUTF8_on(namesv);
12288                             }
12289                         }
12290                         scalar(kid);
12291                         kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
12292                                     OP_RV2GV, flags);
12293                         kid->op_targ = targ;
12294                         kid->op_private |= priv;
12295                     }
12296                 }
12297                 scalar(kid);
12298                 break;
12299             case OA_SCALARREF:
12300                 if ((type == OP_UNDEF || type == OP_POS)
12301                     && numargs == 1 && !(oa >> 4)
12302                     && kid->op_type == OP_LIST)
12303                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
12304                 op_lvalue(scalar(kid), type);
12305                 break;
12306             }
12307             oa >>= 4;
12308             prev_kid = kid;
12309             kid = OpSIBLING(kid);
12310         }
12311         /* FIXME - should the numargs or-ing move after the too many
12312          * arguments check? */
12313         o->op_private |= numargs;
12314         if (kid)
12315             return too_many_arguments_pv(o,OP_DESC(o), 0);
12316         listkids(o);
12317     }
12318     else if (PL_opargs[type] & OA_DEFGV) {
12319         /* Ordering of these two is important to keep f_map.t passing.  */
12320         op_free(o);
12321         return newUNOP(type, 0, newDEFSVOP());
12322     }
12323
12324     if (oa) {
12325         while (oa & OA_OPTIONAL)
12326             oa >>= 4;
12327         if (oa && oa != OA_LIST)
12328             return too_few_arguments_pv(o,OP_DESC(o), 0);
12329     }
12330     return o;
12331 }
12332
12333 OP *
12334 Perl_ck_glob(pTHX_ OP *o)
12335 {
12336     GV *gv;
12337
12338     PERL_ARGS_ASSERT_CK_GLOB;
12339
12340     o = ck_fun(o);
12341     if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
12342         op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
12343
12344     if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
12345     {
12346         /* convert
12347          *     glob
12348          *       \ null - const(wildcard)
12349          * into
12350          *     null
12351          *       \ enter
12352          *            \ list
12353          *                 \ mark - glob - rv2cv
12354          *                             |        \ gv(CORE::GLOBAL::glob)
12355          *                             |
12356          *                              \ null - const(wildcard)
12357          */
12358         o->op_flags |= OPf_SPECIAL;
12359         o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
12360         o = S_new_entersubop(aTHX_ gv, o);
12361         o = newUNOP(OP_NULL, 0, o);
12362         o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
12363         return o;
12364     }
12365     else o->op_flags &= ~OPf_SPECIAL;
12366 #if !defined(PERL_EXTERNAL_GLOB)
12367     if (!PL_globhook) {
12368         ENTER;
12369         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
12370                                newSVpvs("File::Glob"), NULL, NULL, NULL);
12371         LEAVE;
12372     }
12373 #endif /* !PERL_EXTERNAL_GLOB */
12374     gv = (GV *)newSV_type(SVt_NULL);
12375     gv_init(gv, 0, "", 0, 0);
12376     gv_IOadd(gv);
12377     op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
12378     SvREFCNT_dec_NN(gv); /* newGVOP increased it */
12379     scalarkids(o);
12380     return o;
12381 }
12382
12383 OP *
12384 Perl_ck_grep(pTHX_ OP *o)
12385 {
12386     LOGOP *gwop;
12387     OP *kid;
12388     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
12389
12390     PERL_ARGS_ASSERT_CK_GREP;
12391
12392     /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
12393
12394     if (o->op_flags & OPf_STACKED) {
12395         kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
12396         if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
12397             return no_fh_allowed(o);
12398         o->op_flags &= ~OPf_STACKED;
12399     }
12400     kid = OpSIBLING(cLISTOPo->op_first);
12401     if (type == OP_MAPWHILE)
12402         list(kid);
12403     else
12404         scalar(kid);
12405     o = ck_fun(o);
12406     if (PL_parser && PL_parser->error_count)
12407         return o;
12408     kid = OpSIBLING(cLISTOPo->op_first);
12409     if (kid->op_type != OP_NULL)
12410         Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
12411     kid = kUNOP->op_first;
12412
12413     gwop = alloc_LOGOP(type, o, LINKLIST(kid));
12414     kid->op_next = (OP*)gwop;
12415     o->op_private = gwop->op_private = 0;
12416     gwop->op_targ = pad_alloc(type, SVs_PADTMP);
12417
12418     kid = OpSIBLING(cLISTOPo->op_first);
12419     for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
12420         op_lvalue(kid, OP_GREPSTART);
12421
12422     return (OP*)gwop;
12423 }
12424
12425 OP *
12426 Perl_ck_index(pTHX_ OP *o)
12427 {
12428     PERL_ARGS_ASSERT_CK_INDEX;
12429
12430     if (o->op_flags & OPf_KIDS) {
12431         OP *kid = OpSIBLING(cLISTOPo->op_first);        /* get past pushmark */
12432         if (kid)
12433             kid = OpSIBLING(kid);                       /* get past "big" */
12434         if (kid && kid->op_type == OP_CONST) {
12435             const bool save_taint = TAINT_get;
12436             SV *sv = kSVOP->op_sv;
12437             if (   (!SvPOK(sv) || SvNIOKp(sv) || isREGEXP(sv))
12438                 && SvOK(sv) && !SvROK(sv))
12439             {
12440                 sv = newSV_type(SVt_NULL);
12441                 sv_copypv(sv, kSVOP->op_sv);
12442                 SvREFCNT_dec_NN(kSVOP->op_sv);
12443                 kSVOP->op_sv = sv;
12444             }
12445             if (SvOK(sv)) fbm_compile(sv, 0);
12446             TAINT_set(save_taint);
12447 #ifdef NO_TAINT_SUPPORT
12448             PERL_UNUSED_VAR(save_taint);
12449 #endif
12450         }
12451     }
12452     return ck_fun(o);
12453 }
12454
12455 OP *
12456 Perl_ck_lfun(pTHX_ OP *o)
12457 {
12458     const OPCODE type = o->op_type;
12459
12460     PERL_ARGS_ASSERT_CK_LFUN;
12461
12462     return modkids(ck_fun(o), type);
12463 }
12464
12465 OP *
12466 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
12467 {
12468     PERL_ARGS_ASSERT_CK_DEFINED;
12469
12470     if ((o->op_flags & OPf_KIDS)) {
12471         switch (cUNOPo->op_first->op_type) {
12472         case OP_RV2AV:
12473         case OP_PADAV:
12474             Perl_croak(aTHX_ "Can't use 'defined(@array)'"
12475                              " (Maybe you should just omit the defined()?)");
12476             NOT_REACHED; /* NOTREACHED */
12477             break;
12478         case OP_RV2HV:
12479         case OP_PADHV:
12480             Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
12481                              " (Maybe you should just omit the defined()?)");
12482             NOT_REACHED; /* NOTREACHED */
12483             break;
12484         default:
12485             /* no warning */
12486             break;
12487         }
12488     }
12489     return ck_rfun(o);
12490 }
12491
12492 OP *
12493 Perl_ck_readline(pTHX_ OP *o)
12494 {
12495     PERL_ARGS_ASSERT_CK_READLINE;
12496
12497     if (o->op_flags & OPf_KIDS) {
12498          OP *kid = cLISTOPo->op_first;
12499          if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED
12500              && kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
12501              no_bareword_filehandle(SvPVX(kSVOP_sv));
12502          }
12503          if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
12504          scalar(kid);
12505     }
12506     else {
12507         OP * const newop
12508             = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
12509         op_free(o);
12510         return newop;
12511     }
12512     return o;
12513 }
12514
12515 OP *
12516 Perl_ck_rfun(pTHX_ OP *o)
12517 {
12518     const OPCODE type = o->op_type;
12519
12520     PERL_ARGS_ASSERT_CK_RFUN;
12521
12522     return refkids(ck_fun(o), type);
12523 }
12524
12525 OP *
12526 Perl_ck_listiob(pTHX_ OP *o)
12527 {
12528     OP *kid;
12529
12530     PERL_ARGS_ASSERT_CK_LISTIOB;
12531
12532     kid = cLISTOPo->op_first;
12533     if (!kid) {
12534         o = force_list(o, TRUE);
12535         kid = cLISTOPo->op_first;
12536     }
12537     if (kid->op_type == OP_PUSHMARK)
12538         kid = OpSIBLING(kid);
12539     if (kid && o->op_flags & OPf_STACKED)
12540         kid = OpSIBLING(kid);
12541     else if (kid && !OpHAS_SIBLING(kid)) {              /* print HANDLE; */
12542         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
12543          && !kid->op_folded) {
12544             if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED) {
12545                 no_bareword_filehandle(SvPVX(kSVOP_sv));
12546             }
12547             o->op_flags |= OPf_STACKED; /* make it a filehandle */
12548             scalar(kid);
12549             /* replace old const op with new OP_RV2GV parent */
12550             kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
12551                                         OP_RV2GV, OPf_REF);
12552             kid = OpSIBLING(kid);
12553         }
12554     }
12555
12556     if (!kid)
12557         op_append_elem(o->op_type, o, newDEFSVOP());
12558
12559     if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
12560     return listkids(o);
12561 }
12562
12563 OP *
12564 Perl_ck_smartmatch(pTHX_ OP *o)
12565 {
12566     PERL_ARGS_ASSERT_CK_SMARTMATCH;
12567     if (0 == (o->op_flags & OPf_SPECIAL)) {
12568         OP *first  = cBINOPo->op_first;
12569         OP *second = OpSIBLING(first);
12570
12571         /* Implicitly take a reference to an array or hash */
12572
12573         /* remove the original two siblings, then add back the
12574          * (possibly different) first and second sibs.
12575          */
12576         op_sibling_splice(o, NULL, 1, NULL);
12577         op_sibling_splice(o, NULL, 1, NULL);
12578         first  = ref_array_or_hash(first);
12579         second = ref_array_or_hash(second);
12580         op_sibling_splice(o, NULL, 0, second);
12581         op_sibling_splice(o, NULL, 0, first);
12582
12583         /* Implicitly take a reference to a regular expression */
12584         if (first->op_type == OP_MATCH && !(first->op_flags & OPf_STACKED)) {
12585             OpTYPE_set(first, OP_QR);
12586         }
12587         if (second->op_type == OP_MATCH && !(second->op_flags & OPf_STACKED)) {
12588             OpTYPE_set(second, OP_QR);
12589         }
12590     }
12591
12592     return o;
12593 }
12594
12595
12596 static OP *
12597 S_maybe_targlex(pTHX_ OP *o)
12598 {
12599     OP * const kid = cLISTOPo->op_first;
12600     /* has a disposable target? */
12601     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
12602         && !(kid->op_flags & OPf_STACKED)
12603         /* Cannot steal the second time! */
12604         && !(kid->op_private & OPpTARGET_MY)
12605         )
12606     {
12607         OP * const kkid = OpSIBLING(kid);
12608
12609         /* Can just relocate the target. */
12610         if (kkid && kkid->op_type == OP_PADSV
12611             && (!(kkid->op_private & OPpLVAL_INTRO)
12612                || kkid->op_private & OPpPAD_STATE))
12613         {
12614             kid->op_targ = kkid->op_targ;
12615             kkid->op_targ = 0;
12616             /* Now we do not need PADSV and SASSIGN.
12617              * Detach kid and free the rest. */
12618             op_sibling_splice(o, NULL, 1, NULL);
12619             op_free(o);
12620             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
12621             return kid;
12622         }
12623     }
12624     return o;
12625 }
12626
12627 OP *
12628 Perl_ck_sassign(pTHX_ OP *o)
12629 {
12630     OP * const kid = cBINOPo->op_first;
12631
12632     PERL_ARGS_ASSERT_CK_SASSIGN;
12633
12634     if (OpHAS_SIBLING(kid)) {
12635         OP *kkid = OpSIBLING(kid);
12636         /* For state variable assignment with attributes, kkid is a list op
12637            whose op_last is a padsv. */
12638         if ((kkid->op_type == OP_PADSV ||
12639              (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
12640               (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
12641              )
12642             )
12643                 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
12644                     == (OPpLVAL_INTRO|OPpPAD_STATE)) {
12645             return S_newONCEOP(aTHX_ o, kkid);
12646         }
12647     }
12648     return S_maybe_targlex(aTHX_ o);
12649 }
12650
12651
12652 OP *
12653 Perl_ck_match(pTHX_ OP *o)
12654 {
12655     PERL_UNUSED_CONTEXT;
12656     PERL_ARGS_ASSERT_CK_MATCH;
12657
12658     return o;
12659 }
12660
12661 OP *
12662 Perl_ck_method(pTHX_ OP *o)
12663 {
12664     SV *sv, *methsv, *rclass;
12665     const char* method;
12666     char* compatptr;
12667     int utf8;
12668     STRLEN len, nsplit = 0, i;
12669     OP* new_op;
12670     OP * const kid = cUNOPo->op_first;
12671
12672     PERL_ARGS_ASSERT_CK_METHOD;
12673     if (kid->op_type != OP_CONST) return o;
12674
12675     sv = kSVOP->op_sv;
12676
12677     /* replace ' with :: */
12678     while ((compatptr = (char *) memchr(SvPVX(sv), '\'',
12679                                         SvEND(sv) - SvPVX(sv) )))
12680     {
12681         *compatptr = ':';
12682         sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
12683     }
12684
12685     method = SvPVX_const(sv);
12686     len = SvCUR(sv);
12687     utf8 = SvUTF8(sv) ? -1 : 1;
12688
12689     for (i = len - 1; i > 0; --i) if (method[i] == ':') {
12690         nsplit = i+1;
12691         break;
12692     }
12693
12694     methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
12695
12696     if (!nsplit) { /* $proto->method() */
12697         op_free(o);
12698         return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
12699     }
12700
12701     if (memEQs(method, nsplit, "SUPER::")) { /* $proto->SUPER::method() */
12702         op_free(o);
12703         return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
12704     }
12705
12706     /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
12707     if (nsplit >= 9 && strBEGINs(method+nsplit-9, "::SUPER::")) {
12708         rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
12709         new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
12710     } else {
12711         rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
12712         new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
12713     }
12714 #ifdef USE_ITHREADS
12715     op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
12716 #else
12717     cMETHOPx(new_op)->op_rclass_sv = rclass;
12718 #endif
12719     op_free(o);
12720     return new_op;
12721 }
12722
12723 OP *
12724 Perl_ck_null(pTHX_ OP *o)
12725 {
12726     PERL_ARGS_ASSERT_CK_NULL;
12727     PERL_UNUSED_CONTEXT;
12728     return o;
12729 }
12730
12731 OP *
12732 Perl_ck_open(pTHX_ OP *o)
12733 {
12734     PERL_ARGS_ASSERT_CK_OPEN;
12735
12736     S_io_hints(aTHX_ o);
12737     {
12738          /* In case of three-arg dup open remove strictness
12739           * from the last arg if it is a bareword. */
12740          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
12741          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
12742          OP *oa;
12743          const char *mode;
12744
12745          if ((last->op_type == OP_CONST) &&             /* The bareword. */
12746              (last->op_private & OPpCONST_BARE) &&
12747              (last->op_private & OPpCONST_STRICT) &&
12748              (oa = OpSIBLING(first)) &&         /* The fh. */
12749              (oa = OpSIBLING(oa)) &&                    /* The mode. */
12750              (oa->op_type == OP_CONST) &&
12751              SvPOK(cSVOPx(oa)->op_sv) &&
12752              (mode = SvPVX_const(cSVOPx(oa)->op_sv)) &&
12753              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
12754              (last == OpSIBLING(oa)))                   /* The bareword. */
12755               last->op_private &= ~OPpCONST_STRICT;
12756     }
12757     return ck_fun(o);
12758 }
12759
12760 OP *
12761 Perl_ck_prototype(pTHX_ OP *o)
12762 {
12763     PERL_ARGS_ASSERT_CK_PROTOTYPE;
12764     if (!(o->op_flags & OPf_KIDS)) {
12765         op_free(o);
12766         return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
12767     }
12768     return o;
12769 }
12770
12771 OP *
12772 Perl_ck_refassign(pTHX_ OP *o)
12773 {
12774     OP * const right = cLISTOPo->op_first;
12775     OP * const left = OpSIBLING(right);
12776     OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
12777     bool stacked = 0;
12778
12779     PERL_ARGS_ASSERT_CK_REFASSIGN;
12780     assert (left);
12781     assert (left->op_type == OP_SREFGEN);
12782
12783     o->op_private = 0;
12784     /* we use OPpPAD_STATE in refassign to mean either of those things,
12785      * and the code assumes the two flags occupy the same bit position
12786      * in the various ops below */
12787     assert(OPpPAD_STATE == OPpOUR_INTRO);
12788
12789     switch (varop->op_type) {
12790     case OP_PADAV:
12791         o->op_private |= OPpLVREF_AV;
12792         goto settarg;
12793     case OP_PADHV:
12794         o->op_private |= OPpLVREF_HV;
12795         /* FALLTHROUGH */
12796     case OP_PADSV:
12797       settarg:
12798         o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
12799         o->op_targ = varop->op_targ;
12800         varop->op_targ = 0;
12801         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
12802         break;
12803
12804     case OP_RV2AV:
12805         o->op_private |= OPpLVREF_AV;
12806         goto checkgv;
12807         NOT_REACHED; /* NOTREACHED */
12808     case OP_RV2HV:
12809         o->op_private |= OPpLVREF_HV;
12810         /* FALLTHROUGH */
12811     case OP_RV2SV:
12812       checkgv:
12813         o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
12814         if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
12815       detach_and_stack:
12816         /* Point varop to its GV kid, detached.  */
12817         varop = op_sibling_splice(varop, NULL, -1, NULL);
12818         stacked = TRUE;
12819         break;
12820     case OP_RV2CV: {
12821         OP * const kidparent =
12822             OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
12823         OP * const kid = cUNOPx(kidparent)->op_first;
12824         o->op_private |= OPpLVREF_CV;
12825         if (kid->op_type == OP_GV) {
12826             SV *sv = (SV*)cGVOPx_gv(kid);
12827             varop = kidparent;
12828             if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
12829                 /* a CVREF here confuses pp_refassign, so make sure
12830                    it gets a GV */
12831                 CV *const cv = (CV*)SvRV(sv);
12832                 SV *name_sv = newSVhek_mortal(CvNAME_HEK(cv));
12833                 (void)gv_init_sv((GV*)sv, CvSTASH(cv), name_sv, 0);
12834                 assert(SvTYPE(sv) == SVt_PVGV);
12835             }
12836             goto detach_and_stack;
12837         }
12838         if (kid->op_type != OP_PADCV)   goto bad;
12839         o->op_targ = kid->op_targ;
12840         kid->op_targ = 0;
12841         break;
12842     }
12843     case OP_AELEM:
12844     case OP_HELEM:
12845         o->op_private |= (varop->op_private & OPpLVAL_INTRO);
12846         o->op_private |= OPpLVREF_ELEM;
12847         op_null(varop);
12848         stacked = TRUE;
12849         /* Detach varop.  */
12850         op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
12851         break;
12852     default:
12853       bad:
12854         /* diag_listed_as: Can't modify reference to %s in %s assignment */
12855         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
12856                                 "assignment",
12857                                  OP_DESC(varop)));
12858         return o;
12859     }
12860     if (!FEATURE_REFALIASING_IS_ENABLED)
12861         Perl_croak(aTHX_
12862                   "Experimental aliasing via reference not enabled");
12863     Perl_ck_warner_d(aTHX_
12864                      packWARN(WARN_EXPERIMENTAL__REFALIASING),
12865                     "Aliasing via reference is experimental");
12866     if (stacked) {
12867         o->op_flags |= OPf_STACKED;
12868         op_sibling_splice(o, right, 1, varop);
12869     }
12870     else {
12871         o->op_flags &=~ OPf_STACKED;
12872         op_sibling_splice(o, right, 1, NULL);
12873     }
12874     op_free(left);
12875     return o;
12876 }
12877
12878 OP *
12879 Perl_ck_repeat(pTHX_ OP *o)
12880 {
12881     PERL_ARGS_ASSERT_CK_REPEAT;
12882
12883     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
12884         OP* kids;
12885         o->op_private |= OPpREPEAT_DOLIST;
12886         kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
12887         kids = force_list(kids, TRUE); /* promote it to a list */
12888         op_sibling_splice(o, NULL, 0, kids); /* and add back */
12889     }
12890     else
12891         scalar(o);
12892     return o;
12893 }
12894
12895 OP *
12896 Perl_ck_require(pTHX_ OP *o)
12897 {
12898     GV* gv;
12899
12900     PERL_ARGS_ASSERT_CK_REQUIRE;
12901
12902     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
12903         SVOP * const kid = cSVOPx(cUNOPo->op_first);
12904         U32 hash;
12905         char *s;
12906         STRLEN len;
12907         if (kid->op_type == OP_CONST) {
12908           SV * const sv = kid->op_sv;
12909           U32 const was_readonly = SvREADONLY(sv);
12910           if (kid->op_private & OPpCONST_BARE) {
12911             const char *end;
12912             HEK *hek;
12913
12914             if (was_readonly) {
12915                 SvREADONLY_off(sv);
12916             }
12917
12918             if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
12919
12920             s = SvPVX(sv);
12921             len = SvCUR(sv);
12922             end = s + len;
12923             /* treat ::foo::bar as foo::bar */
12924             if (len >= 2 && s[0] == ':' && s[1] == ':')
12925                 DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
12926             if (s == end)
12927                 DIE(aTHX_ "Bareword in require maps to empty filename");
12928
12929             for (; s < end; s++) {
12930                 if (*s == ':' && s[1] == ':') {
12931                     *s = '/';
12932                     Move(s+2, s+1, end - s - 1, char);
12933                     --end;
12934                 }
12935             }
12936             SvEND_set(sv, end);
12937             sv_catpvs(sv, ".pm");
12938             PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
12939             hek = share_hek(SvPVX(sv),
12940                             (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
12941                             hash);
12942             sv_sethek(sv, hek);
12943             unshare_hek(hek);
12944             SvFLAGS(sv) |= was_readonly;
12945           }
12946           else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
12947                 && !SvVOK(sv)) {
12948             s = SvPV(sv, len);
12949             if (SvREFCNT(sv) > 1) {
12950                 kid->op_sv = newSVpvn_share(
12951                     s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
12952                 SvREFCNT_dec_NN(sv);
12953             }
12954             else {
12955                 HEK *hek;
12956                 if (was_readonly) SvREADONLY_off(sv);
12957                 PERL_HASH(hash, s, len);
12958                 hek = share_hek(s,
12959                                 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
12960                                 hash);
12961                 sv_sethek(sv, hek);
12962                 unshare_hek(hek);
12963                 SvFLAGS(sv) |= was_readonly;
12964             }
12965           }
12966         }
12967     }
12968
12969     if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
12970         /* handle override, if any */
12971      && (gv = gv_override("require", 7))) {
12972         OP *kid, *newop;
12973         if (o->op_flags & OPf_KIDS) {
12974             kid = cUNOPo->op_first;
12975             op_sibling_splice(o, NULL, -1, NULL);
12976         }
12977         else {
12978             kid = newDEFSVOP();
12979         }
12980         op_free(o);
12981         newop = S_new_entersubop(aTHX_ gv, kid);
12982         return newop;
12983     }
12984
12985     return ck_fun(o);
12986 }
12987
12988 OP *
12989 Perl_ck_return(pTHX_ OP *o)
12990 {
12991     OP *kid;
12992
12993     PERL_ARGS_ASSERT_CK_RETURN;
12994
12995     kid = OpSIBLING(cLISTOPo->op_first);
12996     if (PL_compcv && CvLVALUE(PL_compcv)) {
12997         for (; kid; kid = OpSIBLING(kid))
12998             op_lvalue(kid, OP_LEAVESUBLV);
12999     }
13000
13001     return o;
13002 }
13003
13004 OP *
13005 Perl_ck_select(pTHX_ OP *o)
13006 {
13007     OP* kid;
13008
13009     PERL_ARGS_ASSERT_CK_SELECT;
13010
13011     if (o->op_flags & OPf_KIDS) {
13012         kid = OpSIBLING(cLISTOPo->op_first);     /* get past pushmark */
13013         if (kid && OpHAS_SIBLING(kid)) {
13014             OpTYPE_set(o, OP_SSELECT);
13015             o = ck_fun(o);
13016             return fold_constants(op_integerize(op_std_init(o)));
13017         }
13018     }
13019     o = ck_fun(o);
13020     kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
13021     if (kid && kid->op_type == OP_RV2GV)
13022         kid->op_private &= ~HINT_STRICT_REFS;
13023     return o;
13024 }
13025
13026 OP *
13027 Perl_ck_shift(pTHX_ OP *o)
13028 {
13029     const I32 type = o->op_type;
13030
13031     PERL_ARGS_ASSERT_CK_SHIFT;
13032
13033     if (!(o->op_flags & OPf_KIDS)) {
13034         OP *argop;
13035
13036         if (!CvUNIQUE(PL_compcv)) {
13037             o->op_flags |= OPf_SPECIAL;
13038             return o;
13039         }
13040
13041         argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
13042         op_free(o);
13043         return newUNOP(type, 0, scalar(argop));
13044     }
13045     return scalar(ck_fun(o));
13046 }
13047
13048 OP *
13049 Perl_ck_sort(pTHX_ OP *o)
13050 {
13051     OP *firstkid;
13052     OP *kid;
13053     U8 stacked;
13054
13055     PERL_ARGS_ASSERT_CK_SORT;
13056
13057     if (o->op_flags & OPf_STACKED)
13058         simplify_sort(o);
13059     firstkid = OpSIBLING(cLISTOPo->op_first);           /* get past pushmark */
13060
13061     if (!firstkid)
13062         return too_few_arguments_pv(o,OP_DESC(o), 0);
13063
13064     if ((stacked = o->op_flags & OPf_STACKED)) {        /* may have been cleared */
13065         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
13066
13067         /* if the first arg is a code block, process it and mark sort as
13068          * OPf_SPECIAL */
13069         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
13070             LINKLIST(kid);
13071             if (kid->op_type == OP_LEAVE)
13072                     op_null(kid);                       /* wipe out leave */
13073             /* Prevent execution from escaping out of the sort block. */
13074             kid->op_next = 0;
13075
13076             /* provide scalar context for comparison function/block */
13077             kid = scalar(firstkid);
13078             kid->op_next = kid;
13079             o->op_flags |= OPf_SPECIAL;
13080         }
13081         else if (kid->op_type == OP_CONST
13082               && kid->op_private & OPpCONST_BARE) {
13083             char tmpbuf[256];
13084             STRLEN len;
13085             PADOFFSET off;
13086             const char * const name = SvPV(kSVOP_sv, len);
13087             *tmpbuf = '&';
13088             assert (len < 256);
13089             Copy(name, tmpbuf+1, len, char);
13090             off = pad_findmy_pvn(tmpbuf, len+1, 0);
13091             if (off != NOT_IN_PAD) {
13092                 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
13093                     SV * const fq =
13094                         newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
13095                     sv_catpvs(fq, "::");
13096                     sv_catsv(fq, kSVOP_sv);
13097                     SvREFCNT_dec_NN(kSVOP_sv);
13098                     kSVOP->op_sv = fq;
13099                 }
13100                 else {
13101                     OP * const padop = newOP(OP_PADCV, 0);
13102                     padop->op_targ = off;
13103                     /* replace the const op with the pad op */
13104                     op_sibling_splice(firstkid, NULL, 1, padop);
13105                     op_free(kid);
13106                 }
13107             }
13108         }
13109
13110         firstkid = OpSIBLING(firstkid);
13111     }
13112
13113     for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
13114         /* provide list context for arguments */
13115         list(kid);
13116         if (stacked)
13117             op_lvalue(kid, OP_GREPSTART);
13118     }
13119
13120     return o;
13121 }
13122
13123 /* for sort { X } ..., where X is one of
13124  *   $a <=> $b, $b <=> $a, $a cmp $b, $b cmp $a
13125  * elide the second child of the sort (the one containing X),
13126  * and set these flags as appropriate
13127         OPpSORT_NUMERIC;
13128         OPpSORT_INTEGER;
13129         OPpSORT_DESCEND;
13130  * Also, check and warn on lexical $a, $b.
13131  */
13132
13133 STATIC void
13134 S_simplify_sort(pTHX_ OP *o)
13135 {
13136     OP *kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
13137     OP *k;
13138     int descending;
13139     GV *gv;
13140     const char *gvname;
13141     bool have_scopeop;
13142
13143     PERL_ARGS_ASSERT_SIMPLIFY_SORT;
13144
13145     kid = kUNOP->op_first;                              /* get past null */
13146     if (!(have_scopeop = kid->op_type == OP_SCOPE)
13147      && kid->op_type != OP_LEAVE)
13148         return;
13149     kid = kLISTOP->op_last;                             /* get past scope */
13150     switch(kid->op_type) {
13151         case OP_NCMP:
13152         case OP_I_NCMP:
13153         case OP_SCMP:
13154             if (!have_scopeop) goto padkids;
13155             break;
13156         default:
13157             return;
13158     }
13159     k = kid;                                            /* remember this node*/
13160     if (kBINOP->op_first->op_type != OP_RV2SV
13161      || kBINOP->op_last ->op_type != OP_RV2SV)
13162     {
13163         /*
13164            Warn about my($a) or my($b) in a sort block, *if* $a or $b is
13165            then used in a comparison.  This catches most, but not
13166            all cases.  For instance, it catches
13167                sort { my($a); $a <=> $b }
13168            but not
13169                sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
13170            (although why you'd do that is anyone's guess).
13171         */
13172
13173        padkids:
13174         if (!ckWARN(WARN_SYNTAX)) return;
13175         kid = kBINOP->op_first;
13176         do {
13177             if (kid->op_type == OP_PADSV) {
13178                 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
13179                 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
13180                  && (  PadnamePV(name)[1] == 'a'
13181                     || PadnamePV(name)[1] == 'b'  ))
13182                     /* diag_listed_as: "my %s" used in sort comparison */
13183                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13184                                      "\"%s %s\" used in sort comparison",
13185                                       PadnameIsSTATE(name)
13186                                         ? "state"
13187                                         : "my",
13188                                       PadnamePV(name));
13189             }
13190         } while ((kid = OpSIBLING(kid)));
13191         return;
13192     }
13193     kid = kBINOP->op_first;                             /* get past cmp */
13194     if (kUNOP->op_first->op_type != OP_GV)
13195         return;
13196     kid = kUNOP->op_first;                              /* get past rv2sv */
13197     gv = kGVOP_gv;
13198     if (GvSTASH(gv) != PL_curstash)
13199         return;
13200     gvname = GvNAME(gv);
13201     if (*gvname == 'a' && gvname[1] == '\0')
13202         descending = 0;
13203     else if (*gvname == 'b' && gvname[1] == '\0')
13204         descending = 1;
13205     else
13206         return;
13207
13208     kid = k;                                            /* back to cmp */
13209     /* already checked above that it is rv2sv */
13210     kid = kBINOP->op_last;                              /* down to 2nd arg */
13211     if (kUNOP->op_first->op_type != OP_GV)
13212         return;
13213     kid = kUNOP->op_first;                              /* get past rv2sv */
13214     gv = kGVOP_gv;
13215     if (GvSTASH(gv) != PL_curstash)
13216         return;
13217     gvname = GvNAME(gv);
13218     if ( descending
13219          ? !(*gvname == 'a' && gvname[1] == '\0')
13220          : !(*gvname == 'b' && gvname[1] == '\0'))
13221         return;
13222     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
13223     if (descending)
13224         o->op_private |= OPpSORT_DESCEND;
13225     if (k->op_type == OP_NCMP)
13226         o->op_private |= OPpSORT_NUMERIC;
13227     if (k->op_type == OP_I_NCMP)
13228         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
13229     kid = OpSIBLING(cLISTOPo->op_first);
13230     /* cut out and delete old block (second sibling) */
13231     op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
13232     op_free(kid);
13233 }
13234
13235 OP *
13236 Perl_ck_split(pTHX_ OP *o)
13237 {
13238     OP *kid;
13239     OP *sibs;
13240
13241     PERL_ARGS_ASSERT_CK_SPLIT;
13242
13243     assert(o->op_type == OP_LIST);
13244
13245     if (o->op_flags & OPf_STACKED)
13246         return no_fh_allowed(o);
13247
13248     kid = cLISTOPo->op_first;
13249     /* delete leading NULL node, then add a CONST if no other nodes */
13250     assert(kid->op_type == OP_NULL);
13251     op_sibling_splice(o, NULL, 1,
13252         OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
13253     op_free(kid);
13254     kid = cLISTOPo->op_first;
13255
13256     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
13257         /* remove match expression, and replace with new optree with
13258          * a match op at its head */
13259         op_sibling_splice(o, NULL, 1, NULL);
13260         /* pmruntime will handle split " " behavior with flag==2 */
13261         kid = pmruntime(newPMOP(OP_MATCH, 0), kid, NULL, 2, 0);
13262         op_sibling_splice(o, NULL, 0, kid);
13263     }
13264
13265     assert(kid->op_type == OP_MATCH || kid->op_type == OP_SPLIT);
13266
13267     if (kPMOP->op_pmflags & PMf_GLOBAL) {
13268       Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
13269                      "Use of /g modifier is meaningless in split");
13270     }
13271
13272     /* eliminate the split op, and move the match op (plus any children)
13273      * into its place, then convert the match op into a split op. i.e.
13274      *
13275      *  SPLIT                    MATCH                 SPLIT(ex-MATCH)
13276      *    |                        |                     |
13277      *  MATCH - A - B - C   =>     R - A - B - C   =>    R - A - B - C
13278      *    |                        |                     |
13279      *    R                        X - Y                 X - Y
13280      *    |
13281      *    X - Y
13282      *
13283      * (R, if it exists, will be a regcomp op)
13284      */
13285
13286     op_sibling_splice(o, NULL, 1, NULL); /* detach match op from o */
13287     sibs = op_sibling_splice(o, NULL, -1, NULL); /* detach any other sibs */
13288     op_sibling_splice(kid, cLISTOPx(kid)->op_last, 0, sibs); /* and reattach */
13289     OpTYPE_set(kid, OP_SPLIT);
13290     kid->op_flags   = (o->op_flags | (kid->op_flags & OPf_KIDS));
13291     kid->op_private = o->op_private;
13292     op_free(o);
13293     o = kid;
13294     kid = sibs; /* kid is now the string arg of the split */
13295
13296     if (!kid) {
13297         kid = newDEFSVOP();
13298         op_append_elem(OP_SPLIT, o, kid);
13299     }
13300     scalar(kid);
13301
13302     kid = OpSIBLING(kid);
13303     if (!kid) {
13304         kid = newSVOP(OP_CONST, 0, newSViv(0));
13305         op_append_elem(OP_SPLIT, o, kid);
13306         o->op_private |= OPpSPLIT_IMPLIM;
13307     }
13308     scalar(kid);
13309
13310     if (OpHAS_SIBLING(kid))
13311         return too_many_arguments_pv(o,OP_DESC(o), 0);
13312
13313     return o;
13314 }
13315
13316 OP *
13317 Perl_ck_stringify(pTHX_ OP *o)
13318 {
13319     OP * const kid = OpSIBLING(cUNOPo->op_first);
13320     PERL_ARGS_ASSERT_CK_STRINGIFY;
13321     if ((   kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
13322          || kid->op_type == OP_LC   || kid->op_type == OP_LCFIRST
13323          || kid->op_type == OP_UC   || kid->op_type == OP_UCFIRST)
13324         && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
13325     {
13326         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
13327         op_free(o);
13328         return kid;
13329     }
13330     return ck_fun(o);
13331 }
13332
13333 OP *
13334 Perl_ck_join(pTHX_ OP *o)
13335 {
13336     OP * const kid = OpSIBLING(cLISTOPo->op_first);
13337
13338     PERL_ARGS_ASSERT_CK_JOIN;
13339
13340     if (kid && kid->op_type == OP_MATCH) {
13341         if (ckWARN(WARN_SYNTAX)) {
13342             const REGEXP *re = PM_GETRE(kPMOP);
13343             const SV *msg = re
13344                     ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
13345                                             SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
13346                     : newSVpvs_flags( "STRING", SVs_TEMP );
13347             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13348                         "/%" SVf "/ should probably be written as \"%" SVf "\"",
13349                         SVfARG(msg), SVfARG(msg));
13350         }
13351     }
13352     if (kid
13353      && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
13354         || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
13355         || (  kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
13356            && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
13357     {
13358         const OP * const bairn = OpSIBLING(kid); /* the list */
13359         if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
13360          && OP_GIMME(bairn,0) == G_SCALAR)
13361         {
13362             OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
13363                                      op_sibling_splice(o, kid, 1, NULL));
13364             op_free(o);
13365             return ret;
13366         }
13367     }
13368
13369     return ck_fun(o);
13370 }
13371
13372 /*
13373 =for apidoc rv2cv_op_cv
13374
13375 Examines an op, which is expected to identify a subroutine at runtime,
13376 and attempts to determine at compile time which subroutine it identifies.
13377 This is normally used during Perl compilation to determine whether
13378 a prototype can be applied to a function call.  C<cvop> is the op
13379 being considered, normally an C<rv2cv> op.  A pointer to the identified
13380 subroutine is returned, if it could be determined statically, and a null
13381 pointer is returned if it was not possible to determine statically.
13382
13383 Currently, the subroutine can be identified statically if the RV that the
13384 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
13385 A C<gv> op is suitable if the GV's CV slot is populated.  A C<const> op is
13386 suitable if the constant value must be an RV pointing to a CV.  Details of
13387 this process may change in future versions of Perl.  If the C<rv2cv> op
13388 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
13389 the subroutine statically: this flag is used to suppress compile-time
13390 magic on a subroutine call, forcing it to use default runtime behaviour.
13391
13392 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
13393 of a GV reference is modified.  If a GV was examined and its CV slot was
13394 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
13395 If the op is not optimised away, and the CV slot is later populated with
13396 a subroutine having a prototype, that flag eventually triggers the warning
13397 "called too early to check prototype".
13398
13399 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
13400 of returning a pointer to the subroutine it returns a pointer to the
13401 GV giving the most appropriate name for the subroutine in this context.
13402 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
13403 (C<CvANON>) subroutine that is referenced through a GV it will be the
13404 referencing GV.  The resulting C<GV*> is cast to C<CV*> to be returned.
13405 A null pointer is returned as usual if there is no statically-determinable
13406 subroutine.
13407
13408 =for apidoc Amnh||OPpEARLY_CV
13409 =for apidoc Amnh||OPpENTERSUB_AMPER
13410 =for apidoc Amnh||RV2CVOPCV_MARK_EARLY
13411 =for apidoc Amnh||RV2CVOPCV_RETURN_NAME_GV
13412
13413 =cut
13414 */
13415
13416 /* shared by toke.c:yylex */
13417 CV *
13418 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
13419 {
13420     PADNAME *name = PAD_COMPNAME(off);
13421     CV *compcv = PL_compcv;
13422     while (PadnameOUTER(name)) {
13423         assert(PARENT_PAD_INDEX(name));
13424         compcv = CvOUTSIDE(compcv);
13425         name = PadlistNAMESARRAY(CvPADLIST(compcv))
13426                 [off = PARENT_PAD_INDEX(name)];
13427     }
13428     assert(!PadnameIsOUR(name));
13429     if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
13430         return PadnamePROTOCV(name);
13431     }
13432     return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
13433 }
13434
13435 CV *
13436 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
13437 {
13438     OP *rvop;
13439     CV *cv;
13440     GV *gv;
13441     PERL_ARGS_ASSERT_RV2CV_OP_CV;
13442     if (flags & ~RV2CVOPCV_FLAG_MASK)
13443         Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
13444     if (cvop->op_type != OP_RV2CV)
13445         return NULL;
13446     if (cvop->op_private & OPpENTERSUB_AMPER)
13447         return NULL;
13448     if (!(cvop->op_flags & OPf_KIDS))
13449         return NULL;
13450     rvop = cUNOPx(cvop)->op_first;
13451     switch (rvop->op_type) {
13452         case OP_GV: {
13453             gv = cGVOPx_gv(rvop);
13454             if (!isGV(gv)) {
13455                 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
13456                     cv = MUTABLE_CV(SvRV(gv));
13457                     gv = NULL;
13458                     break;
13459                 }
13460                 if (flags & RV2CVOPCV_RETURN_STUB)
13461                     return (CV *)gv;
13462                 else return NULL;
13463             }
13464             cv = GvCVu(gv);
13465             if (!cv) {
13466                 if (flags & RV2CVOPCV_MARK_EARLY)
13467                     rvop->op_private |= OPpEARLY_CV;
13468                 return NULL;
13469             }
13470         } break;
13471         case OP_CONST: {
13472             SV *rv = cSVOPx_sv(rvop);
13473             if (!SvROK(rv))
13474                 return NULL;
13475             cv = (CV*)SvRV(rv);
13476             gv = NULL;
13477         } break;
13478         case OP_PADCV: {
13479             cv = find_lexical_cv(rvop->op_targ);
13480             gv = NULL;
13481         } break;
13482         default: {
13483             return NULL;
13484         } NOT_REACHED; /* NOTREACHED */
13485     }
13486     if (SvTYPE((SV*)cv) != SVt_PVCV)
13487         return NULL;
13488     if (flags & RV2CVOPCV_RETURN_NAME_GV) {
13489         if ((!CvANON(cv) && !CvLEXICAL(cv)) || !gv)
13490             gv = CvGV(cv);
13491         return (CV*)gv;
13492     }
13493     else if (flags & RV2CVOPCV_MAYBE_NAME_GV) {
13494         if (CvLEXICAL(cv) || CvNAMED(cv))
13495             return NULL;
13496         if (!CvANON(cv) || !gv)
13497             gv = CvGV(cv);
13498         return (CV*)gv;
13499
13500     } else {
13501         return cv;
13502     }
13503 }
13504
13505 /*
13506 =for apidoc ck_entersub_args_list
13507
13508 Performs the default fixup of the arguments part of an C<entersub>
13509 op tree.  This consists of applying list context to each of the
13510 argument ops.  This is the standard treatment used on a call marked
13511 with C<&>, or a method call, or a call through a subroutine reference,
13512 or any other call where the callee can't be identified at compile time,
13513 or a call where the callee has no prototype.
13514
13515 =cut
13516 */
13517
13518 OP *
13519 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
13520 {
13521     OP *aop;
13522
13523     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
13524
13525     aop = cUNOPx(entersubop)->op_first;
13526     if (!OpHAS_SIBLING(aop))
13527         aop = cUNOPx(aop)->op_first;
13528     for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
13529         /* skip the extra attributes->import() call implicitly added in
13530          * something like foo(my $x : bar)
13531          */
13532         if (   aop->op_type == OP_ENTERSUB
13533             && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
13534         )
13535             continue;
13536         list(aop);
13537         op_lvalue(aop, OP_ENTERSUB);
13538     }
13539     return entersubop;
13540 }
13541
13542 /*
13543 =for apidoc ck_entersub_args_proto
13544
13545 Performs the fixup of the arguments part of an C<entersub> op tree
13546 based on a subroutine prototype.  This makes various modifications to
13547 the argument ops, from applying context up to inserting C<refgen> ops,
13548 and checking the number and syntactic types of arguments, as directed by
13549 the prototype.  This is the standard treatment used on a subroutine call,
13550 not marked with C<&>, where the callee can be identified at compile time
13551 and has a prototype.
13552
13553 C<protosv> supplies the subroutine prototype to be applied to the call.
13554 It may be a normal defined scalar, of which the string value will be used.
13555 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
13556 that has been cast to C<SV*>) which has a prototype.  The prototype
13557 supplied, in whichever form, does not need to match the actual callee
13558 referenced by the op tree.
13559
13560 If the argument ops disagree with the prototype, for example by having
13561 an unacceptable number of arguments, a valid op tree is returned anyway.
13562 The error is reflected in the parser state, normally resulting in a single
13563 exception at the top level of parsing which covers all the compilation
13564 errors that occurred.  In the error message, the callee is referred to
13565 by the name defined by the C<namegv> parameter.
13566
13567 =cut
13568 */
13569
13570 OP *
13571 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
13572 {
13573     STRLEN proto_len;
13574     const char *proto, *proto_end;
13575     OP *aop, *prev, *cvop, *parent;
13576     int optional = 0;
13577     I32 arg = 0;
13578     I32 contextclass = 0;
13579     const char *e = NULL;
13580     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
13581     if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
13582         Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
13583                    "flags=%lx", (unsigned long) SvFLAGS(protosv));
13584     if (SvTYPE(protosv) == SVt_PVCV)
13585          proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
13586     else proto = SvPV(protosv, proto_len);
13587     proto = S_strip_spaces(aTHX_ proto, &proto_len);
13588     proto_end = proto + proto_len;
13589     parent = entersubop;
13590     aop = cUNOPx(entersubop)->op_first;
13591     if (!OpHAS_SIBLING(aop)) {
13592         parent = aop;
13593         aop = cUNOPx(aop)->op_first;
13594     }
13595     prev = aop;
13596     aop = OpSIBLING(aop);
13597     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13598     while (aop != cvop) {
13599         OP* o3 = aop;
13600
13601         if (proto >= proto_end)
13602         {
13603             SV * const namesv = cv_name((CV *)namegv, NULL, 0);
13604             yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13605                                         SVfARG(namesv)), SvUTF8(namesv));
13606             return entersubop;
13607         }
13608
13609         switch (*proto) {
13610             case ';':
13611                 optional = 1;
13612                 proto++;
13613                 continue;
13614             case '_':
13615                 /* _ must be at the end */
13616                 if (proto[1] && !memCHRs(";@%", proto[1]))
13617                     goto oops;
13618                 /* FALLTHROUGH */
13619             case '$':
13620                 proto++;
13621                 arg++;
13622                 scalar(aop);
13623                 break;
13624             case '%':
13625             case '@':
13626                 list(aop);
13627                 arg++;
13628                 break;
13629             case '&':
13630                 proto++;
13631                 arg++;
13632                 if (    o3->op_type != OP_UNDEF
13633                     && (o3->op_type != OP_SREFGEN
13634                         || (  cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
13635                                 != OP_ANONCODE
13636                             && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
13637                                 != OP_RV2CV)))
13638                     bad_type_gv(arg, namegv, o3,
13639                             arg == 1 ? "block or sub {}" : "sub {}");
13640                 break;
13641             case '*':
13642                 /* '*' allows any scalar type, including bareword */
13643                 proto++;
13644                 arg++;
13645                 if (o3->op_type == OP_RV2GV)
13646                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
13647                 else if (o3->op_type == OP_CONST)
13648                     o3->op_private &= ~OPpCONST_STRICT;
13649                 scalar(aop);
13650                 break;
13651             case '+':
13652                 proto++;
13653                 arg++;
13654                 if (o3->op_type == OP_RV2AV ||
13655                     o3->op_type == OP_PADAV ||
13656                     o3->op_type == OP_RV2HV ||
13657                     o3->op_type == OP_PADHV
13658                 ) {
13659                     goto wrapref;
13660                 }
13661                 scalar(aop);
13662                 break;
13663             case '[': case ']':
13664                 goto oops;
13665
13666             case '\\':
13667                 proto++;
13668                 arg++;
13669             again:
13670                 switch (*proto++) {
13671                     case '[':
13672                         if (contextclass++ == 0) {
13673                             e = (char *) memchr(proto, ']', proto_end - proto);
13674                             if (!e || e == proto)
13675                                 goto oops;
13676                         }
13677                         else
13678                             goto oops;
13679                         goto again;
13680
13681                     case ']':
13682                         if (contextclass) {
13683                             const char *p = proto;
13684                             const char *const end = proto;
13685                             contextclass = 0;
13686                             while (*--p != '[')
13687                                 /* \[$] accepts any scalar lvalue */
13688                                 if (*p == '$'
13689                                  && Perl_op_lvalue_flags(aTHX_
13690                                      scalar(o3),
13691                                      OP_READ, /* not entersub */
13692                                      OP_LVALUE_NO_CROAK
13693                                     )) goto wrapref;
13694                             bad_type_gv(arg, namegv, o3,
13695                                     Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
13696                         } else
13697                             goto oops;
13698                         break;
13699                     case '*':
13700                         if (o3->op_type == OP_RV2GV)
13701                             goto wrapref;
13702                         if (!contextclass)
13703                             bad_type_gv(arg, namegv, o3, "symbol");
13704                         break;
13705                     case '&':
13706                         if (o3->op_type == OP_ENTERSUB
13707                          && !(o3->op_flags & OPf_STACKED))
13708                             goto wrapref;
13709                         if (!contextclass)
13710                             bad_type_gv(arg, namegv, o3, "subroutine");
13711                         break;
13712                     case '$':
13713                         if (o3->op_type == OP_RV2SV ||
13714                                 o3->op_type == OP_PADSV ||
13715                                 o3->op_type == OP_HELEM ||
13716                                 o3->op_type == OP_AELEM)
13717                             goto wrapref;
13718                         if (!contextclass) {
13719                             /* \$ accepts any scalar lvalue */
13720                             if (Perl_op_lvalue_flags(aTHX_
13721                                     scalar(o3),
13722                                     OP_READ,  /* not entersub */
13723                                     OP_LVALUE_NO_CROAK
13724                                )) goto wrapref;
13725                             bad_type_gv(arg, namegv, o3, "scalar");
13726                         }
13727                         break;
13728                     case '@':
13729                         if (o3->op_type == OP_RV2AV ||
13730                                 o3->op_type == OP_PADAV)
13731                         {
13732                             o3->op_flags &=~ OPf_PARENS;
13733                             goto wrapref;
13734                         }
13735                         if (!contextclass)
13736                             bad_type_gv(arg, namegv, o3, "array");
13737                         break;
13738                     case '%':
13739                         if (o3->op_type == OP_RV2HV ||
13740                                 o3->op_type == OP_PADHV)
13741                         {
13742                             o3->op_flags &=~ OPf_PARENS;
13743                             goto wrapref;
13744                         }
13745                         if (!contextclass)
13746                             bad_type_gv(arg, namegv, o3, "hash");
13747                         break;
13748                     wrapref:
13749                             aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
13750                                                 OP_REFGEN, 0);
13751                         if (contextclass && e) {
13752                             proto = e + 1;
13753                             contextclass = 0;
13754                         }
13755                         break;
13756                     default: goto oops;
13757                 }
13758                 if (contextclass)
13759                     goto again;
13760                 break;
13761             case ' ':
13762                 proto++;
13763                 continue;
13764             default:
13765             oops: {
13766                 Perl_croak(aTHX_ "Malformed prototype for %" SVf ": %" SVf,
13767                                   SVfARG(cv_name((CV *)namegv, NULL, 0)),
13768                                   SVfARG(protosv));
13769             }
13770         }
13771
13772         op_lvalue(aop, OP_ENTERSUB);
13773         prev = aop;
13774         aop = OpSIBLING(aop);
13775     }
13776     if (aop == cvop && *proto == '_') {
13777         /* generate an access to $_ */
13778         op_sibling_splice(parent, prev, 0, newDEFSVOP());
13779     }
13780     if (!optional && proto_end > proto &&
13781         (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
13782     {
13783         SV * const namesv = cv_name((CV *)namegv, NULL, 0);
13784         yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %" SVf,
13785                                     SVfARG(namesv)), SvUTF8(namesv));
13786     }
13787     return entersubop;
13788 }
13789
13790 /*
13791 =for apidoc ck_entersub_args_proto_or_list
13792
13793 Performs the fixup of the arguments part of an C<entersub> op tree either
13794 based on a subroutine prototype or using default list-context processing.
13795 This is the standard treatment used on a subroutine call, not marked
13796 with C<&>, where the callee can be identified at compile time.
13797
13798 C<protosv> supplies the subroutine prototype to be applied to the call,
13799 or indicates that there is no prototype.  It may be a normal scalar,
13800 in which case if it is defined then the string value will be used
13801 as a prototype, and if it is undefined then there is no prototype.
13802 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
13803 that has been cast to C<SV*>), of which the prototype will be used if it
13804 has one.  The prototype (or lack thereof) supplied, in whichever form,
13805 does not need to match the actual callee referenced by the op tree.
13806
13807 If the argument ops disagree with the prototype, for example by having
13808 an unacceptable number of arguments, a valid op tree is returned anyway.
13809 The error is reflected in the parser state, normally resulting in a single
13810 exception at the top level of parsing which covers all the compilation
13811 errors that occurred.  In the error message, the callee is referred to
13812 by the name defined by the C<namegv> parameter.
13813
13814 =cut
13815 */
13816
13817 OP *
13818 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
13819         GV *namegv, SV *protosv)
13820 {
13821     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
13822     if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
13823         return ck_entersub_args_proto(entersubop, namegv, protosv);
13824     else
13825         return ck_entersub_args_list(entersubop);
13826 }
13827
13828 OP *
13829 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
13830 {
13831     IV cvflags = SvIVX(protosv);
13832     int opnum = cvflags & 0xffff;
13833     OP *aop = cUNOPx(entersubop)->op_first;
13834
13835     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
13836
13837     if (!opnum) {
13838         OP *cvop;
13839         if (!OpHAS_SIBLING(aop))
13840             aop = cUNOPx(aop)->op_first;
13841         aop = OpSIBLING(aop);
13842         for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13843         if (aop != cvop) {
13844             SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
13845             yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13846                 SVfARG(namesv)), SvUTF8(namesv));
13847         }
13848
13849         op_free(entersubop);
13850         switch(cvflags >> 16) {
13851         case 'F': return newSVOP(OP_CONST, 0,
13852                                         newSVpv(CopFILE(PL_curcop),0));
13853         case 'L': return newSVOP(
13854                            OP_CONST, 0,
13855                            Perl_newSVpvf(aTHX_
13856                              "%" IVdf, (IV)CopLINE(PL_curcop)
13857                            )
13858                          );
13859         case 'P': return newSVOP(OP_CONST, 0,
13860                                    (PL_curstash
13861                                      ? newSVhek(HvNAME_HEK(PL_curstash))
13862                                      : &PL_sv_undef
13863                                    )
13864                                 );
13865         }
13866         NOT_REACHED; /* NOTREACHED */
13867     }
13868     else {
13869         OP *prev, *cvop, *first, *parent;
13870         U32 flags = 0;
13871
13872         parent = entersubop;
13873         if (!OpHAS_SIBLING(aop)) {
13874             parent = aop;
13875             aop = cUNOPx(aop)->op_first;
13876         }
13877
13878         first = prev = aop;
13879         aop = OpSIBLING(aop);
13880         /* find last sibling */
13881         for (cvop = aop;
13882              OpHAS_SIBLING(cvop);
13883              prev = cvop, cvop = OpSIBLING(cvop))
13884             ;
13885         if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
13886             /* Usually, OPf_SPECIAL on an op with no args means that it had
13887              * parens, but these have their own meaning for that flag: */
13888             && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
13889             && opnum != OP_DELETE && opnum != OP_EXISTS)
13890                 flags |= OPf_SPECIAL;
13891         /* excise cvop from end of sibling chain */
13892         op_sibling_splice(parent, prev, 1, NULL);
13893         op_free(cvop);
13894         if (aop == cvop) aop = NULL;
13895
13896         /* detach remaining siblings from the first sibling, then
13897          * dispose of original optree */
13898
13899         if (aop)
13900             op_sibling_splice(parent, first, -1, NULL);
13901         op_free(entersubop);
13902
13903         if (cvflags == (OP_ENTEREVAL | (1<<16)))
13904             flags |= OPpEVAL_BYTES <<8;
13905
13906         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
13907         case OA_UNOP:
13908         case OA_BASEOP_OR_UNOP:
13909         case OA_FILESTATOP:
13910             if (!aop)
13911                 return newOP(opnum,flags);       /* zero args */
13912             if (aop == prev)
13913                 return newUNOP(opnum,flags,aop); /* one arg */
13914             /* too many args */
13915             /* FALLTHROUGH */
13916         case OA_BASEOP:
13917             if (aop) {
13918                 SV *namesv;
13919                 OP *nextop;
13920
13921                 namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
13922                 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13923                     SVfARG(namesv)), SvUTF8(namesv));
13924                 while (aop) {
13925                     nextop = OpSIBLING(aop);
13926                     op_free(aop);
13927                     aop = nextop;
13928                 }
13929
13930             }
13931             return opnum == OP_RUNCV
13932                 ? newSVOP(OP_RUNCV, 0, &PL_sv_undef)
13933                 : newOP(opnum,0);
13934         default:
13935             return op_convert_list(opnum,0,aop);
13936         }
13937     }
13938     NOT_REACHED; /* NOTREACHED */
13939     return entersubop;
13940 }
13941
13942 /*
13943 =for apidoc cv_get_call_checker_flags
13944
13945 Retrieves the function that will be used to fix up a call to C<cv>.
13946 Specifically, the function is applied to an C<entersub> op tree for a
13947 subroutine call, not marked with C<&>, where the callee can be identified
13948 at compile time as C<cv>.
13949
13950 The C-level function pointer is returned in C<*ckfun_p>, an SV argument
13951 for it is returned in C<*ckobj_p>, and control flags are returned in
13952 C<*ckflags_p>.  The function is intended to be called in this manner:
13953
13954  entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
13955
13956 In this call, C<entersubop> is a pointer to the C<entersub> op,
13957 which may be replaced by the check function, and C<namegv> supplies
13958 the name that should be used by the check function to refer
13959 to the callee of the C<entersub> op if it needs to emit any diagnostics.
13960 It is permitted to apply the check function in non-standard situations,
13961 such as to a call to a different subroutine or to a method call.
13962
13963 C<namegv> may not actually be a GV.  If the C<CALL_CHECKER_REQUIRE_GV>
13964 bit is clear in C<*ckflags_p>, it is permitted to pass a CV or other SV
13965 instead, anything that can be used as the first argument to L</cv_name>.
13966 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<*ckflags_p> then the
13967 check function requires C<namegv> to be a genuine GV.
13968
13969 By default, the check function is
13970 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
13971 the SV parameter is C<cv> itself, and the C<CALL_CHECKER_REQUIRE_GV>
13972 flag is clear.  This implements standard prototype processing.  It can
13973 be changed, for a particular subroutine, by L</cv_set_call_checker_flags>.
13974
13975 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<gflags> then it
13976 indicates that the caller only knows about the genuine GV version of
13977 C<namegv>, and accordingly the corresponding bit will always be set in
13978 C<*ckflags_p>, regardless of the check function's recorded requirements.
13979 If the C<CALL_CHECKER_REQUIRE_GV> bit is clear in C<gflags> then it
13980 indicates the caller knows about the possibility of passing something
13981 other than a GV as C<namegv>, and accordingly the corresponding bit may
13982 be either set or clear in C<*ckflags_p>, indicating the check function's
13983 recorded requirements.
13984
13985 C<gflags> is a bitset passed into C<cv_get_call_checker_flags>, in which
13986 only the C<CALL_CHECKER_REQUIRE_GV> bit currently has a defined meaning
13987 (for which see above).  All other bits should be clear.
13988
13989 =for apidoc Amnh||CALL_CHECKER_REQUIRE_GV
13990
13991 =for apidoc cv_get_call_checker
13992
13993 The original form of L</cv_get_call_checker_flags>, which does not return
13994 checker flags.  When using a checker function returned by this function,
13995 it is only safe to call it with a genuine GV as its C<namegv> argument.
13996
13997 =cut
13998 */
13999
14000 void
14001 Perl_cv_get_call_checker_flags(pTHX_ CV *cv, U32 gflags,
14002         Perl_call_checker *ckfun_p, SV **ckobj_p, U32 *ckflags_p)
14003 {
14004     MAGIC *callmg;
14005     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER_FLAGS;
14006     PERL_UNUSED_CONTEXT;
14007     callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
14008     if (callmg) {
14009         *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
14010         *ckobj_p = callmg->mg_obj;
14011         *ckflags_p = (callmg->mg_flags | gflags) & MGf_REQUIRE_GV;
14012     } else {
14013         *ckfun_p = Perl_ck_entersub_args_proto_or_list;
14014         *ckobj_p = (SV*)cv;
14015         *ckflags_p = gflags & MGf_REQUIRE_GV;
14016     }
14017 }
14018
14019 void
14020 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
14021 {
14022     U32 ckflags;
14023     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
14024     PERL_UNUSED_CONTEXT;
14025     cv_get_call_checker_flags(cv, CALL_CHECKER_REQUIRE_GV, ckfun_p, ckobj_p,
14026         &ckflags);
14027 }
14028
14029 /*
14030 =for apidoc cv_set_call_checker_flags
14031
14032 Sets the function that will be used to fix up a call to C<cv>.
14033 Specifically, the function is applied to an C<entersub> op tree for a
14034 subroutine call, not marked with C<&>, where the callee can be identified
14035 at compile time as C<cv>.
14036
14037 The C-level function pointer is supplied in C<ckfun>, an SV argument for
14038 it is supplied in C<ckobj>, and control flags are supplied in C<ckflags>.
14039 The function should be defined like this:
14040
14041     STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
14042
14043 It is intended to be called in this manner:
14044
14045     entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
14046
14047 In this call, C<entersubop> is a pointer to the C<entersub> op,
14048 which may be replaced by the check function, and C<namegv> supplies
14049 the name that should be used by the check function to refer
14050 to the callee of the C<entersub> op if it needs to emit any diagnostics.
14051 It is permitted to apply the check function in non-standard situations,
14052 such as to a call to a different subroutine or to a method call.
14053
14054 C<namegv> may not actually be a GV.  For efficiency, perl may pass a
14055 CV or other SV instead.  Whatever is passed can be used as the first
14056 argument to L</cv_name>.  You can force perl to pass a GV by including
14057 C<CALL_CHECKER_REQUIRE_GV> in the C<ckflags>.
14058
14059 C<ckflags> is a bitset, in which only the C<CALL_CHECKER_REQUIRE_GV>
14060 bit currently has a defined meaning (for which see above).  All other
14061 bits should be clear.
14062
14063 The current setting for a particular CV can be retrieved by
14064 L</cv_get_call_checker_flags>.
14065
14066 =for apidoc cv_set_call_checker
14067
14068 The original form of L</cv_set_call_checker_flags>, which passes it the
14069 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.  The effect
14070 of that flag setting is that the check function is guaranteed to get a
14071 genuine GV as its C<namegv> argument.
14072
14073 =cut
14074 */
14075
14076 void
14077 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
14078 {
14079     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
14080     cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
14081 }
14082
14083 void
14084 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
14085                                      SV *ckobj, U32 ckflags)
14086 {
14087     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
14088     if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
14089         if (SvMAGICAL((SV*)cv))
14090             mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
14091     } else {
14092         MAGIC *callmg;
14093         sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
14094         callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
14095         assert(callmg);
14096         if (callmg->mg_flags & MGf_REFCOUNTED) {
14097             SvREFCNT_dec(callmg->mg_obj);
14098             callmg->mg_flags &= ~MGf_REFCOUNTED;
14099         }
14100         callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
14101         callmg->mg_obj = ckobj;
14102         if (ckobj != (SV*)cv) {
14103             SvREFCNT_inc_simple_void_NN(ckobj);
14104             callmg->mg_flags |= MGf_REFCOUNTED;
14105         }
14106         callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
14107                          | (U8)(ckflags & MGf_REQUIRE_GV) | MGf_COPY;
14108     }
14109 }
14110
14111 static void
14112 S_entersub_alloc_targ(pTHX_ OP * const o)
14113 {
14114     o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
14115     o->op_private |= OPpENTERSUB_HASTARG;
14116 }
14117
14118 OP *
14119 Perl_ck_subr(pTHX_ OP *o)
14120 {
14121     OP *aop, *cvop;
14122     CV *cv;
14123     GV *namegv;
14124     SV **const_class = NULL;
14125
14126     PERL_ARGS_ASSERT_CK_SUBR;
14127
14128     aop = cUNOPx(o)->op_first;
14129     if (!OpHAS_SIBLING(aop))
14130         aop = cUNOPx(aop)->op_first;
14131     aop = OpSIBLING(aop);
14132     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
14133     cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
14134     namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
14135
14136     o->op_private &= ~1;
14137     o->op_private |= (PL_hints & HINT_STRICT_REFS);
14138     if (PERLDB_SUB && PL_curstash != PL_debstash)
14139         o->op_private |= OPpENTERSUB_DB;
14140     switch (cvop->op_type) {
14141         case OP_RV2CV:
14142             o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
14143             op_null(cvop);
14144             break;
14145         case OP_METHOD:
14146         case OP_METHOD_NAMED:
14147         case OP_METHOD_SUPER:
14148         case OP_METHOD_REDIR:
14149         case OP_METHOD_REDIR_SUPER:
14150             o->op_flags |= OPf_REF;
14151             if (aop->op_type == OP_CONST) {
14152                 aop->op_private &= ~OPpCONST_STRICT;
14153                 const_class = &cSVOPx(aop)->op_sv;
14154             }
14155             else if (aop->op_type == OP_LIST) {
14156                 OP * const sib = OpSIBLING(cUNOPx(aop)->op_first);
14157                 if (sib && sib->op_type == OP_CONST) {
14158                     sib->op_private &= ~OPpCONST_STRICT;
14159                     const_class = &cSVOPx(sib)->op_sv;
14160                 }
14161             }
14162             /* make class name a shared cow string to speedup method calls */
14163             /* constant string might be replaced with object, f.e. bigint */
14164             if (const_class && SvPOK(*const_class)) {
14165                 STRLEN len;
14166                 const char* str = SvPV(*const_class, len);
14167                 if (len) {
14168                     SV* const shared = newSVpvn_share(
14169                         str, SvUTF8(*const_class)
14170                                     ? -(SSize_t)len : (SSize_t)len,
14171                         0
14172                     );
14173                     if (SvREADONLY(*const_class))
14174                         SvREADONLY_on(shared);
14175                     SvREFCNT_dec(*const_class);
14176                     *const_class = shared;
14177                 }
14178             }
14179             break;
14180     }
14181
14182     if (!cv) {
14183         S_entersub_alloc_targ(aTHX_ o);
14184         return ck_entersub_args_list(o);
14185     } else {
14186         Perl_call_checker ckfun;
14187         SV *ckobj;
14188         U32 ckflags;
14189         cv_get_call_checker_flags(cv, 0, &ckfun, &ckobj, &ckflags);
14190         if (CvISXSUB(cv) || !CvROOT(cv))
14191             S_entersub_alloc_targ(aTHX_ o);
14192         if (!namegv) {
14193             /* The original call checker API guarantees that a GV will
14194                be provided with the right name.  So, if the old API was
14195                used (or the REQUIRE_GV flag was passed), we have to reify
14196                the CV’s GV, unless this is an anonymous sub.  This is not
14197                ideal for lexical subs, as its stringification will include
14198                the package.  But it is the best we can do.  */
14199             if (ckflags & CALL_CHECKER_REQUIRE_GV) {
14200                 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
14201                     namegv = CvGV(cv);
14202             }
14203             else namegv = MUTABLE_GV(cv);
14204             /* After a syntax error in a lexical sub, the cv that
14205                rv2cv_op_cv returns may be a nameless stub. */
14206             if (!namegv) return ck_entersub_args_list(o);
14207
14208         }
14209         return ckfun(aTHX_ o, namegv, ckobj);
14210     }
14211 }
14212
14213 OP *
14214 Perl_ck_svconst(pTHX_ OP *o)
14215 {
14216     SV * const sv = cSVOPo->op_sv;
14217     PERL_ARGS_ASSERT_CK_SVCONST;
14218     PERL_UNUSED_CONTEXT;
14219 #ifdef PERL_COPY_ON_WRITE
14220     /* Since the read-only flag may be used to protect a string buffer, we
14221        cannot do copy-on-write with existing read-only scalars that are not
14222        already copy-on-write scalars.  To allow $_ = "hello" to do COW with
14223        that constant, mark the constant as COWable here, if it is not
14224        already read-only. */
14225     if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
14226         SvIsCOW_on(sv);
14227         CowREFCNT(sv) = 0;
14228 # ifdef PERL_DEBUG_READONLY_COW
14229         sv_buf_to_ro(sv);
14230 # endif
14231     }
14232 #endif
14233     SvREADONLY_on(sv);
14234     return o;
14235 }
14236
14237 OP *
14238 Perl_ck_trunc(pTHX_ OP *o)
14239 {
14240     PERL_ARGS_ASSERT_CK_TRUNC;
14241
14242     if (o->op_flags & OPf_KIDS) {
14243         SVOP *kid = cSVOPx(cUNOPo->op_first);
14244
14245         if (kid->op_type == OP_NULL)
14246             kid = cSVOPx(OpSIBLING(kid));
14247         if (kid && kid->op_type == OP_CONST &&
14248             (kid->op_private & OPpCONST_BARE) &&
14249             !kid->op_folded)
14250         {
14251             o->op_flags |= OPf_SPECIAL;
14252             kid->op_private &= ~OPpCONST_STRICT;
14253             if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED) {
14254                 no_bareword_filehandle(SvPVX(cSVOPx_sv(kid)));
14255             }
14256         }
14257     }
14258     return ck_fun(o);
14259 }
14260
14261 OP *
14262 Perl_ck_substr(pTHX_ OP *o)
14263 {
14264     PERL_ARGS_ASSERT_CK_SUBSTR;
14265
14266     o = ck_fun(o);
14267     if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
14268         OP *kid = cLISTOPo->op_first;
14269
14270         if (kid->op_type == OP_NULL)
14271             kid = OpSIBLING(kid);
14272         if (kid)
14273             /* Historically, substr(delete $foo{bar},...) has been allowed
14274                with 4-arg substr.  Keep it working by applying entersub
14275                lvalue context.  */
14276             op_lvalue(kid, OP_ENTERSUB);
14277
14278     }
14279     return o;
14280 }
14281
14282 OP *
14283 Perl_ck_tell(pTHX_ OP *o)
14284 {
14285     PERL_ARGS_ASSERT_CK_TELL;
14286     o = ck_fun(o);
14287     if (o->op_flags & OPf_KIDS) {
14288      OP *kid = cLISTOPo->op_first;
14289      if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
14290      if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
14291     }
14292     return o;
14293 }
14294
14295 PERL_STATIC_INLINE OP *
14296 S_last_non_null_kid(OP *o) {
14297     OP *last = NULL;
14298     if (cUNOPo->op_flags & OPf_KIDS) {
14299         OP *k = cLISTOPo->op_first;
14300         while (k) {
14301             if (k->op_type != OP_NULL) {
14302                 last = k;
14303             }
14304             k = OpSIBLING(k);
14305         }
14306     }
14307
14308     return last;
14309 }
14310
14311 OP *
14312 Perl_ck_each(pTHX_ OP *o)
14313 {
14314     OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
14315     const unsigned orig_type  = o->op_type;
14316
14317     PERL_ARGS_ASSERT_CK_EACH;
14318
14319     if (kid) {
14320         switch (kid->op_type) {
14321             case OP_PADHV:
14322                 break;
14323
14324             case OP_RV2HV:
14325                 /* Catch out an anonhash here, since the behaviour might be
14326                  * confusing.
14327                  *
14328                  * The typical tree is:
14329                  *
14330                  *     rv2hv
14331                  *         scope
14332                  *             null
14333                  *             anonhash
14334                  *
14335                  * If the contents of the block is more complex you might get:
14336                  *
14337                  *     rv2hv
14338                  *         leave
14339                  *             enter
14340                  *             ...
14341                  *             anonhash
14342                  *
14343                  * Similarly for the anonlist version below.
14344                  */
14345                 if (orig_type == OP_EACH &&
14346                     ckWARN(WARN_SYNTAX) &&
14347                     (cUNOPx(kid)->op_flags & OPf_KIDS) &&
14348                     ( cUNOPx(kid)->op_first->op_type == OP_SCOPE ||
14349                       cUNOPx(kid)->op_first->op_type == OP_LEAVE) &&
14350                     (cUNOPx(kid)->op_first->op_flags & OPf_KIDS)) {
14351                     /* look for last non-null kid, since we might have:
14352                        each %{ some code ; +{ anon hash } }
14353                     */
14354                     OP *k = S_last_non_null_kid(cUNOPx(kid)->op_first);
14355                     if (k && k->op_type == OP_ANONHASH) {
14356                         /* diag_listed_as: each on anonymous %s will always start from the beginning */
14357                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "each on anonymous hash will always start from the beginning");
14358                     }
14359                 }
14360                 break;
14361             case OP_RV2AV:
14362                 if (orig_type == OP_EACH &&
14363                     ckWARN(WARN_SYNTAX) &&
14364                     (cUNOPx(kid)->op_flags & OPf_KIDS) &&
14365                     (cUNOPx(kid)->op_first->op_type == OP_SCOPE ||
14366                      cUNOPx(kid)->op_first->op_type == OP_LEAVE) &&
14367                     (cUNOPx(kid)->op_first->op_flags & OPf_KIDS)) {
14368                     OP *k = S_last_non_null_kid(cUNOPx(kid)->op_first);
14369                     if (k && k->op_type == OP_ANONLIST) {
14370                         /* diag_listed_as: each on anonymous %s will always start from the beginning */
14371                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "each on anonymous array will always start from the beginning");
14372                     }
14373                 }
14374                 /* FALLTHROUGH */
14375             case OP_PADAV:
14376                 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
14377                             : orig_type == OP_KEYS ? OP_AKEYS
14378                             :                        OP_AVALUES);
14379                 break;
14380             case OP_CONST:
14381                 if (kid->op_private == OPpCONST_BARE
14382                  || !SvROK(cSVOPx_sv(kid))
14383                  || (  SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
14384                     && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV  )
14385                    )
14386                     goto bad;
14387                 /* FALLTHROUGH */
14388             default:
14389                 qerror(Perl_mess(aTHX_
14390                     "Experimental %s on scalar is now forbidden",
14391                      PL_op_desc[orig_type]));
14392                bad:
14393                 bad_type_pv(1, "hash or array", o, kid);
14394                 return o;
14395         }
14396     }
14397     return ck_fun(o);
14398 }
14399
14400 OP *
14401 Perl_ck_length(pTHX_ OP *o)
14402 {
14403     PERL_ARGS_ASSERT_CK_LENGTH;
14404
14405     o = ck_fun(o);
14406
14407     if (ckWARN(WARN_SYNTAX)) {
14408         const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
14409
14410         if (kid) {
14411             SV *name = NULL;
14412             const bool hash = kid->op_type == OP_PADHV
14413                            || kid->op_type == OP_RV2HV;
14414             switch (kid->op_type) {
14415                 case OP_PADHV:
14416                 case OP_PADAV:
14417                 case OP_RV2HV:
14418                 case OP_RV2AV:
14419                     name = op_varname(kid);
14420                     break;
14421                 default:
14422                     return o;
14423             }
14424             if (name)
14425                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14426                     "length() used on %" SVf " (did you mean \"scalar(%s%" SVf
14427                     ")\"?)",
14428                     SVfARG(name), hash ? "keys " : "", SVfARG(name)
14429                 );
14430             else if (hash)
14431      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
14432                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14433                     "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
14434             else
14435      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
14436                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14437                     "length() used on @array (did you mean \"scalar(@array)\"?)");
14438         }
14439     }
14440
14441     return o;
14442 }
14443
14444
14445 OP *
14446 Perl_ck_isa(pTHX_ OP *o)
14447 {
14448     OP *classop = cBINOPo->op_last;
14449
14450     PERL_ARGS_ASSERT_CK_ISA;
14451
14452     /* Convert barename into PV */
14453     if(classop->op_type == OP_CONST && classop->op_private & OPpCONST_BARE) {
14454         /* TODO: Optionally convert package to raw HV here */
14455         classop->op_private &= ~(OPpCONST_BARE|OPpCONST_STRICT);
14456     }
14457
14458     return o;
14459 }
14460
14461
14462 /* Check for in place reverse and sort assignments like "@a = reverse @a"
14463    and modify the optree to make them work inplace */
14464
14465 STATIC void
14466 S_inplace_aassign(pTHX_ OP *o) {
14467
14468     OP *modop, *modop_pushmark;
14469     OP *oright;
14470     OP *oleft, *oleft_pushmark;
14471
14472     PERL_ARGS_ASSERT_INPLACE_AASSIGN;
14473
14474     assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
14475
14476     assert(cUNOPo->op_first->op_type == OP_NULL);
14477     modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
14478     assert(modop_pushmark->op_type == OP_PUSHMARK);
14479     modop = OpSIBLING(modop_pushmark);
14480
14481     if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
14482         return;
14483
14484     /* no other operation except sort/reverse */
14485     if (OpHAS_SIBLING(modop))
14486         return;
14487
14488     assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
14489     if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
14490
14491     if (modop->op_flags & OPf_STACKED) {
14492         /* skip sort subroutine/block */
14493         assert(oright->op_type == OP_NULL);
14494         oright = OpSIBLING(oright);
14495     }
14496
14497     assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
14498     oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
14499     assert(oleft_pushmark->op_type == OP_PUSHMARK);
14500     oleft = OpSIBLING(oleft_pushmark);
14501
14502     /* Check the lhs is an array */
14503     if (!oleft ||
14504         (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
14505         || OpHAS_SIBLING(oleft)
14506         || (oleft->op_private & OPpLVAL_INTRO)
14507     )
14508         return;
14509
14510     /* Only one thing on the rhs */
14511     if (OpHAS_SIBLING(oright))
14512         return;
14513
14514     /* check the array is the same on both sides */
14515     if (oleft->op_type == OP_RV2AV) {
14516         if (oright->op_type != OP_RV2AV
14517             || !cUNOPx(oright)->op_first
14518             || cUNOPx(oright)->op_first->op_type != OP_GV
14519             || cUNOPx(oleft )->op_first->op_type != OP_GV
14520             || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
14521                cGVOPx_gv(cUNOPx(oright)->op_first)
14522         )
14523             return;
14524     }
14525     else if (oright->op_type != OP_PADAV
14526         || oright->op_targ != oleft->op_targ
14527     )
14528         return;
14529
14530     /* This actually is an inplace assignment */
14531
14532     modop->op_private |= OPpSORT_INPLACE;
14533
14534     /* transfer MODishness etc from LHS arg to RHS arg */
14535     oright->op_flags = oleft->op_flags;
14536
14537     /* remove the aassign op and the lhs */
14538     op_null(o);
14539     op_null(oleft_pushmark);
14540     if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
14541         op_null(cUNOPx(oleft)->op_first);
14542     op_null(oleft);
14543 }
14544
14545
14546 /*
14547 =for apidoc_section $custom
14548
14549 =for apidoc Perl_custom_op_xop
14550 Return the XOP structure for a given custom op.  This macro should be
14551 considered internal to C<OP_NAME> and the other access macros: use them instead.
14552 This macro does call a function.  Prior
14553 to 5.19.6, this was implemented as a
14554 function.
14555
14556 =cut
14557 */
14558
14559
14560 /* use PERL_MAGIC_ext to call a function to free the xop structure when
14561  * freeing PL_custom_ops */
14562
14563 static int
14564 custom_op_register_free(pTHX_ SV *sv, MAGIC *mg)
14565 {
14566     XOP *xop;
14567
14568     PERL_UNUSED_ARG(mg);
14569     xop = INT2PTR(XOP *, SvIV(sv));
14570     Safefree(xop->xop_name);
14571     Safefree(xop->xop_desc);
14572     Safefree(xop);
14573     return 0;
14574 }
14575
14576
14577 static const MGVTBL custom_op_register_vtbl = {
14578     0,                          /* get */
14579     0,                          /* set */
14580     0,                          /* len */
14581     0,                          /* clear */
14582     custom_op_register_free,     /* free */
14583     0,                          /* copy */
14584     0,                          /* dup */
14585 #ifdef MGf_LOCAL
14586     0,                          /* local */
14587 #endif
14588 };
14589
14590
14591 XOPRETANY
14592 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
14593 {
14594     SV *keysv;
14595     HE *he = NULL;
14596     XOP *xop;
14597
14598     static const XOP xop_null = { 0, 0, 0, 0, 0 };
14599
14600     PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
14601     assert(o->op_type == OP_CUSTOM);
14602
14603     /* This is wrong. It assumes a function pointer can be cast to IV,
14604      * which isn't guaranteed, but this is what the old custom OP code
14605      * did. In principle it should be safer to Copy the bytes of the
14606      * pointer into a PV: since the new interface is hidden behind
14607      * functions, this can be changed later if necessary.  */
14608     /* Change custom_op_xop if this ever happens */
14609     keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
14610
14611     if (PL_custom_ops)
14612         he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
14613
14614     /* See if the op isn't registered, but its name *is* registered.
14615      * That implies someone is using the pre-5.14 API,where only name and
14616      * description could be registered. If so, fake up a real
14617      * registration.
14618      * We only check for an existing name, and assume no one will have
14619      * just registered a desc */
14620     if (!he && PL_custom_op_names &&
14621         (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
14622     ) {
14623         const char *pv;
14624         STRLEN l;
14625
14626         /* XXX does all this need to be shared mem? */
14627         Newxz(xop, 1, XOP);
14628         pv = SvPV(HeVAL(he), l);
14629         XopENTRY_set(xop, xop_name, savepvn(pv, l));
14630         if (PL_custom_op_descs &&
14631             (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
14632         ) {
14633             pv = SvPV(HeVAL(he), l);
14634             XopENTRY_set(xop, xop_desc, savepvn(pv, l));
14635         }
14636         Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
14637         he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
14638         /* add magic to the SV so that the xop struct (pointed to by
14639          * SvIV(sv)) is freed. Normally a static xop is registered, but
14640          * for this backcompat hack, we've alloced one */
14641         (void)sv_magicext(HeVAL(he), NULL, PERL_MAGIC_ext,
14642                 &custom_op_register_vtbl, NULL, 0);
14643
14644     }
14645     else {
14646         if (!he)
14647             xop = (XOP *)&xop_null;
14648         else
14649             xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
14650     }
14651
14652     {
14653         XOPRETANY any;
14654         if(field == XOPe_xop_ptr) {
14655             any.xop_ptr = xop;
14656         } else {
14657             const U32 flags = XopFLAGS(xop);
14658             if(flags & field) {
14659                 switch(field) {
14660                 case XOPe_xop_name:
14661                     any.xop_name = xop->xop_name;
14662                     break;
14663                 case XOPe_xop_desc:
14664                     any.xop_desc = xop->xop_desc;
14665                     break;
14666                 case XOPe_xop_class:
14667                     any.xop_class = xop->xop_class;
14668                     break;
14669                 case XOPe_xop_peep:
14670                     any.xop_peep = xop->xop_peep;
14671                     break;
14672                 default:
14673                   field_panic:
14674                     Perl_croak(aTHX_
14675                         "panic: custom_op_get_field(): invalid field %d\n",
14676                         (int)field);
14677                     break;
14678                 }
14679             } else {
14680                 switch(field) {
14681                 case XOPe_xop_name:
14682                     any.xop_name = XOPd_xop_name;
14683                     break;
14684                 case XOPe_xop_desc:
14685                     any.xop_desc = XOPd_xop_desc;
14686                     break;
14687                 case XOPe_xop_class:
14688                     any.xop_class = XOPd_xop_class;
14689                     break;
14690                 case XOPe_xop_peep:
14691                     any.xop_peep = XOPd_xop_peep;
14692                     break;
14693                 default:
14694                     goto field_panic;
14695                     break;
14696                 }
14697             }
14698         }
14699         return any;
14700     }
14701 }
14702
14703 /*
14704 =for apidoc custom_op_register
14705 Register a custom op.  See L<perlguts/"Custom Operators">.
14706
14707 =cut
14708 */
14709
14710 void
14711 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
14712 {
14713     SV *keysv;
14714
14715     PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
14716
14717     /* see the comment in custom_op_xop */
14718     keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
14719
14720     if (!PL_custom_ops)
14721         PL_custom_ops = newHV();
14722
14723     if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
14724         Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
14725 }
14726
14727 /*
14728
14729 =for apidoc core_prototype
14730
14731 This function assigns the prototype of the named core function to C<sv>, or
14732 to a new mortal SV if C<sv> is C<NULL>.  It returns the modified C<sv>, or
14733 C<NULL> if the core function has no prototype.  C<code> is a code as returned
14734 by C<keyword()>.  It must not be equal to 0.
14735
14736 =cut
14737 */
14738
14739 SV *
14740 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
14741                           int * const opnum)
14742 {
14743     int i = 0, n = 0, seen_question = 0, defgv = 0;
14744     I32 oa;
14745 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
14746     char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
14747     bool nullret = FALSE;
14748
14749     PERL_ARGS_ASSERT_CORE_PROTOTYPE;
14750
14751     assert (code);
14752
14753     if (!sv) sv = sv_newmortal();
14754
14755 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
14756
14757     switch (code < 0 ? -code : code) {
14758     case KEY_and   : case KEY_chop: case KEY_chomp:
14759     case KEY_cmp   : case KEY_defined: case KEY_delete: case KEY_exec  :
14760     case KEY_exists: case KEY_eq     : case KEY_ge    : case KEY_goto  :
14761     case KEY_grep  : case KEY_gt     : case KEY_last  : case KEY_le    :
14762     case KEY_lt    : case KEY_map    : case KEY_ne    : case KEY_next  :
14763     case KEY_or    : case KEY_print  : case KEY_printf: case KEY_qr    :
14764     case KEY_redo  : case KEY_require: case KEY_return: case KEY_say   :
14765     case KEY_select: case KEY_sort   : case KEY_split : case KEY_system:
14766     case KEY_x     : case KEY_xor    :
14767         if (!opnum) return NULL; nullret = TRUE; goto findopnum;
14768     case KEY_glob:    retsetpvs("_;", OP_GLOB);
14769     case KEY_keys:    retsetpvs("\\[%@]", OP_KEYS);
14770     case KEY_values:  retsetpvs("\\[%@]", OP_VALUES);
14771     case KEY_each:    retsetpvs("\\[%@]", OP_EACH);
14772     case KEY_pos:     retsetpvs(";\\[$*]", OP_POS);
14773     case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
14774         retsetpvs("", 0);
14775     case KEY_evalbytes:
14776         name = "entereval"; break;
14777     case KEY_readpipe:
14778         name = "backtick";
14779     }
14780
14781 #undef retsetpvs
14782
14783   findopnum:
14784     while (i < MAXO) {  /* The slow way. */
14785         if (strEQ(name, PL_op_name[i])
14786             || strEQ(name, PL_op_desc[i]))
14787         {
14788             if (nullret) { assert(opnum); *opnum = i; return NULL; }
14789             goto found;
14790         }
14791         i++;
14792     }
14793     return NULL;
14794   found:
14795     defgv = PL_opargs[i] & OA_DEFGV;
14796     oa = PL_opargs[i] >> OASHIFT;
14797     while (oa) {
14798         if (oa & OA_OPTIONAL && !seen_question && (
14799               !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
14800         )) {
14801             seen_question = 1;
14802             str[n++] = ';';
14803         }
14804         if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
14805             && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
14806             /* But globs are already references (kinda) */
14807             && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
14808         ) {
14809             str[n++] = '\\';
14810         }
14811         if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
14812          && !scalar_mod_type(NULL, i)) {
14813             str[n++] = '[';
14814             str[n++] = '$';
14815             str[n++] = '@';
14816             str[n++] = '%';
14817             if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
14818             str[n++] = '*';
14819             str[n++] = ']';
14820         }
14821         else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
14822         if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
14823             str[n-1] = '_'; defgv = 0;
14824         }
14825         oa = oa >> 4;
14826     }
14827     if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
14828     str[n++] = '\0';
14829     sv_setpvn(sv, str, n - 1);
14830     if (opnum) *opnum = i;
14831     return sv;
14832 }
14833
14834 OP *
14835 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
14836                       const int opnum)
14837 {
14838     OP * const argop = (opnum == OP_SELECT && code) ? NULL :
14839                                         newSVOP(OP_COREARGS,0,coreargssv);
14840     OP *o;
14841
14842     PERL_ARGS_ASSERT_CORESUB_OP;
14843
14844     switch(opnum) {
14845     case 0:
14846         return op_append_elem(OP_LINESEQ,
14847                        argop,
14848                        newSLICEOP(0,
14849                                   newSVOP(OP_CONST, 0, newSViv(-code % 3)),
14850                                   newOP(OP_CALLER,0)
14851                        )
14852                );
14853     case OP_EACH:
14854     case OP_KEYS:
14855     case OP_VALUES:
14856         o = newUNOP(OP_AVHVSWITCH,0,argop);
14857         o->op_private = opnum-OP_EACH;
14858         return o;
14859     case OP_SELECT: /* which represents OP_SSELECT as well */
14860         if (code)
14861             return newCONDOP(
14862                          0,
14863                          newBINOP(OP_GT, 0,
14864                                   newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
14865                                   newSVOP(OP_CONST, 0, newSVuv(1))
14866                                  ),
14867                          coresub_op(newSVuv((UV)OP_SSELECT), 0,
14868                                     OP_SSELECT),
14869                          coresub_op(coreargssv, 0, OP_SELECT)
14870                    );
14871         /* FALLTHROUGH */
14872     default:
14873         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
14874         case OA_BASEOP:
14875             return op_append_elem(
14876                         OP_LINESEQ, argop,
14877                         newOP(opnum,
14878                               opnum == OP_WANTARRAY || opnum == OP_RUNCV
14879                                 ? OPpOFFBYONE << 8 : 0)
14880                    );
14881         case OA_BASEOP_OR_UNOP:
14882             if (opnum == OP_ENTEREVAL) {
14883                 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
14884                 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
14885             }
14886             else o = newUNOP(opnum,0,argop);
14887             if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
14888             else {
14889           onearg:
14890               if (is_handle_constructor(o, 1))
14891                 argop->op_private |= OPpCOREARGS_DEREF1;
14892               if (scalar_mod_type(NULL, opnum))
14893                 argop->op_private |= OPpCOREARGS_SCALARMOD;
14894             }
14895             return o;
14896         default:
14897             o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
14898             if (is_handle_constructor(o, 2))
14899                 argop->op_private |= OPpCOREARGS_DEREF2;
14900             if (opnum == OP_SUBSTR) {
14901                 o->op_private |= OPpMAYBE_LVSUB;
14902                 return o;
14903             }
14904             else goto onearg;
14905         }
14906     }
14907 }
14908
14909 void
14910 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
14911                                SV * const *new_const_svp)
14912 {
14913     const char *hvname;
14914     bool is_const = cBOOL(CvCONST(old_cv));
14915     SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
14916
14917     PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
14918
14919     if (is_const && new_const_svp && old_const_sv == *new_const_svp)
14920         return;
14921         /* They are 2 constant subroutines generated from
14922            the same constant. This probably means that
14923            they are really the "same" proxy subroutine
14924            instantiated in 2 places. Most likely this is
14925            when a constant is exported twice.  Don't warn.
14926         */
14927     if (
14928         (ckWARN(WARN_REDEFINE)
14929          && !(
14930                 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
14931              && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
14932              && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
14933                  strEQ(hvname, "autouse"))
14934              )
14935         )
14936      || (is_const
14937          && ckWARN_d(WARN_REDEFINE)
14938          && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
14939         )
14940     )
14941         Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
14942                           is_const
14943                             ? "Constant subroutine %" SVf " redefined"
14944                             : "Subroutine %" SVf " redefined",
14945                           SVfARG(name));
14946 }
14947
14948 /*
14949 =for apidoc_section $hook
14950
14951 These functions provide convenient and thread-safe means of manipulating
14952 hook variables.
14953
14954 =cut
14955 */
14956
14957 /*
14958 =for apidoc wrap_op_checker
14959
14960 Puts a C function into the chain of check functions for a specified op
14961 type.  This is the preferred way to manipulate the L</PL_check> array.
14962 C<opcode> specifies which type of op is to be affected.  C<new_checker>
14963 is a pointer to the C function that is to be added to that opcode's
14964 check chain, and C<old_checker_p> points to the storage location where a
14965 pointer to the next function in the chain will be stored.  The value of
14966 C<new_checker> is written into the L</PL_check> array, while the value
14967 previously stored there is written to C<*old_checker_p>.
14968
14969 L</PL_check> is global to an entire process, and a module wishing to
14970 hook op checking may find itself invoked more than once per process,
14971 typically in different threads.  To handle that situation, this function
14972 is idempotent.  The location C<*old_checker_p> must initially (once
14973 per process) contain a null pointer.  A C variable of static duration
14974 (declared at file scope, typically also marked C<static> to give
14975 it internal linkage) will be implicitly initialised appropriately,
14976 if it does not have an explicit initialiser.  This function will only
14977 actually modify the check chain if it finds C<*old_checker_p> to be null.
14978 This function is also thread safe on the small scale.  It uses appropriate
14979 locking to avoid race conditions in accessing L</PL_check>.
14980
14981 When this function is called, the function referenced by C<new_checker>
14982 must be ready to be called, except for C<*old_checker_p> being unfilled.
14983 In a threading situation, C<new_checker> may be called immediately,
14984 even before this function has returned.  C<*old_checker_p> will always
14985 be appropriately set before C<new_checker> is called.  If C<new_checker>
14986 decides not to do anything special with an op that it is given (which
14987 is the usual case for most uses of op check hooking), it must chain the
14988 check function referenced by C<*old_checker_p>.
14989
14990 Taken all together, XS code to hook an op checker should typically look
14991 something like this:
14992
14993     static Perl_check_t nxck_frob;
14994     static OP *myck_frob(pTHX_ OP *op) {
14995         ...
14996         op = nxck_frob(aTHX_ op);
14997         ...
14998         return op;
14999     }
15000     BOOT:
15001         wrap_op_checker(OP_FROB, myck_frob, &nxck_frob);
15002
15003 If you want to influence compilation of calls to a specific subroutine,
15004 then use L</cv_set_call_checker_flags> rather than hooking checking of
15005 all C<entersub> ops.
15006
15007 =cut
15008 */
15009
15010 void
15011 Perl_wrap_op_checker(pTHX_ Optype opcode,
15012     Perl_check_t new_checker, Perl_check_t *old_checker_p)
15013 {
15014
15015     PERL_UNUSED_CONTEXT;
15016     PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
15017     if (*old_checker_p) return;
15018     OP_CHECK_MUTEX_LOCK;
15019     if (!*old_checker_p) {
15020         *old_checker_p = PL_check[opcode];
15021         PL_check[opcode] = new_checker;
15022     }
15023     OP_CHECK_MUTEX_UNLOCK;
15024 }
15025
15026 #include "XSUB.h"
15027
15028 /* Efficient sub that returns a constant scalar value. */
15029 static void
15030 const_sv_xsub(pTHX_ CV* cv)
15031 {
15032     dXSARGS;
15033     SV *const sv = MUTABLE_SV(XSANY.any_ptr);
15034     PERL_UNUSED_ARG(items);
15035     if (!sv) {
15036         XSRETURN(0);
15037     }
15038     EXTEND(sp, 1);
15039     ST(0) = sv;
15040     XSRETURN(1);
15041 }
15042
15043 static void
15044 const_av_xsub(pTHX_ CV* cv)
15045 {
15046     dXSARGS;
15047     AV * const av = MUTABLE_AV(XSANY.any_ptr);
15048     SP -= items;
15049     assert(av);
15050 #ifndef DEBUGGING
15051     if (!av) {
15052         XSRETURN(0);
15053     }
15054 #endif
15055     if (SvRMAGICAL(av))
15056         Perl_croak(aTHX_ "Magical list constants are not supported");
15057     if (GIMME_V != G_LIST) {
15058         EXTEND(SP, 1);
15059         ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
15060         XSRETURN(1);
15061     }
15062     EXTEND(SP, AvFILLp(av)+1);
15063     Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
15064     XSRETURN(AvFILLp(av)+1);
15065 }
15066
15067 /* Copy an existing cop->cop_warnings field.
15068  * If it's one of the standard addresses, just re-use the address.
15069  * This is the e implementation for the DUP_WARNINGS() macro
15070  */
15071
15072 STRLEN*
15073 Perl_dup_warnings(pTHX_ STRLEN* warnings)
15074 {
15075     Size_t size;
15076     STRLEN *new_warnings;
15077
15078     if (warnings == NULL || specialWARN(warnings))
15079         return warnings;
15080
15081     size = sizeof(*warnings) + *warnings;
15082
15083     new_warnings = (STRLEN*)PerlMemShared_malloc(size);
15084     Copy(warnings, new_warnings, size, char);
15085     return new_warnings;
15086 }
15087
15088 /*
15089  * ex: set ts=8 sts=4 sw=4 et:
15090  */