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             /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1881             PERL_DIAG_WARN_SYNTAX(
1882                 "Scalar value @%" SVf "%c%s%c better written as $%" SVf "%c%s%c") :
1883             /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1884             PERL_DIAG_WARN_SYNTAX(
1885                 "%%%" SVf "%c%s%c in scalar context better written as $%" SVf "%c%s%c");
1886
1887         Perl_warner(aTHX_ packWARN(WARN_SYNTAX), msg,
1888                 SVfARG(name), lbrack, keypv, rbrack,
1889                 SVfARG(name), lbrack, keypv, rbrack);
1890     }
1891     else {
1892         msg = is_slice ?
1893             /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1894             PERL_DIAG_WARN_SYNTAX(
1895                 "Scalar value @%" SVf "%c%" SVf "%c better written as $%" SVf "%c%" SVf "%c") :
1896             /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1897             PERL_DIAG_WARN_SYNTAX(
1898                 "%%%" SVf "%c%" SVf "%c in scalar context better written as $%" SVf "%c%" SVf "%c");
1899
1900         Perl_warner(aTHX_ packWARN(WARN_SYNTAX), msg,
1901                 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1902                 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1903     }
1904 }
1905
1906
1907 /* apply scalar context to the o subtree */
1908
1909 OP *
1910 Perl_scalar(pTHX_ OP *o)
1911 {
1912     OP * top_op = o;
1913
1914     while (1) {
1915         OP *next_kid = NULL; /* what op (if any) to process next */
1916         OP *kid;
1917
1918         /* assumes no premature commitment */
1919         if (!o || (PL_parser && PL_parser->error_count)
1920              || (o->op_flags & OPf_WANT)
1921              || o->op_type == OP_RETURN)
1922         {
1923             goto do_next;
1924         }
1925
1926         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1927
1928         switch (o->op_type) {
1929         case OP_REPEAT:
1930             scalar(cBINOPo->op_first);
1931             /* convert what initially looked like a list repeat into a
1932              * scalar repeat, e.g. $s = (1) x $n
1933              */
1934             if (o->op_private & OPpREPEAT_DOLIST) {
1935                 kid = cLISTOPx(cUNOPo->op_first)->op_first;
1936                 assert(kid->op_type == OP_PUSHMARK);
1937                 if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1938                     op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1939                     o->op_private &=~ OPpREPEAT_DOLIST;
1940                 }
1941             }
1942             break;
1943
1944         case OP_OR:
1945         case OP_AND:
1946         case OP_COND_EXPR:
1947             /* impose scalar context on everything except the condition */
1948             next_kid = OpSIBLING(cUNOPo->op_first);
1949             break;
1950
1951         default:
1952             if (o->op_flags & OPf_KIDS)
1953                 next_kid = cUNOPo->op_first; /* do all kids */
1954             break;
1955
1956         /* the children of these ops are usually a list of statements,
1957          * except the leaves, whose first child is a corresponding enter
1958          */
1959         case OP_SCOPE:
1960         case OP_LINESEQ:
1961         case OP_LIST:
1962             kid = cLISTOPo->op_first;
1963             goto do_kids;
1964         case OP_LEAVE:
1965         case OP_LEAVETRY:
1966             kid = cLISTOPo->op_first;
1967             scalar(kid);
1968             kid = OpSIBLING(kid);
1969         do_kids:
1970             while (kid) {
1971                 OP *sib = OpSIBLING(kid);
1972                 /* Apply void context to all kids except the last, which
1973                  * is scalar (ignoring a trailing ex-nextstate in determining
1974                  * if it's the last kid). E.g.
1975                  *      $scalar = do { void; void; scalar }
1976                  * Except that 'when's are always scalar, e.g.
1977                  *      $scalar = do { given(..) {
1978                     *                 when (..) { scalar }
1979                     *                 when (..) { scalar }
1980                     *                 ...
1981                     *                }}
1982                     */
1983                 if (!sib
1984                      || (  !OpHAS_SIBLING(sib)
1985                          && sib->op_type == OP_NULL
1986                          && (   sib->op_targ == OP_NEXTSTATE
1987                              || sib->op_targ == OP_DBSTATE  )
1988                         )
1989                 )
1990                 {
1991                     /* tail call optimise calling scalar() on the last kid */
1992                     next_kid = kid;
1993                     goto do_next;
1994                 }
1995                 else if (kid->op_type == OP_LEAVEWHEN)
1996                     scalar(kid);
1997                 else
1998                     scalarvoid(kid);
1999                 kid = sib;
2000             }
2001             NOT_REACHED; /* NOTREACHED */
2002             break;
2003
2004         case OP_SORT:
2005             Perl_ck_warner(aTHX_ packWARN(WARN_SCALAR), "Useless use of %s in scalar context", "sort");
2006             break;
2007
2008         case OP_KVHSLICE:
2009         case OP_KVASLICE:
2010         {
2011             /* Warn about scalar context */
2012             SV *name;
2013
2014             /* This warning can be nonsensical when there is a syntax error. */
2015             if (PL_parser && PL_parser->error_count)
2016                 break;
2017
2018             if (!ckWARN(WARN_SYNTAX)) break;
2019
2020             kid = cLISTOPo->op_first;
2021             kid = OpSIBLING(kid); /* get past pushmark */
2022             assert(OpSIBLING(kid));
2023             name = op_varname(OpSIBLING(kid));
2024             if (!name) /* XS module fiddling with the op tree */
2025                 break;
2026             warn_elem_scalar_context(kid, name, o->op_type == OP_KVHSLICE, false);
2027         }
2028         } /* switch */
2029
2030         /* If next_kid is set, someone in the code above wanted us to process
2031          * that kid and all its remaining siblings.  Otherwise, work our way
2032          * back up the tree */
2033       do_next:
2034         while (!next_kid) {
2035             if (o == top_op)
2036                 return top_op; /* at top; no parents/siblings to try */
2037             if (OpHAS_SIBLING(o))
2038                 next_kid = o->op_sibparent;
2039             else {
2040                 o = o->op_sibparent; /*try parent's next sibling */
2041                 switch (o->op_type) {
2042                 case OP_SCOPE:
2043                 case OP_LINESEQ:
2044                 case OP_LIST:
2045                 case OP_LEAVE:
2046                 case OP_LEAVETRY:
2047                     /* should really restore PL_curcop to its old value, but
2048                      * setting it to PL_compiling is better than do nothing */
2049                     PL_curcop = &PL_compiling;
2050                 }
2051             }
2052         }
2053         o = next_kid;
2054     } /* while */
2055 }
2056
2057
2058 /* apply void context to the optree arg */
2059
2060 OP *
2061 Perl_scalarvoid(pTHX_ OP *arg)
2062 {
2063     OP *kid;
2064     SV* sv;
2065     OP *o = arg;
2066
2067     PERL_ARGS_ASSERT_SCALARVOID;
2068
2069     while (1) {
2070         U8 want;
2071         SV *useless_sv = NULL;
2072         const char* useless = NULL;
2073         OP * next_kid = NULL;
2074
2075         if (o->op_type == OP_NEXTSTATE
2076             || o->op_type == OP_DBSTATE
2077             || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
2078                                           || o->op_targ == OP_DBSTATE)))
2079             PL_curcop = (COP*)o;                /* for warning below */
2080
2081         /* assumes no premature commitment */
2082         want = o->op_flags & OPf_WANT;
2083         if ((want && want != OPf_WANT_SCALAR)
2084             || (PL_parser && PL_parser->error_count)
2085             || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
2086         {
2087             goto get_next_op;
2088         }
2089
2090         if ((o->op_private & OPpTARGET_MY)
2091             && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2092         {
2093             /* newASSIGNOP has already applied scalar context, which we
2094                leave, as if this op is inside SASSIGN.  */
2095             goto get_next_op;
2096         }
2097
2098         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
2099
2100         switch (o->op_type) {
2101         default:
2102             if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
2103                 break;
2104             /* FALLTHROUGH */
2105         case OP_REPEAT:
2106             if (o->op_flags & OPf_STACKED)
2107                 break;
2108             if (o->op_type == OP_REPEAT)
2109                 scalar(cBINOPo->op_first);
2110             goto func_ops;
2111         case OP_CONCAT:
2112             if ((o->op_flags & OPf_STACKED) &&
2113                     !(o->op_private & OPpCONCAT_NESTED))
2114                 break;
2115             goto func_ops;
2116         case OP_SUBSTR:
2117             if (o->op_private == 4)
2118                 break;
2119             /* FALLTHROUGH */
2120         case OP_WANTARRAY:
2121         case OP_GV:
2122         case OP_SMARTMATCH:
2123         case OP_AV2ARYLEN:
2124         case OP_REF:
2125         case OP_REFGEN:
2126         case OP_SREFGEN:
2127         case OP_DEFINED:
2128         case OP_HEX:
2129         case OP_OCT:
2130         case OP_LENGTH:
2131         case OP_VEC:
2132         case OP_INDEX:
2133         case OP_RINDEX:
2134         case OP_SPRINTF:
2135         case OP_KVASLICE:
2136         case OP_KVHSLICE:
2137         case OP_UNPACK:
2138         case OP_PACK:
2139         case OP_JOIN:
2140         case OP_LSLICE:
2141         case OP_ANONLIST:
2142         case OP_ANONHASH:
2143         case OP_SORT:
2144         case OP_REVERSE:
2145         case OP_RANGE:
2146         case OP_FLIP:
2147         case OP_FLOP:
2148         case OP_CALLER:
2149         case OP_FILENO:
2150         case OP_EOF:
2151         case OP_TELL:
2152         case OP_GETSOCKNAME:
2153         case OP_GETPEERNAME:
2154         case OP_READLINK:
2155         case OP_TELLDIR:
2156         case OP_GETPPID:
2157         case OP_GETPGRP:
2158         case OP_GETPRIORITY:
2159         case OP_TIME:
2160         case OP_TMS:
2161         case OP_LOCALTIME:
2162         case OP_GMTIME:
2163         case OP_GHBYNAME:
2164         case OP_GHBYADDR:
2165         case OP_GHOSTENT:
2166         case OP_GNBYNAME:
2167         case OP_GNBYADDR:
2168         case OP_GNETENT:
2169         case OP_GPBYNAME:
2170         case OP_GPBYNUMBER:
2171         case OP_GPROTOENT:
2172         case OP_GSBYNAME:
2173         case OP_GSBYPORT:
2174         case OP_GSERVENT:
2175         case OP_GPWNAM:
2176         case OP_GPWUID:
2177         case OP_GGRNAM:
2178         case OP_GGRGID:
2179         case OP_GETLOGIN:
2180         case OP_PROTOTYPE:
2181         case OP_RUNCV:
2182         func_ops:
2183             useless = OP_DESC(o);
2184             break;
2185
2186         case OP_GVSV:
2187         case OP_PADSV:
2188         case OP_PADAV:
2189         case OP_PADHV:
2190         case OP_PADANY:
2191         case OP_AELEM:
2192         case OP_AELEMFAST:
2193         case OP_AELEMFAST_LEX:
2194         case OP_ASLICE:
2195         case OP_HELEM:
2196         case OP_HSLICE:
2197             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
2198                 /* Otherwise it's "Useless use of grep iterator" */
2199                 useless = OP_DESC(o);
2200             break;
2201
2202         case OP_SPLIT:
2203             if (!(o->op_private & OPpSPLIT_ASSIGN))
2204                 useless = OP_DESC(o);
2205             break;
2206
2207         case OP_NOT:
2208             kid = cUNOPo->op_first;
2209             if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2210                 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2211                 goto func_ops;
2212             }
2213             useless = "negative pattern binding (!~)";
2214             break;
2215
2216         case OP_SUBST:
2217             if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2218                 useless = "non-destructive substitution (s///r)";
2219             break;
2220
2221         case OP_TRANSR:
2222             useless = "non-destructive transliteration (tr///r)";
2223             break;
2224
2225         case OP_RV2GV:
2226         case OP_RV2SV:
2227         case OP_RV2AV:
2228         case OP_RV2HV:
2229             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
2230                 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
2231                 useless = "a variable";
2232             break;
2233
2234         case OP_CONST:
2235             sv = cSVOPo_sv;
2236             if (cSVOPo->op_private & OPpCONST_STRICT)
2237                 no_bareword_allowed(o);
2238             else {
2239                 if (ckWARN(WARN_VOID)) {
2240                     NV nv;
2241                     /* don't warn on optimised away booleans, eg
2242                      * use constant Foo, 5; Foo || print; */
2243                     if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2244                         useless = NULL;
2245                     /* the constants 0 and 1 are permitted as they are
2246                        conventionally used as dummies in constructs like
2247                        1 while some_condition_with_side_effects;  */
2248                     else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2249                         useless = NULL;
2250                     else if (SvPOK(sv)) {
2251                         SV * const dsv = newSVpvs("");
2252                         useless_sv
2253                             = Perl_newSVpvf(aTHX_
2254                                             "a constant (%s)",
2255                                             pv_pretty(dsv, SvPVX_const(sv),
2256                                                       SvCUR(sv), 32, NULL, NULL,
2257                                                       PERL_PV_PRETTY_DUMP
2258                                                       | PERL_PV_ESCAPE_NOCLEAR
2259                                                       | PERL_PV_ESCAPE_UNI_DETECT));
2260                         SvREFCNT_dec_NN(dsv);
2261                     }
2262                     else if (SvOK(sv)) {
2263                         useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv));
2264                     }
2265                     else
2266                         useless = "a constant (undef)";
2267                 }
2268             }
2269             op_null(o);         /* don't execute or even remember it */
2270             break;
2271
2272         case OP_POSTINC:
2273             OpTYPE_set(o, OP_PREINC);  /* pre-increment is faster */
2274             break;
2275
2276         case OP_POSTDEC:
2277             OpTYPE_set(o, OP_PREDEC);  /* pre-decrement is faster */
2278             break;
2279
2280         case OP_I_POSTINC:
2281             OpTYPE_set(o, OP_I_PREINC);        /* pre-increment is faster */
2282             break;
2283
2284         case OP_I_POSTDEC:
2285             OpTYPE_set(o, OP_I_PREDEC);        /* pre-decrement is faster */
2286             break;
2287
2288         case OP_SASSIGN: {
2289             OP *rv2gv;
2290             UNOP *refgen, *rv2cv;
2291             LISTOP *exlist;
2292
2293             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2294                 break;
2295
2296             rv2gv = cBINOPo->op_last;
2297             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2298                 break;
2299
2300             refgen = cUNOPx(cBINOPo->op_first);
2301
2302             if (!refgen || (refgen->op_type != OP_REFGEN
2303                             && refgen->op_type != OP_SREFGEN))
2304                 break;
2305
2306             exlist = cLISTOPx(refgen->op_first);
2307             if (!exlist || exlist->op_type != OP_NULL
2308                 || exlist->op_targ != OP_LIST)
2309                 break;
2310
2311             if (exlist->op_first->op_type != OP_PUSHMARK
2312                 && exlist->op_first != exlist->op_last)
2313                 break;
2314
2315             rv2cv = cUNOPx(exlist->op_last);
2316
2317             if (rv2cv->op_type != OP_RV2CV)
2318                 break;
2319
2320             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2321             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2322             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2323
2324             o->op_private |= OPpASSIGN_CV_TO_GV;
2325             rv2gv->op_private |= OPpDONT_INIT_GV;
2326             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2327
2328             break;
2329         }
2330
2331         case OP_AASSIGN: {
2332             inplace_aassign(o);
2333             break;
2334         }
2335
2336         case OP_OR:
2337         case OP_AND:
2338             kid = cLOGOPo->op_first;
2339             if (kid->op_type == OP_NOT
2340                 && (kid->op_flags & OPf_KIDS)) {
2341                 if (o->op_type == OP_AND) {
2342                     OpTYPE_set(o, OP_OR);
2343                 } else {
2344                     OpTYPE_set(o, OP_AND);
2345                 }
2346                 op_null(kid);
2347             }
2348             /* FALLTHROUGH */
2349
2350         case OP_DOR:
2351         case OP_COND_EXPR:
2352         case OP_ENTERGIVEN:
2353         case OP_ENTERWHEN:
2354             next_kid = OpSIBLING(cUNOPo->op_first);
2355         break;
2356
2357         case OP_NULL:
2358             if (o->op_flags & OPf_STACKED)
2359                 break;
2360             /* FALLTHROUGH */
2361         case OP_NEXTSTATE:
2362         case OP_DBSTATE:
2363         case OP_ENTERTRY:
2364         case OP_ENTER:
2365             if (!(o->op_flags & OPf_KIDS))
2366                 break;
2367             /* FALLTHROUGH */
2368         case OP_SCOPE:
2369         case OP_LEAVE:
2370         case OP_LEAVETRY:
2371         case OP_LEAVELOOP:
2372         case OP_LINESEQ:
2373         case OP_LEAVEGIVEN:
2374         case OP_LEAVEWHEN:
2375         kids:
2376             next_kid = cLISTOPo->op_first;
2377             break;
2378         case OP_LIST:
2379             /* If the first kid after pushmark is something that the padrange
2380                optimisation would reject, then null the list and the pushmark.
2381             */
2382             if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2383                 && (  !(kid = OpSIBLING(kid))
2384                       || (  kid->op_type != OP_PADSV
2385                             && kid->op_type != OP_PADAV
2386                             && kid->op_type != OP_PADHV)
2387                       || kid->op_private & ~OPpLVAL_INTRO
2388                       || !(kid = OpSIBLING(kid))
2389                       || (  kid->op_type != OP_PADSV
2390                             && kid->op_type != OP_PADAV
2391                             && kid->op_type != OP_PADHV)
2392                       || kid->op_private & ~OPpLVAL_INTRO)
2393             ) {
2394                 op_null(cUNOPo->op_first); /* NULL the pushmark */
2395                 op_null(o); /* NULL the list */
2396             }
2397             goto kids;
2398         case OP_ENTEREVAL:
2399             scalarkids(o);
2400             break;
2401         case OP_SCALAR:
2402             scalar(o);
2403             break;
2404         }
2405
2406         if (useless_sv) {
2407             /* mortalise it, in case warnings are fatal.  */
2408             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2409                            "Useless use of %" SVf " in void context",
2410                            SVfARG(sv_2mortal(useless_sv)));
2411         }
2412         else if (useless) {
2413             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2414                            "Useless use of %s in void context",
2415                            useless);
2416         }
2417
2418       get_next_op:
2419         /* if a kid hasn't been nominated to process, continue with the
2420          * next sibling, or if no siblings left, go back to the parent's
2421          * siblings and so on
2422          */
2423         while (!next_kid) {
2424             if (o == arg)
2425                 return arg; /* at top; no parents/siblings to try */
2426             if (OpHAS_SIBLING(o))
2427                 next_kid = o->op_sibparent;
2428             else
2429                 o = o->op_sibparent; /*try parent's next sibling */
2430         }
2431         o = next_kid;
2432     }
2433
2434     return arg;
2435 }
2436
2437
2438 static OP *
2439 S_listkids(pTHX_ OP *o)
2440 {
2441     if (o && o->op_flags & OPf_KIDS) {
2442         OP *kid;
2443         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2444             list(kid);
2445     }
2446     return o;
2447 }
2448
2449
2450 /* apply list context to the o subtree */
2451
2452 OP *
2453 Perl_list(pTHX_ OP *o)
2454 {
2455     OP * top_op = o;
2456
2457     while (1) {
2458         OP *next_kid = NULL; /* what op (if any) to process next */
2459
2460         OP *kid;
2461
2462         /* assumes no premature commitment */
2463         if (!o || (o->op_flags & OPf_WANT)
2464              || (PL_parser && PL_parser->error_count)
2465              || o->op_type == OP_RETURN)
2466         {
2467             goto do_next;
2468         }
2469
2470         if ((o->op_private & OPpTARGET_MY)
2471             && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2472         {
2473             goto do_next;                               /* As if inside SASSIGN */
2474         }
2475
2476         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2477
2478         switch (o->op_type) {
2479         case OP_REPEAT:
2480             if (o->op_private & OPpREPEAT_DOLIST
2481              && !(o->op_flags & OPf_STACKED))
2482             {
2483                 list(cBINOPo->op_first);
2484                 kid = cBINOPo->op_last;
2485                 /* optimise away (.....) x 1 */
2486                 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2487                  && SvIVX(kSVOP_sv) == 1)
2488                 {
2489                     op_null(o); /* repeat */
2490                     op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2491                     /* const (rhs): */
2492                     op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2493                 }
2494             }
2495             break;
2496
2497         case OP_OR:
2498         case OP_AND:
2499         case OP_COND_EXPR:
2500             /* impose list context on everything except the condition */
2501             next_kid = OpSIBLING(cUNOPo->op_first);
2502             break;
2503
2504         default:
2505             if (!(o->op_flags & OPf_KIDS))
2506                 break;
2507             /* possibly flatten 1..10 into a constant array */
2508             if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2509                 list(cBINOPo->op_first);
2510                 gen_constant_list(o);
2511                 goto do_next;
2512             }
2513             next_kid = cUNOPo->op_first; /* do all kids */
2514             break;
2515
2516         case OP_LIST:
2517             if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2518                 op_null(cUNOPo->op_first); /* NULL the pushmark */
2519                 op_null(o); /* NULL the list */
2520             }
2521             if (o->op_flags & OPf_KIDS)
2522                 next_kid = cUNOPo->op_first; /* do all kids */
2523             break;
2524
2525         /* the children of these ops are usually a list of statements,
2526          * except the leaves, whose first child is a corresponding enter
2527          */
2528         case OP_SCOPE:
2529         case OP_LINESEQ:
2530             kid = cLISTOPo->op_first;
2531             goto do_kids;
2532         case OP_LEAVE:
2533         case OP_LEAVETRY:
2534             kid = cLISTOPo->op_first;
2535             list(kid);
2536             kid = OpSIBLING(kid);
2537         do_kids:
2538             while (kid) {
2539                 OP *sib = OpSIBLING(kid);
2540                 /* Apply void context to all kids except the last, which
2541                  * is list. E.g.
2542                  *      @a = do { void; void; list }
2543                  * Except that 'when's are always list context, e.g.
2544                  *      @a = do { given(..) {
2545                     *                 when (..) { list }
2546                     *                 when (..) { list }
2547                     *                 ...
2548                     *                }}
2549                     */
2550                 if (!sib) {
2551                     /* tail call optimise calling list() on the last kid */
2552                     next_kid = kid;
2553                     goto do_next;
2554                 }
2555                 else if (kid->op_type == OP_LEAVEWHEN)
2556                     list(kid);
2557                 else
2558                     scalarvoid(kid);
2559                 kid = sib;
2560             }
2561             NOT_REACHED; /* NOTREACHED */
2562             break;
2563
2564         }
2565
2566         /* If next_kid is set, someone in the code above wanted us to process
2567          * that kid and all its remaining siblings.  Otherwise, work our way
2568          * back up the tree */
2569       do_next:
2570         while (!next_kid) {
2571             if (o == top_op)
2572                 return top_op; /* at top; no parents/siblings to try */
2573             if (OpHAS_SIBLING(o))
2574                 next_kid = o->op_sibparent;
2575             else {
2576                 o = o->op_sibparent; /*try parent's next sibling */
2577                 switch (o->op_type) {
2578                 case OP_SCOPE:
2579                 case OP_LINESEQ:
2580                 case OP_LIST:
2581                 case OP_LEAVE:
2582                 case OP_LEAVETRY:
2583                     /* should really restore PL_curcop to its old value, but
2584                      * setting it to PL_compiling is better than do nothing */
2585                     PL_curcop = &PL_compiling;
2586                 }
2587             }
2588
2589
2590         }
2591         o = next_kid;
2592     } /* while */
2593 }
2594
2595 /* apply void context to non-final ops of a sequence */
2596
2597 static OP *
2598 S_voidnonfinal(pTHX_ OP *o)
2599 {
2600     if (o) {
2601         const OPCODE type = o->op_type;
2602
2603         if (type == OP_LINESEQ || type == OP_SCOPE ||
2604             type == OP_LEAVE || type == OP_LEAVETRY)
2605         {
2606             OP *kid = cLISTOPo->op_first, *sib;
2607             if(type == OP_LEAVE) {
2608                 /* Don't put the OP_ENTER in void context */
2609                 assert(kid->op_type == OP_ENTER);
2610                 kid = OpSIBLING(kid);
2611             }
2612             for (; kid; kid = sib) {
2613                 if ((sib = OpSIBLING(kid))
2614                  && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2615                     || (  sib->op_targ != OP_NEXTSTATE
2616                        && sib->op_targ != OP_DBSTATE  )))
2617                 {
2618                     scalarvoid(kid);
2619                 }
2620             }
2621             PL_curcop = &PL_compiling;
2622         }
2623         o->op_flags &= ~OPf_PARENS;
2624         if (PL_hints & HINT_BLOCK_SCOPE)
2625             o->op_flags |= OPf_PARENS;
2626     }
2627     else
2628         o = newOP(OP_STUB, 0);
2629     return o;
2630 }
2631
2632 STATIC OP *
2633 S_modkids(pTHX_ OP *o, I32 type)
2634 {
2635     if (o && o->op_flags & OPf_KIDS) {
2636         OP *kid;
2637         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2638             op_lvalue(kid, type);
2639     }
2640     return o;
2641 }
2642
2643
2644 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2645  * const fields. Also, convert CONST keys to HEK-in-SVs.
2646  * rop    is the op that retrieves the hash;
2647  * key_op is the first key
2648  * real   if false, only check (and possibly croak); don't update op
2649  */
2650
2651 void
2652 Perl_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op, int real)
2653 {
2654     PADNAME *lexname;
2655     GV **fields;
2656     bool check_fields;
2657
2658     /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2659     if (rop) {
2660         if (rop->op_first->op_type == OP_PADSV)
2661             /* @$hash{qw(keys here)} */
2662             rop = cUNOPx(rop->op_first);
2663         else {
2664             /* @{$hash}{qw(keys here)} */
2665             if (rop->op_first->op_type == OP_SCOPE
2666                 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2667                 {
2668                     rop = cUNOPx(cLISTOPx(rop->op_first)->op_last);
2669                 }
2670             else
2671                 rop = NULL;
2672         }
2673     }
2674
2675     lexname = NULL; /* just to silence compiler warnings */
2676     fields  = NULL; /* just to silence compiler warnings */
2677
2678     check_fields =
2679             rop
2680          && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2681              PadnameHasTYPE(lexname))
2682          && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2683          && isGV(*fields) && GvHV(*fields);
2684
2685     for (; key_op; key_op = cSVOPx(OpSIBLING(key_op))) {
2686         SV **svp, *sv;
2687         if (key_op->op_type != OP_CONST)
2688             continue;
2689         svp = cSVOPx_svp(key_op);
2690
2691         /* make sure it's not a bareword under strict subs */
2692         if (key_op->op_private & OPpCONST_BARE &&
2693             key_op->op_private & OPpCONST_STRICT)
2694         {
2695             no_bareword_allowed((OP*)key_op);
2696         }
2697
2698         /* Make the CONST have a shared SV */
2699         if (   !SvIsCOW_shared_hash(sv = *svp)
2700             && SvTYPE(sv) < SVt_PVMG
2701             && SvOK(sv)
2702             && !SvROK(sv)
2703             && real)
2704         {
2705             SSize_t keylen;
2706             const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2707             SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2708             SvREFCNT_dec_NN(sv);
2709             *svp = nsv;
2710         }
2711
2712         if (   check_fields
2713             && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2714         {
2715             Perl_croak(aTHX_ "No such class field \"%" SVf "\" "
2716                         "in variable %" PNf " of type %" HEKf,
2717                         SVfARG(*svp), PNfARG(lexname),
2718                         HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2719         }
2720     }
2721 }
2722
2723
2724 /* do all the final processing on an optree (e.g. running the peephole
2725  * optimiser on it), then attach it to cv (if cv is non-null)
2726  */
2727
2728 static void
2729 S_process_optree(pTHX_ CV *cv, OP *optree, OP* start)
2730 {
2731     OP **startp;
2732
2733     /* XXX for some reason, evals, require and main optrees are
2734      * never attached to their CV; instead they just hang off
2735      * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start
2736      * and get manually freed when appropriate */
2737     if (cv)
2738         startp = &CvSTART(cv);
2739     else
2740         startp = PL_in_eval? &PL_eval_start : &PL_main_start;
2741
2742     *startp = start;
2743     optree->op_private |= OPpREFCOUNTED;
2744     OpREFCNT_set(optree, 1);
2745     optimize_optree(optree);
2746     CALL_PEEP(*startp);
2747     finalize_optree(optree);
2748     op_prune_chain_head(startp);
2749
2750     if (cv) {
2751         /* now that optimizer has done its work, adjust pad values */
2752         pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT
2753                  : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
2754     }
2755 }
2756
2757 #ifdef USE_ITHREADS
2758 /* Relocate sv to the pad for thread safety.
2759  * Despite being a "constant", the SV is written to,
2760  * for reference counts, sv_upgrade() etc. */
2761 void
2762 Perl_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
2763 {
2764     PADOFFSET ix;
2765     PERL_ARGS_ASSERT_OP_RELOCATE_SV;
2766     if (!*svp) return;
2767     ix = pad_alloc(OP_CONST, SVf_READONLY);
2768     SvREFCNT_dec(PAD_SVl(ix));
2769     PAD_SETSV(ix, *svp);
2770     /* XXX I don't know how this isn't readonly already. */
2771     if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
2772     *svp = NULL;
2773     *targp = ix;
2774 }
2775 #endif
2776
2777 static void
2778 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
2779 {
2780     CV *cv = PL_compcv;
2781     PadnameLVALUE_on(pn);
2782     while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
2783         cv = CvOUTSIDE(cv);
2784         /* RT #127786: cv can be NULL due to an eval within the DB package
2785          * called from an anon sub - anon subs don't have CvOUTSIDE() set
2786          * unless they contain an eval, but calling eval within DB
2787          * pretends the eval was done in the caller's scope.
2788          */
2789         if (!cv)
2790             break;
2791         assert(CvPADLIST(cv));
2792         pn =
2793            PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
2794         assert(PadnameLEN(pn));
2795         PadnameLVALUE_on(pn);
2796     }
2797 }
2798
2799 static bool
2800 S_vivifies(const OPCODE type)
2801 {
2802     switch(type) {
2803     case OP_RV2AV:     case   OP_ASLICE:
2804     case OP_RV2HV:     case OP_KVASLICE:
2805     case OP_RV2SV:     case   OP_HSLICE:
2806     case OP_AELEMFAST: case OP_KVHSLICE:
2807     case OP_HELEM:
2808     case OP_AELEM:
2809         return 1;
2810     }
2811     return 0;
2812 }
2813
2814
2815 /* apply lvalue reference (aliasing) context to the optree o.
2816  * E.g. in
2817  *     \($x,$y) = (...)
2818  * o would be the list ($x,$y) and type would be OP_AASSIGN.
2819  * It may descend and apply this to children too, for example in
2820  * \( $cond ? $x, $y) = (...)
2821  */
2822
2823 static void
2824 S_lvref(pTHX_ OP *o, I32 type)
2825 {
2826     OP *kid;
2827     OP * top_op = o;
2828
2829     while (1) {
2830         switch (o->op_type) {
2831         case OP_COND_EXPR:
2832             o = OpSIBLING(cUNOPo->op_first);
2833             continue;
2834
2835         case OP_PUSHMARK:
2836             goto do_next;
2837
2838         case OP_RV2AV:
2839             if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2840             o->op_flags |= OPf_STACKED;
2841             if (o->op_flags & OPf_PARENS) {
2842                 if (o->op_private & OPpLVAL_INTRO) {
2843                      yyerror(Perl_form(aTHX_ "Can't modify reference to "
2844                           "localized parenthesized array in list assignment"));
2845                     goto do_next;
2846                 }
2847               slurpy:
2848                 OpTYPE_set(o, OP_LVAVREF);
2849                 o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
2850                 o->op_flags |= OPf_MOD|OPf_REF;
2851                 goto do_next;
2852             }
2853             o->op_private |= OPpLVREF_AV;
2854             goto checkgv;
2855
2856         case OP_RV2CV:
2857             kid = cUNOPo->op_first;
2858             if (kid->op_type == OP_NULL)
2859                 kid = cUNOPx(OpSIBLING(kUNOP->op_first))
2860                     ->op_first;
2861             o->op_private = OPpLVREF_CV;
2862             if (kid->op_type == OP_GV)
2863                 o->op_flags |= OPf_STACKED;
2864             else if (kid->op_type == OP_PADCV) {
2865                 o->op_targ = kid->op_targ;
2866                 kid->op_targ = 0;
2867                 op_free(cUNOPo->op_first);
2868                 cUNOPo->op_first = NULL;
2869                 o->op_flags &=~ OPf_KIDS;
2870             }
2871             else goto badref;
2872             break;
2873
2874         case OP_RV2HV:
2875             if (o->op_flags & OPf_PARENS) {
2876               parenhash:
2877                 yyerror(Perl_form(aTHX_ "Can't modify reference to "
2878                                      "parenthesized hash in list assignment"));
2879                     goto do_next;
2880             }
2881             o->op_private |= OPpLVREF_HV;
2882             /* FALLTHROUGH */
2883         case OP_RV2SV:
2884           checkgv:
2885             if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2886             o->op_flags |= OPf_STACKED;
2887             break;
2888
2889         case OP_PADHV:
2890             if (o->op_flags & OPf_PARENS) goto parenhash;
2891             o->op_private |= OPpLVREF_HV;
2892             /* FALLTHROUGH */
2893         case OP_PADSV:
2894             PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2895             break;
2896
2897         case OP_PADAV:
2898             PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2899             if (o->op_flags & OPf_PARENS) goto slurpy;
2900             o->op_private |= OPpLVREF_AV;
2901             break;
2902
2903         case OP_AELEM:
2904         case OP_HELEM:
2905             o->op_private |= OPpLVREF_ELEM;
2906             o->op_flags   |= OPf_STACKED;
2907             break;
2908
2909         case OP_ASLICE:
2910         case OP_HSLICE:
2911             OpTYPE_set(o, OP_LVREFSLICE);
2912             o->op_private &= OPpLVAL_INTRO;
2913             goto do_next;
2914
2915         case OP_NULL:
2916             if (o->op_flags & OPf_SPECIAL)              /* do BLOCK */
2917                 goto badref;
2918             else if (!(o->op_flags & OPf_KIDS))
2919                 goto do_next;
2920
2921             /* the code formerly only recursed into the first child of
2922              * a non ex-list OP_NULL. if we ever encounter such a null op with
2923              * more than one child, need to decide whether its ok to process
2924              * *all* its kids or not */
2925             assert(o->op_targ == OP_LIST
2926                     || !(OpHAS_SIBLING(cBINOPo->op_first)));
2927             /* FALLTHROUGH */
2928         case OP_LIST:
2929             o = cLISTOPo->op_first;
2930             continue;
2931
2932         case OP_STUB:
2933             if (o->op_flags & OPf_PARENS)
2934                 goto do_next;
2935             /* FALLTHROUGH */
2936         default:
2937           badref:
2938             /* diag_listed_as: Can't modify reference to %s in %s assignment */
2939             yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
2940                          o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
2941                           ? "do block"
2942                           : OP_DESC(o),
2943                          PL_op_desc[type]));
2944             goto do_next;
2945         }
2946
2947         OpTYPE_set(o, OP_LVREF);
2948         o->op_private &=
2949             OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
2950         if (type == OP_ENTERLOOP)
2951             o->op_private |= OPpLVREF_ITER;
2952
2953       do_next:
2954         while (1) {
2955             if (o == top_op)
2956                 return; /* at top; no parents/siblings to try */
2957             if (OpHAS_SIBLING(o)) {
2958                 o = o->op_sibparent;
2959                 break;
2960             }
2961             o = o->op_sibparent; /*try parent's next sibling */
2962         }
2963     } /* while */
2964 }
2965
2966
2967 PERL_STATIC_INLINE bool
2968 S_potential_mod_type(I32 type)
2969 {
2970     /* Types that only potentially result in modification.  */
2971     return type == OP_GREPSTART || type == OP_ENTERSUB
2972         || type == OP_REFGEN    || type == OP_LEAVESUBLV;
2973 }
2974
2975
2976 /*
2977 =for apidoc op_lvalue
2978
2979 Propagate lvalue ("modifiable") context to an op and its children.
2980 C<type> represents the context type, roughly based on the type of op that
2981 would do the modifying, although C<local()> is represented by C<OP_NULL>,
2982 because it has no op type of its own (it is signalled by a flag on
2983 the lvalue op).
2984
2985 This function detects things that can't be modified, such as C<$x+1>, and
2986 generates errors for them.  For example, C<$x+1 = 2> would cause it to be
2987 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
2988
2989 It also flags things that need to behave specially in an lvalue context,
2990 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
2991
2992 =cut
2993
2994 Perl_op_lvalue_flags() is a non-API lower-level interface to
2995 op_lvalue().  The flags param has these bits:
2996     OP_LVALUE_NO_CROAK:  return rather than croaking on error
2997
2998 */
2999
3000 OP *
3001 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
3002 {
3003     OP *top_op = o;
3004
3005     if (!o || (PL_parser && PL_parser->error_count))
3006         return o;
3007
3008     while (1) {
3009     OP *kid;
3010     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
3011     int localize = -1;
3012     OP *next_kid = NULL;
3013
3014     if ((o->op_private & OPpTARGET_MY)
3015         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
3016     {
3017         goto do_next;
3018     }
3019
3020     /* elements of a list might be in void context because the list is
3021        in scalar context or because they are attribute sub calls */
3022     if ((o->op_flags & OPf_WANT) == OPf_WANT_VOID)
3023         goto do_next;
3024
3025     if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
3026
3027     switch (o->op_type) {
3028     case OP_UNDEF:
3029         if (type == OP_SASSIGN)
3030             goto nomod;
3031         PL_modcount++;
3032         goto do_next;
3033
3034     case OP_STUB:
3035         if ((o->op_flags & OPf_PARENS))
3036             break;
3037         goto nomod;
3038
3039     case OP_ENTERSUB:
3040         if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
3041             !(o->op_flags & OPf_STACKED)) {
3042             OpTYPE_set(o, OP_RV2CV);            /* entersub => rv2cv */
3043             assert(cUNOPo->op_first->op_type == OP_NULL);
3044             op_null(cLISTOPx(cUNOPo->op_first)->op_first);/* disable pushmark */
3045             break;
3046         }
3047         else {                          /* lvalue subroutine call */
3048             o->op_private |= OPpLVAL_INTRO;
3049             PL_modcount = RETURN_UNLIMITED_NUMBER;
3050             if (S_potential_mod_type(type)) {
3051                 o->op_private |= OPpENTERSUB_INARGS;
3052                 break;
3053             }
3054             else {                      /* Compile-time error message: */
3055                 OP *kid = cUNOPo->op_first;
3056                 CV *cv;
3057                 GV *gv;
3058                 SV *namesv;
3059
3060                 if (kid->op_type != OP_PUSHMARK) {
3061                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
3062                         Perl_croak(aTHX_
3063                                 "panic: unexpected lvalue entersub "
3064                                 "args: type/targ %ld:%" UVuf,
3065                                 (long)kid->op_type, (UV)kid->op_targ);
3066                     kid = kLISTOP->op_first;
3067                 }
3068                 while (OpHAS_SIBLING(kid))
3069                     kid = OpSIBLING(kid);
3070                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
3071                     break;      /* Postpone until runtime */
3072                 }
3073
3074                 kid = kUNOP->op_first;
3075                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
3076                     kid = kUNOP->op_first;
3077                 if (kid->op_type == OP_NULL)
3078                     Perl_croak(aTHX_
3079                                "panic: unexpected constant lvalue entersub "
3080                                "entry via type/targ %ld:%" UVuf,
3081                                (long)kid->op_type, (UV)kid->op_targ);
3082                 if (kid->op_type != OP_GV) {
3083                     break;
3084                 }
3085
3086                 gv = kGVOP_gv;
3087                 cv = isGV(gv)
3088                     ? GvCV(gv)
3089                     : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
3090                         ? MUTABLE_CV(SvRV(gv))
3091                         : NULL;
3092                 if (!cv)
3093                     break;
3094                 if (CvLVALUE(cv))
3095                     break;
3096                 if (flags & OP_LVALUE_NO_CROAK)
3097                     return NULL;
3098
3099                 namesv = cv_name(cv, NULL, 0);
3100                 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
3101                                      "subroutine call of &%" SVf " in %s",
3102                                      SVfARG(namesv), PL_op_desc[type]),
3103                            SvUTF8(namesv));
3104                 goto do_next;
3105             }
3106         }
3107         /* FALLTHROUGH */
3108     default:
3109       nomod:
3110         if (flags & OP_LVALUE_NO_CROAK) return NULL;
3111         /* grep, foreach, subcalls, refgen */
3112         if (S_potential_mod_type(type))
3113             break;
3114         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
3115                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
3116                       ? "do block"
3117                       : OP_DESC(o)),
3118                      type ? PL_op_desc[type] : "local"));
3119         goto do_next;
3120
3121     case OP_PREINC:
3122     case OP_PREDEC:
3123     case OP_POW:
3124     case OP_MULTIPLY:
3125     case OP_DIVIDE:
3126     case OP_MODULO:
3127     case OP_ADD:
3128     case OP_SUBTRACT:
3129     case OP_CONCAT:
3130     case OP_LEFT_SHIFT:
3131     case OP_RIGHT_SHIFT:
3132     case OP_BIT_AND:
3133     case OP_BIT_XOR:
3134     case OP_BIT_OR:
3135     case OP_I_MULTIPLY:
3136     case OP_I_DIVIDE:
3137     case OP_I_MODULO:
3138     case OP_I_ADD:
3139     case OP_I_SUBTRACT:
3140         if (!(o->op_flags & OPf_STACKED))
3141             goto nomod;
3142         PL_modcount++;
3143         break;
3144
3145     case OP_REPEAT:
3146         if (o->op_flags & OPf_STACKED) {
3147             PL_modcount++;
3148             break;
3149         }
3150         if (!(o->op_private & OPpREPEAT_DOLIST))
3151             goto nomod;
3152         else {
3153             const I32 mods = PL_modcount;
3154             /* we recurse rather than iterate here because we need to
3155              * calculate and use the delta applied to PL_modcount by the
3156              * first child. So in something like
3157              *     ($x, ($y) x 3) = split;
3158              * split knows that 4 elements are wanted
3159              */
3160             modkids(cBINOPo->op_first, type);
3161             if (type != OP_AASSIGN)
3162                 goto nomod;
3163             kid = cBINOPo->op_last;
3164             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
3165                 const IV iv = SvIV(kSVOP_sv);
3166                 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
3167                     PL_modcount =
3168                         mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
3169             }
3170             else
3171                 PL_modcount = RETURN_UNLIMITED_NUMBER;
3172         }
3173         break;
3174
3175     case OP_COND_EXPR:
3176         localize = 1;
3177         next_kid = OpSIBLING(cUNOPo->op_first);
3178         break;
3179
3180     case OP_RV2AV:
3181     case OP_RV2HV:
3182         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
3183            PL_modcount = RETURN_UNLIMITED_NUMBER;
3184            /* Treat \(@foo) like ordinary list, but still mark it as modi-
3185               fiable since some contexts need to know.  */
3186            o->op_flags |= OPf_MOD;
3187            goto do_next;
3188         }
3189         /* FALLTHROUGH */
3190     case OP_RV2GV:
3191         if (scalar_mod_type(o, type))
3192             goto nomod;
3193         ref(cUNOPo->op_first, o->op_type);
3194         /* FALLTHROUGH */
3195     case OP_ASLICE:
3196     case OP_HSLICE:
3197         localize = 1;
3198         /* FALLTHROUGH */
3199     case OP_AASSIGN:
3200         /* Do not apply the lvsub flag for rv2[ah]v in scalar context.  */
3201         if (type == OP_LEAVESUBLV && (
3202                 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
3203              || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
3204            ))
3205             o->op_private |= OPpMAYBE_LVSUB;
3206         /* FALLTHROUGH */
3207     case OP_NEXTSTATE:
3208     case OP_DBSTATE:
3209        PL_modcount = RETURN_UNLIMITED_NUMBER;
3210         break;
3211
3212     case OP_KVHSLICE:
3213     case OP_KVASLICE:
3214     case OP_AKEYS:
3215         if (type == OP_LEAVESUBLV)
3216             o->op_private |= OPpMAYBE_LVSUB;
3217         goto nomod;
3218
3219     case OP_AVHVSWITCH:
3220         if (type == OP_LEAVESUBLV
3221          && (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS)
3222             o->op_private |= OPpMAYBE_LVSUB;
3223         goto nomod;
3224
3225     case OP_AV2ARYLEN:
3226         PL_hints |= HINT_BLOCK_SCOPE;
3227         if (type == OP_LEAVESUBLV)
3228             o->op_private |= OPpMAYBE_LVSUB;
3229         PL_modcount++;
3230         break;
3231
3232     case OP_RV2SV:
3233         ref(cUNOPo->op_first, o->op_type);
3234         localize = 1;
3235         /* FALLTHROUGH */
3236     case OP_GV:
3237         PL_hints |= HINT_BLOCK_SCOPE;
3238         /* FALLTHROUGH */
3239     case OP_SASSIGN:
3240     case OP_ANDASSIGN:
3241     case OP_ORASSIGN:
3242     case OP_DORASSIGN:
3243         PL_modcount++;
3244         break;
3245
3246     case OP_AELEMFAST:
3247     case OP_AELEMFAST_LEX:
3248         localize = -1;
3249         PL_modcount++;
3250         break;
3251
3252     case OP_PADAV:
3253     case OP_PADHV:
3254        PL_modcount = RETURN_UNLIMITED_NUMBER;
3255         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
3256         {
3257            /* Treat \(@foo) like ordinary list, but still mark it as modi-
3258               fiable since some contexts need to know.  */
3259             o->op_flags |= OPf_MOD;
3260             goto do_next;
3261         }
3262         if (scalar_mod_type(o, type))
3263             goto nomod;
3264         if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
3265           && type == OP_LEAVESUBLV)
3266             o->op_private |= OPpMAYBE_LVSUB;
3267         /* FALLTHROUGH */
3268     case OP_PADSV:
3269         PL_modcount++;
3270         if (!type) /* local() */
3271             Perl_croak(aTHX_ "Can't localize lexical variable %" PNf,
3272                               PNfARG(PAD_COMPNAME(o->op_targ)));
3273         if (!(o->op_private & OPpLVAL_INTRO)
3274          || (  type != OP_SASSIGN && type != OP_AASSIGN
3275             && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ))  ))
3276             S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
3277         break;
3278
3279     case OP_PUSHMARK:
3280         localize = 0;
3281         break;
3282
3283     case OP_KEYS:
3284         if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
3285             goto nomod;
3286         goto lvalue_func;
3287     case OP_SUBSTR:
3288         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
3289             goto nomod;
3290         /* FALLTHROUGH */
3291     case OP_POS:
3292     case OP_VEC:
3293       lvalue_func:
3294         if (type == OP_LEAVESUBLV)
3295             o->op_private |= OPpMAYBE_LVSUB;
3296         if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
3297             /* we recurse rather than iterate here because the child
3298              * needs to be processed with a different 'type' parameter */
3299
3300             /* substr and vec */
3301             /* If this op is in merely potential (non-fatal) modifiable
3302                context, then apply OP_ENTERSUB context to
3303                the kid op (to avoid croaking).  Other-
3304                wise pass this op’s own type so the correct op is mentioned
3305                in error messages.  */
3306             op_lvalue(OpSIBLING(cBINOPo->op_first),
3307                       S_potential_mod_type(type)
3308                         ? (I32)OP_ENTERSUB
3309                         : o->op_type);
3310         }
3311         break;
3312
3313     case OP_AELEM:
3314     case OP_HELEM:
3315         ref(cBINOPo->op_first, o->op_type);
3316         if (type == OP_ENTERSUB &&
3317              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
3318             o->op_private |= OPpLVAL_DEFER;
3319         if (type == OP_LEAVESUBLV)
3320             o->op_private |= OPpMAYBE_LVSUB;
3321         localize = 1;
3322         PL_modcount++;
3323         break;
3324
3325     case OP_LEAVE:
3326     case OP_LEAVELOOP:
3327         o->op_private |= OPpLVALUE;
3328         /* FALLTHROUGH */
3329     case OP_SCOPE:
3330     case OP_ENTER:
3331     case OP_LINESEQ:
3332         localize = 0;
3333         if (o->op_flags & OPf_KIDS)
3334             next_kid = cLISTOPo->op_last;
3335         break;
3336
3337     case OP_NULL:
3338         localize = 0;
3339         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
3340             goto nomod;
3341         else if (!(o->op_flags & OPf_KIDS))
3342             break;
3343
3344         if (o->op_targ != OP_LIST) {
3345             OP *sib = OpSIBLING(cLISTOPo->op_first);
3346             /* OP_TRANS and OP_TRANSR with argument have a weird optree
3347              * that looks like
3348              *
3349              *   null
3350              *      arg
3351              *      trans
3352              *
3353              * compared with things like OP_MATCH which have the argument
3354              * as a child:
3355              *
3356              *   match
3357              *      arg
3358              *
3359              * so handle specially to correctly get "Can't modify" croaks etc
3360              */
3361
3362             if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR))
3363             {
3364                 /* this should trigger a "Can't modify transliteration" err */
3365                 op_lvalue(sib, type);
3366             }
3367             next_kid = cBINOPo->op_first;
3368             /* we assume OP_NULLs which aren't ex-list have no more than 2
3369              * children. If this assumption is wrong, increase the scan
3370              * limit below */
3371             assert(   !OpHAS_SIBLING(next_kid)
3372                    || !OpHAS_SIBLING(OpSIBLING(next_kid)));
3373             break;
3374         }
3375         /* FALLTHROUGH */
3376     case OP_LIST:
3377         localize = 0;
3378         next_kid = cLISTOPo->op_first;
3379         break;
3380
3381     case OP_COREARGS:
3382         goto do_next;
3383
3384     case OP_AND:
3385     case OP_OR:
3386         if (type == OP_LEAVESUBLV
3387          || !S_vivifies(cLOGOPo->op_first->op_type))
3388             next_kid = cLOGOPo->op_first;
3389         else if (type == OP_LEAVESUBLV
3390          || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
3391             next_kid = OpSIBLING(cLOGOPo->op_first);
3392         goto nomod;
3393
3394     case OP_SREFGEN:
3395         if (type == OP_NULL) { /* local */
3396           local_refgen:
3397             if (!FEATURE_MYREF_IS_ENABLED)
3398                 Perl_croak(aTHX_ "The experimental declared_refs "
3399                                  "feature is not enabled");
3400             Perl_ck_warner_d(aTHX_
3401                      packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
3402                     "Declaring references is experimental");
3403             next_kid = cUNOPo->op_first;
3404             goto do_next;
3405         }
3406         if (type != OP_AASSIGN && type != OP_SASSIGN
3407          && type != OP_ENTERLOOP)
3408             goto nomod;
3409         /* Don’t bother applying lvalue context to the ex-list.  */
3410         kid = cUNOPx(cUNOPo->op_first)->op_first;
3411         assert (!OpHAS_SIBLING(kid));
3412         goto kid_2lvref;
3413     case OP_REFGEN:
3414         if (type == OP_NULL) /* local */
3415             goto local_refgen;
3416         if (type != OP_AASSIGN) goto nomod;
3417         kid = cUNOPo->op_first;
3418       kid_2lvref:
3419         {
3420             const U8 ec = PL_parser ? PL_parser->error_count : 0;
3421             S_lvref(aTHX_ kid, type);
3422             if (!PL_parser || PL_parser->error_count == ec) {
3423                 if (!FEATURE_REFALIASING_IS_ENABLED)
3424                     Perl_croak(aTHX_
3425                        "Experimental aliasing via reference not enabled");
3426                 Perl_ck_warner_d(aTHX_
3427                                  packWARN(WARN_EXPERIMENTAL__REFALIASING),
3428                                 "Aliasing via reference is experimental");
3429             }
3430         }
3431         if (o->op_type == OP_REFGEN)
3432             op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
3433         op_null(o);
3434         goto do_next;
3435
3436     case OP_SPLIT:
3437         if ((o->op_private & OPpSPLIT_ASSIGN)) {
3438             /* This is actually @array = split.  */
3439             PL_modcount = RETURN_UNLIMITED_NUMBER;
3440             break;
3441         }
3442         goto nomod;
3443
3444     case OP_SCALAR:
3445         op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
3446         goto nomod;
3447     }
3448
3449     /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
3450        their argument is a filehandle; thus \stat(".") should not set
3451        it. AMS 20011102 */
3452     if (type == OP_REFGEN && OP_IS_STAT(o->op_type))
3453         goto do_next;
3454
3455     if (type != OP_LEAVESUBLV)
3456         o->op_flags |= OPf_MOD;
3457
3458     if (type == OP_AASSIGN || type == OP_SASSIGN)
3459         o->op_flags |= o->op_type == OP_ENTERSUB ? 0 : OPf_SPECIAL|OPf_REF;
3460     else if (!type) { /* local() */
3461         switch (localize) {
3462         case 1:
3463             o->op_private |= OPpLVAL_INTRO;
3464             o->op_flags &= ~OPf_SPECIAL;
3465             PL_hints |= HINT_BLOCK_SCOPE;
3466             break;
3467         case 0:
3468             break;
3469         case -1:
3470             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
3471                            "Useless localization of %s", OP_DESC(o));
3472         }
3473     }
3474     else if (type != OP_GREPSTART && type != OP_ENTERSUB
3475              && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
3476         o->op_flags |= OPf_REF;
3477
3478   do_next:
3479     while (!next_kid) {
3480         if (o == top_op)
3481             return top_op; /* at top; no parents/siblings to try */
3482         if (OpHAS_SIBLING(o)) {
3483             next_kid = o->op_sibparent;
3484             if (!OpHAS_SIBLING(next_kid)) {
3485                 /* a few node types don't recurse into their second child */
3486                 OP *parent = next_kid->op_sibparent;
3487                 I32 ptype  = parent->op_type;
3488                 if (   (ptype == OP_NULL && parent->op_targ != OP_LIST)
3489                     || (   (ptype == OP_AND || ptype == OP_OR)
3490                         && (type != OP_LEAVESUBLV
3491                             && S_vivifies(next_kid->op_type))
3492                        )
3493                 )  {
3494                     /*try parent's next sibling */
3495                     o = parent;
3496                     next_kid =  NULL;
3497                 }
3498             }
3499         }
3500         else
3501             o = o->op_sibparent; /*try parent's next sibling */
3502
3503     }
3504     o = next_kid;
3505
3506     } /* while */
3507
3508 }
3509
3510
3511 STATIC bool
3512 S_scalar_mod_type(const OP *o, I32 type)
3513 {
3514     switch (type) {
3515     case OP_POS:
3516     case OP_SASSIGN:
3517         if (o && o->op_type == OP_RV2GV)
3518             return FALSE;
3519         /* FALLTHROUGH */
3520     case OP_PREINC:
3521     case OP_PREDEC:
3522     case OP_POSTINC:
3523     case OP_POSTDEC:
3524     case OP_I_PREINC:
3525     case OP_I_PREDEC:
3526     case OP_I_POSTINC:
3527     case OP_I_POSTDEC:
3528     case OP_POW:
3529     case OP_MULTIPLY:
3530     case OP_DIVIDE:
3531     case OP_MODULO:
3532     case OP_REPEAT:
3533     case OP_ADD:
3534     case OP_SUBTRACT:
3535     case OP_I_MULTIPLY:
3536     case OP_I_DIVIDE:
3537     case OP_I_MODULO:
3538     case OP_I_ADD:
3539     case OP_I_SUBTRACT:
3540     case OP_LEFT_SHIFT:
3541     case OP_RIGHT_SHIFT:
3542     case OP_BIT_AND:
3543     case OP_BIT_XOR:
3544     case OP_BIT_OR:
3545     case OP_NBIT_AND:
3546     case OP_NBIT_XOR:
3547     case OP_NBIT_OR:
3548     case OP_SBIT_AND:
3549     case OP_SBIT_XOR:
3550     case OP_SBIT_OR:
3551     case OP_CONCAT:
3552     case OP_SUBST:
3553     case OP_TRANS:
3554     case OP_TRANSR:
3555     case OP_READ:
3556     case OP_SYSREAD:
3557     case OP_RECV:
3558     case OP_ANDASSIGN:
3559     case OP_ORASSIGN:
3560     case OP_DORASSIGN:
3561     case OP_VEC:
3562     case OP_SUBSTR:
3563         return TRUE;
3564     default:
3565         return FALSE;
3566     }
3567 }
3568
3569 STATIC bool
3570 S_is_handle_constructor(const OP *o, I32 numargs)
3571 {
3572     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
3573
3574     switch (o->op_type) {
3575     case OP_PIPE_OP:
3576     case OP_SOCKPAIR:
3577         if (numargs == 2)
3578             return TRUE;
3579         /* FALLTHROUGH */
3580     case OP_SYSOPEN:
3581     case OP_OPEN:
3582     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
3583     case OP_SOCKET:
3584     case OP_OPEN_DIR:
3585     case OP_ACCEPT:
3586         if (numargs == 1)
3587             return TRUE;
3588         /* FALLTHROUGH */
3589     default:
3590         return FALSE;
3591     }
3592 }
3593
3594 static OP *
3595 S_refkids(pTHX_ OP *o, I32 type)
3596 {
3597     if (o && o->op_flags & OPf_KIDS) {
3598         OP *kid;
3599         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3600             ref(kid, type);
3601     }
3602     return o;
3603 }
3604
3605
3606 /* Apply reference (autovivification) context to the subtree at o.
3607  * For example in
3608  *     push @{expression}, ....;
3609  * o will be the head of 'expression' and type will be OP_RV2AV.
3610  * It marks the op o (or a suitable child) as autovivifying, e.g. by
3611  * setting  OPf_MOD.
3612  * For OP_RV2AV/OP_PADAV and OP_RV2HV/OP_PADHV sets OPf_REF too if
3613  * set_op_ref is true.
3614  *
3615  * Also calls scalar(o).
3616  */
3617
3618 OP *
3619 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
3620 {
3621     OP * top_op = o;
3622
3623     PERL_ARGS_ASSERT_DOREF;
3624
3625     if (PL_parser && PL_parser->error_count)
3626         return o;
3627
3628     while (1) {
3629         switch (o->op_type) {
3630         case OP_ENTERSUB:
3631             if ((type == OP_EXISTS || type == OP_DEFINED) &&
3632                 !(o->op_flags & OPf_STACKED)) {
3633                 OpTYPE_set(o, OP_RV2CV);             /* entersub => rv2cv */
3634                 assert(cUNOPo->op_first->op_type == OP_NULL);
3635                 /* disable pushmark */
3636                 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
3637                 o->op_flags |= OPf_SPECIAL;
3638             }
3639             else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
3640                 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3641                                   : type == OP_RV2HV ? OPpDEREF_HV
3642                                   : OPpDEREF_SV);
3643                 o->op_flags |= OPf_MOD;
3644             }
3645
3646             break;
3647
3648         case OP_COND_EXPR:
3649             o = OpSIBLING(cUNOPo->op_first);
3650             continue;
3651
3652         case OP_RV2SV:
3653             if (type == OP_DEFINED)
3654                 o->op_flags |= OPf_SPECIAL;             /* don't create GV */
3655             /* FALLTHROUGH */
3656         case OP_PADSV:
3657             if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3658                 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3659                                   : type == OP_RV2HV ? OPpDEREF_HV
3660                                   : OPpDEREF_SV);
3661                 o->op_flags |= OPf_MOD;
3662             }
3663             if (o->op_flags & OPf_KIDS) {
3664                 type = o->op_type;
3665                 o = cUNOPo->op_first;
3666                 continue;
3667             }
3668             break;
3669
3670         case OP_RV2AV:
3671         case OP_RV2HV:
3672             if (set_op_ref)
3673                 o->op_flags |= OPf_REF;
3674             /* FALLTHROUGH */
3675         case OP_RV2GV:
3676             if (type == OP_DEFINED)
3677                 o->op_flags |= OPf_SPECIAL;             /* don't create GV */
3678             type = o->op_type;
3679             o = cUNOPo->op_first;
3680             continue;
3681
3682         case OP_PADAV:
3683         case OP_PADHV:
3684             if (set_op_ref)
3685                 o->op_flags |= OPf_REF;
3686             break;
3687
3688         case OP_SCALAR:
3689         case OP_NULL:
3690             if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
3691                 break;
3692              o = cBINOPo->op_first;
3693             continue;
3694
3695         case OP_AELEM:
3696         case OP_HELEM:
3697             if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3698                 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3699                                   : type == OP_RV2HV ? OPpDEREF_HV
3700                                   : OPpDEREF_SV);
3701                 o->op_flags |= OPf_MOD;
3702             }
3703             type = o->op_type;
3704             o = cBINOPo->op_first;
3705             continue;;
3706
3707         case OP_SCOPE:
3708         case OP_LEAVE:
3709             set_op_ref = FALSE;
3710             /* FALLTHROUGH */
3711         case OP_ENTER:
3712         case OP_LIST:
3713             if (!(o->op_flags & OPf_KIDS))
3714                 break;
3715             o = cLISTOPo->op_last;
3716             continue;
3717
3718         default:
3719             break;
3720         } /* switch */
3721
3722         while (1) {
3723             if (o == top_op)
3724                 return scalar(top_op); /* at top; no parents/siblings to try */
3725             if (OpHAS_SIBLING(o)) {
3726                 o = o->op_sibparent;
3727                 /* Normally skip all siblings and go straight to the parent;
3728                  * the only op that requires two children to be processed
3729                  * is OP_COND_EXPR */
3730                 if (!OpHAS_SIBLING(o)
3731                         && o->op_sibparent->op_type == OP_COND_EXPR)
3732                     break;
3733                 continue;
3734             }
3735             o = o->op_sibparent; /*try parent's next sibling */
3736         }
3737     } /* while */
3738 }
3739
3740
3741 STATIC OP *
3742 S_dup_attrlist(pTHX_ OP *o)
3743 {
3744     OP *rop;
3745
3746     PERL_ARGS_ASSERT_DUP_ATTRLIST;
3747
3748     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
3749      * where the first kid is OP_PUSHMARK and the remaining ones
3750      * are OP_CONST.  We need to push the OP_CONST values.
3751      */
3752     if (o->op_type == OP_CONST)
3753         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
3754     else {
3755         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
3756         rop = NULL;
3757         for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
3758             if (o->op_type == OP_CONST)
3759                 rop = op_append_elem(OP_LIST, rop,
3760                                   newSVOP(OP_CONST, o->op_flags,
3761                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
3762         }
3763     }
3764     return rop;
3765 }
3766
3767 STATIC void
3768 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
3769 {
3770     PERL_ARGS_ASSERT_APPLY_ATTRS;
3771     {
3772         SV * const stashsv = newSVhek(HvNAME_HEK(stash));
3773
3774         /* fake up C<use attributes $pkg,$rv,@attrs> */
3775
3776 #define ATTRSMODULE "attributes"
3777 #define ATTRSMODULE_PM "attributes.pm"
3778
3779         Perl_load_module(
3780           aTHX_ PERL_LOADMOD_IMPORT_OPS,
3781           newSVpvs(ATTRSMODULE),
3782           NULL,
3783           op_prepend_elem(OP_LIST,
3784                           newSVOP(OP_CONST, 0, stashsv),
3785                           op_prepend_elem(OP_LIST,
3786                                           newSVOP(OP_CONST, 0,
3787                                                   newRV(target)),
3788                                           dup_attrlist(attrs))));
3789     }
3790 }
3791
3792 STATIC void
3793 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
3794 {
3795     OP *pack, *imop, *arg;
3796     SV *meth, *stashsv, **svp;
3797
3798     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
3799
3800     if (!attrs)
3801         return;
3802
3803     assert(target->op_type == OP_PADSV ||
3804            target->op_type == OP_PADHV ||
3805            target->op_type == OP_PADAV);
3806
3807     /* Ensure that attributes.pm is loaded. */
3808     /* Don't force the C<use> if we don't need it. */
3809     svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
3810     if (svp && *svp != &PL_sv_undef)
3811         NOOP;   /* already in %INC */
3812     else
3813         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
3814                                newSVpvs(ATTRSMODULE), NULL);
3815
3816     /* Need package name for method call. */
3817     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
3818
3819     /* Build up the real arg-list. */
3820     stashsv = newSVhek(HvNAME_HEK(stash));
3821
3822     arg = newOP(OP_PADSV, 0);
3823     arg->op_targ = target->op_targ;
3824     arg = op_prepend_elem(OP_LIST,
3825                        newSVOP(OP_CONST, 0, stashsv),
3826                        op_prepend_elem(OP_LIST,
3827                                     newUNOP(OP_REFGEN, 0,
3828                                             arg),
3829                                     dup_attrlist(attrs)));
3830
3831     /* Fake up a method call to import */
3832     meth = newSVpvs_share("import");
3833     imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_WANT_VOID,
3834                    op_append_elem(OP_LIST,
3835                                op_prepend_elem(OP_LIST, pack, arg),
3836                                newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
3837
3838     /* Combine the ops. */
3839     *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
3840 }
3841
3842 /*
3843 =notfor apidoc apply_attrs_string
3844
3845 Attempts to apply a list of attributes specified by the C<attrstr> and
3846 C<len> arguments to the subroutine identified by the C<cv> argument which
3847 is expected to be associated with the package identified by the C<stashpv>
3848 argument (see L<attributes>).  It gets this wrong, though, in that it
3849 does not correctly identify the boundaries of the individual attribute
3850 specifications within C<attrstr>.  This is not really intended for the
3851 public API, but has to be listed here for systems such as AIX which
3852 need an explicit export list for symbols.  (It's called from XS code
3853 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
3854 to respect attribute syntax properly would be welcome.
3855
3856 =cut
3857 */
3858
3859 void
3860 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
3861                         const char *attrstr, STRLEN len)
3862 {
3863     OP *attrs = NULL;
3864
3865     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
3866
3867     if (!len) {
3868         len = strlen(attrstr);
3869     }
3870
3871     while (len) {
3872         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
3873         if (len) {
3874             const char * const sstr = attrstr;
3875             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
3876             attrs = op_append_elem(OP_LIST, attrs,
3877                                 newSVOP(OP_CONST, 0,
3878                                         newSVpvn(sstr, attrstr-sstr)));
3879         }
3880     }
3881
3882     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3883                      newSVpvs(ATTRSMODULE),
3884                      NULL, op_prepend_elem(OP_LIST,
3885                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
3886                                   op_prepend_elem(OP_LIST,
3887                                                newSVOP(OP_CONST, 0,
3888                                                        newRV(MUTABLE_SV(cv))),
3889                                                attrs)));
3890 }
3891
3892 STATIC void
3893 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name,
3894                         bool curstash)
3895 {
3896     OP *new_proto = NULL;
3897     STRLEN pvlen;
3898     char *pv;
3899     OP *o;
3900
3901     PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
3902
3903     if (!*attrs)
3904         return;
3905
3906     o = *attrs;
3907     if (o->op_type == OP_CONST) {
3908         pv = SvPV(cSVOPo_sv, pvlen);
3909         if (memBEGINs(pv, pvlen, "prototype(")) {
3910             SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3911             SV ** const tmpo = cSVOPx_svp(o);
3912             SvREFCNT_dec(cSVOPo_sv);
3913             *tmpo = tmpsv;
3914             new_proto = o;
3915             *attrs = NULL;
3916         }
3917     } else if (o->op_type == OP_LIST) {
3918         OP * lasto;
3919         assert(o->op_flags & OPf_KIDS);
3920         lasto = cLISTOPo->op_first;
3921         assert(lasto->op_type == OP_PUSHMARK);
3922         for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
3923             if (o->op_type == OP_CONST) {
3924                 pv = SvPV(cSVOPo_sv, pvlen);
3925                 if (memBEGINs(pv, pvlen, "prototype(")) {
3926                     SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3927                     SV ** const tmpo = cSVOPx_svp(o);
3928                     SvREFCNT_dec(cSVOPo_sv);
3929                     *tmpo = tmpsv;
3930                     if (new_proto && ckWARN(WARN_MISC)) {
3931                         STRLEN new_len;
3932                         const char * newp = SvPV(cSVOPo_sv, new_len);
3933                         Perl_warner(aTHX_ packWARN(WARN_MISC),
3934                             "Attribute prototype(%" UTF8f ") discards earlier prototype attribute in same sub",
3935                             UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
3936                         op_free(new_proto);
3937                     }
3938                     else if (new_proto)
3939                         op_free(new_proto);
3940                     new_proto = o;
3941                     /* excise new_proto from the list */
3942                     op_sibling_splice(*attrs, lasto, 1, NULL);
3943                     o = lasto;
3944                     continue;
3945                 }
3946             }
3947             lasto = o;
3948         }
3949         /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
3950            would get pulled in with no real need */
3951         if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
3952             op_free(*attrs);
3953             *attrs = NULL;
3954         }
3955     }
3956
3957     if (new_proto) {
3958         SV *svname;
3959         if (isGV(name)) {
3960             svname = sv_newmortal();
3961             gv_efullname3(svname, name, NULL);
3962         }
3963         else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
3964             svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
3965         else
3966             svname = (SV *)name;
3967         if (ckWARN(WARN_ILLEGALPROTO))
3968             (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE,
3969                                  curstash);
3970         if (*proto && ckWARN(WARN_PROTOTYPE)) {
3971             STRLEN old_len, new_len;
3972             const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
3973             const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
3974
3975             if (curstash && svname == (SV *)name
3976              && !memchr(SvPVX(svname), ':', SvCUR(svname))) {
3977                 svname = sv_2mortal(newSVsv(PL_curstname));
3978                 sv_catpvs(svname, "::");
3979                 sv_catsv(svname, (SV *)name);
3980             }
3981
3982             Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3983                 "Prototype '%" UTF8f "' overridden by attribute 'prototype(%" UTF8f ")'"
3984                 " in %" SVf,
3985                 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
3986                 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
3987                 SVfARG(svname));
3988         }
3989         if (*proto)
3990             op_free(*proto);
3991         *proto = new_proto;
3992     }
3993 }
3994
3995 static void
3996 S_cant_declare(pTHX_ OP *o)
3997 {
3998     if (o->op_type == OP_NULL
3999      && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
4000         o = cUNOPo->op_first;
4001     yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
4002                              o->op_type == OP_NULL
4003                                && o->op_flags & OPf_SPECIAL
4004                                  ? "do block"
4005                                  : OP_DESC(o),
4006                              PL_parser->in_my == KEY_our   ? "our"   :
4007                              PL_parser->in_my == KEY_state ? "state" :
4008                                                              "my"));
4009 }
4010
4011 STATIC OP *
4012 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
4013 {
4014     I32 type;
4015     const bool stately = PL_parser && PL_parser->in_my == KEY_state;
4016
4017     PERL_ARGS_ASSERT_MY_KID;
4018
4019     if (!o || (PL_parser && PL_parser->error_count))
4020         return o;
4021
4022     type = o->op_type;
4023
4024     if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
4025         OP *kid;
4026         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4027             my_kid(kid, attrs, imopsp);
4028         return o;
4029     } else if (type == OP_UNDEF || type == OP_STUB) {
4030         return o;
4031     } else if (type == OP_RV2SV ||      /* "our" declaration */
4032                type == OP_RV2AV ||
4033                type == OP_RV2HV) {
4034         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
4035             S_cant_declare(aTHX_ o);
4036         } else if (attrs) {
4037             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
4038             assert(PL_parser);
4039             PL_parser->in_my = FALSE;
4040             PL_parser->in_my_stash = NULL;
4041             apply_attrs(GvSTASH(gv),
4042                         (type == OP_RV2SV ? GvSVn(gv) :
4043                          type == OP_RV2AV ? MUTABLE_SV(GvAVn(gv)) :
4044                          type == OP_RV2HV ? MUTABLE_SV(GvHVn(gv)) : MUTABLE_SV(gv)),
4045                         attrs);
4046         }
4047         o->op_private |= OPpOUR_INTRO;
4048         return o;
4049     }
4050     else if (type == OP_REFGEN || type == OP_SREFGEN) {
4051         if (!FEATURE_MYREF_IS_ENABLED)
4052             Perl_croak(aTHX_ "The experimental declared_refs "
4053                              "feature is not enabled");
4054         Perl_ck_warner_d(aTHX_
4055              packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4056             "Declaring references is experimental");
4057         /* Kid is a nulled OP_LIST, handled above.  */
4058         my_kid(cUNOPo->op_first, attrs, imopsp);
4059         return o;
4060     }
4061     else if (type != OP_PADSV &&
4062              type != OP_PADAV &&
4063              type != OP_PADHV &&
4064              type != OP_PUSHMARK)
4065     {
4066         S_cant_declare(aTHX_ o);
4067         return o;
4068     }
4069     else if (attrs && type != OP_PUSHMARK) {
4070         HV *stash;
4071
4072         assert(PL_parser);
4073         PL_parser->in_my = FALSE;
4074         PL_parser->in_my_stash = NULL;
4075
4076         /* check for C<my Dog $spot> when deciding package */
4077         stash = PAD_COMPNAME_TYPE(o->op_targ);
4078         if (!stash)
4079             stash = PL_curstash;
4080         apply_attrs_my(stash, o, attrs, imopsp);
4081     }
4082     o->op_flags |= OPf_MOD;
4083     o->op_private |= OPpLVAL_INTRO;
4084     if (stately)
4085         o->op_private |= OPpPAD_STATE;
4086     return o;
4087 }
4088
4089 OP *
4090 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
4091 {
4092     OP *rops;
4093     int maybe_scalar = 0;
4094
4095     PERL_ARGS_ASSERT_MY_ATTRS;
4096
4097 /* [perl #17376]: this appears to be premature, and results in code such as
4098    C< our(%x); > executing in list mode rather than void mode */
4099 #if 0
4100     if (o->op_flags & OPf_PARENS)
4101         list(o);
4102     else
4103         maybe_scalar = 1;
4104 #else
4105     maybe_scalar = 1;
4106 #endif
4107     if (attrs)
4108         SAVEFREEOP(attrs);
4109     rops = NULL;
4110     o = my_kid(o, attrs, &rops);
4111     if (rops) {
4112         if (maybe_scalar && o->op_type == OP_PADSV) {
4113             o = scalar(op_append_list(OP_LIST, rops, o));
4114             o->op_private |= OPpLVAL_INTRO;
4115         }
4116         else {
4117             /* The listop in rops might have a pushmark at the beginning,
4118                which will mess up list assignment. */
4119             LISTOP * const lrops = cLISTOPx(rops); /* for brevity */
4120             if (rops->op_type == OP_LIST &&
4121                 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
4122             {
4123                 OP * const pushmark = lrops->op_first;
4124                 /* excise pushmark */
4125                 op_sibling_splice(rops, NULL, 1, NULL);
4126                 op_free(pushmark);
4127             }
4128             o = op_append_list(OP_LIST, o, rops);
4129         }
4130     }
4131     PL_parser->in_my = FALSE;
4132     PL_parser->in_my_stash = NULL;
4133     return o;
4134 }
4135
4136 OP *
4137 Perl_sawparens(pTHX_ OP *o)
4138 {
4139     PERL_UNUSED_CONTEXT;
4140     if (o)
4141         o->op_flags |= OPf_PARENS;
4142     return o;
4143 }
4144
4145 OP *
4146 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
4147 {
4148     OP *o;
4149     bool ismatchop = 0;
4150     const OPCODE ltype = left->op_type;
4151     const OPCODE rtype = right->op_type;
4152
4153     PERL_ARGS_ASSERT_BIND_MATCH;
4154
4155     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
4156           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
4157     {
4158       const char * const desc
4159           = PL_op_desc[(
4160                           rtype == OP_SUBST || rtype == OP_TRANS
4161                        || rtype == OP_TRANSR
4162                        )
4163                        ? (int)rtype : OP_MATCH];
4164       const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
4165       SV * const name = op_varname(left);
4166       if (name)
4167         Perl_warner(aTHX_ packWARN(WARN_MISC),
4168              "Applying %s to %" SVf " will act on scalar(%" SVf ")",
4169              desc, SVfARG(name), SVfARG(name));
4170       else {
4171         const char * const sample = (isary
4172              ? "@array" : "%hash");
4173         Perl_warner(aTHX_ packWARN(WARN_MISC),
4174              "Applying %s to %s will act on scalar(%s)",
4175              desc, sample, sample);
4176       }
4177     }
4178
4179     if (rtype == OP_CONST &&
4180         cSVOPx(right)->op_private & OPpCONST_BARE &&
4181         cSVOPx(right)->op_private & OPpCONST_STRICT)
4182     {
4183         no_bareword_allowed(right);
4184     }
4185
4186     /* !~ doesn't make sense with /r, so error on it for now */
4187     if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
4188         type == OP_NOT)
4189         /* diag_listed_as: Using !~ with %s doesn't make sense */
4190         yyerror("Using !~ with s///r doesn't make sense");
4191     if (rtype == OP_TRANSR && type == OP_NOT)
4192         /* diag_listed_as: Using !~ with %s doesn't make sense */
4193         yyerror("Using !~ with tr///r doesn't make sense");
4194
4195     ismatchop = (rtype == OP_MATCH ||
4196                  rtype == OP_SUBST ||
4197                  rtype == OP_TRANS || rtype == OP_TRANSR)
4198              && !(right->op_flags & OPf_SPECIAL);
4199     if (ismatchop && right->op_private & OPpTARGET_MY) {
4200         right->op_targ = 0;
4201         right->op_private &= ~OPpTARGET_MY;
4202     }
4203     if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
4204         if (left->op_type == OP_PADSV
4205          && !(left->op_private & OPpLVAL_INTRO))
4206         {
4207             right->op_targ = left->op_targ;
4208             op_free(left);
4209             o = right;
4210         }
4211         else {
4212             right->op_flags |= OPf_STACKED;
4213             if (rtype != OP_MATCH && rtype != OP_TRANSR &&
4214             ! (rtype == OP_TRANS &&
4215                right->op_private & OPpTRANS_IDENTICAL) &&
4216             ! (rtype == OP_SUBST &&
4217                (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
4218                 left = op_lvalue(left, rtype);
4219             if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
4220                 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
4221             else
4222                 o = op_prepend_elem(rtype, scalar(left), right);
4223         }
4224         if (type == OP_NOT)
4225             return newUNOP(OP_NOT, 0, scalar(o));
4226         return o;
4227     }
4228     else
4229         return bind_match(type, left,
4230                 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
4231 }
4232
4233 OP *
4234 Perl_invert(pTHX_ OP *o)
4235 {
4236     if (!o)
4237         return NULL;
4238     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
4239 }
4240
4241 OP *
4242 Perl_cmpchain_start(pTHX_ I32 type, OP *left, OP *right)
4243 {
4244     BINOP *bop;
4245     OP *op;
4246
4247     if (!left)
4248         left = newOP(OP_NULL, 0);
4249     if (!right)
4250         right = newOP(OP_NULL, 0);
4251     scalar(left);
4252     scalar(right);
4253     NewOp(0, bop, 1, BINOP);
4254     op = (OP*)bop;
4255     ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP);
4256     OpTYPE_set(op, type);
4257     cBINOPx(op)->op_flags = OPf_KIDS;
4258     cBINOPx(op)->op_private = 2;
4259     cBINOPx(op)->op_first = left;
4260     cBINOPx(op)->op_last = right;
4261     OpMORESIB_set(left, right);
4262     OpLASTSIB_set(right, op);
4263     return op;
4264 }
4265
4266 OP *
4267 Perl_cmpchain_extend(pTHX_ I32 type, OP *ch, OP *right)
4268 {
4269     BINOP *bop;
4270     OP *op;
4271
4272     PERL_ARGS_ASSERT_CMPCHAIN_EXTEND;
4273     if (!right)
4274         right = newOP(OP_NULL, 0);
4275     scalar(right);
4276     NewOp(0, bop, 1, BINOP);
4277     op = (OP*)bop;
4278     ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP);
4279     OpTYPE_set(op, type);
4280     if (ch->op_type != OP_NULL) {
4281         UNOP *lch;
4282         OP *nch, *cleft, *cright;
4283         NewOp(0, lch, 1, UNOP);
4284         nch = (OP*)lch;
4285         OpTYPE_set(nch, OP_NULL);
4286         nch->op_flags = OPf_KIDS;
4287         cleft = cBINOPx(ch)->op_first;
4288         cright = cBINOPx(ch)->op_last;
4289         cBINOPx(ch)->op_first = NULL;
4290         cBINOPx(ch)->op_last = NULL;
4291         cBINOPx(ch)->op_private = 0;
4292         cBINOPx(ch)->op_flags = 0;
4293         cUNOPx(nch)->op_first = cright;
4294         OpMORESIB_set(cright, ch);
4295         OpMORESIB_set(ch, cleft);
4296         OpLASTSIB_set(cleft, nch);
4297         ch = nch;
4298     }
4299     OpMORESIB_set(right, op);
4300     OpMORESIB_set(op, cUNOPx(ch)->op_first);
4301     cUNOPx(ch)->op_first = right;
4302     return ch;
4303 }
4304
4305 OP *
4306 Perl_cmpchain_finish(pTHX_ OP *ch)
4307 {
4308
4309     PERL_ARGS_ASSERT_CMPCHAIN_FINISH;
4310     if (ch->op_type != OP_NULL) {
4311         OPCODE cmpoptype = ch->op_type;
4312         ch = CHECKOP(cmpoptype, ch);
4313         if(!ch->op_next && ch->op_type == cmpoptype)
4314             ch = fold_constants(op_integerize(op_std_init(ch)));
4315         return ch;
4316     } else {
4317         OP *condop = NULL;
4318         OP *rightarg = cUNOPx(ch)->op_first;
4319         cUNOPx(ch)->op_first = OpSIBLING(rightarg);
4320         OpLASTSIB_set(rightarg, NULL);
4321         while (1) {
4322             OP *cmpop = cUNOPx(ch)->op_first;
4323             OP *leftarg = OpSIBLING(cmpop);
4324             OPCODE cmpoptype = cmpop->op_type;
4325             OP *nextrightarg;
4326             bool is_last;
4327             is_last = !(cUNOPx(ch)->op_first = OpSIBLING(leftarg));
4328             OpLASTSIB_set(cmpop, NULL);
4329             OpLASTSIB_set(leftarg, NULL);
4330             if (is_last) {
4331                 ch->op_flags = 0;
4332                 op_free(ch);
4333                 nextrightarg = NULL;
4334             } else {
4335                 nextrightarg = newUNOP(OP_CMPCHAIN_DUP, 0, leftarg);
4336                 leftarg = newOP(OP_NULL, 0);
4337             }
4338             cBINOPx(cmpop)->op_first = leftarg;
4339             cBINOPx(cmpop)->op_last = rightarg;
4340             OpMORESIB_set(leftarg, rightarg);
4341             OpLASTSIB_set(rightarg, cmpop);
4342             cmpop->op_flags = OPf_KIDS;
4343             cmpop->op_private = 2;
4344             cmpop = CHECKOP(cmpoptype, cmpop);
4345             if(!cmpop->op_next && cmpop->op_type == cmpoptype)
4346                 cmpop = op_integerize(op_std_init(cmpop));
4347             condop = condop ? newLOGOP(OP_CMPCHAIN_AND, 0, cmpop, condop) :
4348                         cmpop;
4349             if (!nextrightarg)
4350                 return condop;
4351             rightarg = nextrightarg;
4352         }
4353     }
4354 }
4355
4356 /*
4357 =for apidoc op_scope
4358
4359 Wraps up an op tree with some additional ops so that at runtime a dynamic
4360 scope will be created.  The original ops run in the new dynamic scope,
4361 and then, provided that they exit normally, the scope will be unwound.
4362 The additional ops used to create and unwind the dynamic scope will
4363 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
4364 instead if the ops are simple enough to not need the full dynamic scope
4365 structure.
4366
4367 =cut
4368 */
4369
4370 OP *
4371 Perl_op_scope(pTHX_ OP *o)
4372 {
4373     if (o) {
4374         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
4375             o = op_prepend_elem(OP_LINESEQ,
4376                     newOP(OP_ENTER, (o->op_flags & OPf_WANT)), o);
4377             OpTYPE_set(o, OP_LEAVE);
4378         }
4379         else if (o->op_type == OP_LINESEQ) {
4380             OP *kid;
4381             OpTYPE_set(o, OP_SCOPE);
4382             kid = cLISTOPo->op_first;
4383             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
4384                 op_null(kid);
4385
4386                 /* The following deals with things like 'do {1 for 1}' */
4387                 kid = OpSIBLING(kid);
4388                 if (kid &&
4389                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
4390                     op_null(kid);
4391             }
4392         }
4393         else
4394             o = newLISTOP(OP_SCOPE, 0, o, NULL);
4395     }
4396     return o;
4397 }
4398
4399 OP *
4400 Perl_op_unscope(pTHX_ OP *o)
4401 {
4402     if (o && o->op_type == OP_LINESEQ) {
4403         OP *kid = cLISTOPo->op_first;
4404         for(; kid; kid = OpSIBLING(kid))
4405             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
4406                 op_null(kid);
4407     }
4408     return o;
4409 }
4410
4411 /*
4412 =for apidoc block_start
4413
4414 Handles compile-time scope entry.
4415 Arranges for hints to be restored on block
4416 exit and also handles pad sequence numbers to make lexical variables scope
4417 right.  Returns a savestack index for use with C<block_end>.
4418
4419 =cut
4420 */
4421
4422 int
4423 Perl_block_start(pTHX_ int full)
4424 {
4425     const int retval = PL_savestack_ix;
4426
4427     PL_compiling.cop_seq = PL_cop_seqmax;
4428     COP_SEQMAX_INC;
4429     pad_block_start(full);
4430     SAVEHINTS();
4431     PL_hints &= ~HINT_BLOCK_SCOPE;
4432     SAVECOMPILEWARNINGS();
4433     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
4434     SAVEI32(PL_compiling.cop_seq);
4435     PL_compiling.cop_seq = 0;
4436
4437     CALL_BLOCK_HOOKS(bhk_start, full);
4438
4439     return retval;
4440 }
4441
4442 /*
4443 =for apidoc block_end
4444
4445 Handles compile-time scope exit.  C<floor>
4446 is the savestack index returned by
4447 C<block_start>, and C<seq> is the body of the block.  Returns the block,
4448 possibly modified.
4449
4450 =cut
4451 */
4452
4453 OP*
4454 Perl_block_end(pTHX_ I32 floor, OP *seq)
4455 {
4456     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
4457     OP* retval = voidnonfinal(seq);
4458     OP *o;
4459
4460     /* XXX Is the null PL_parser check necessary here? */
4461     assert(PL_parser); /* Let’s find out under debugging builds.  */
4462     if (PL_parser && PL_parser->parsed_sub) {
4463         o = newSTATEOP(0, NULL, NULL);
4464         op_null(o);
4465         retval = op_append_elem(OP_LINESEQ, retval, o);
4466     }
4467
4468     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
4469
4470     LEAVE_SCOPE(floor);
4471     if (needblockscope)
4472         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
4473     o = pad_leavemy();
4474
4475     if (o) {
4476         /* pad_leavemy has created a sequence of introcv ops for all my
4477            subs declared in the block.  We have to replicate that list with
4478            clonecv ops, to deal with this situation:
4479
4480                sub {
4481                    my sub s1;
4482                    my sub s2;
4483                    sub s1 { state sub foo { \&s2 } }
4484                }->()
4485
4486            Originally, I was going to have introcv clone the CV and turn
4487            off the stale flag.  Since &s1 is declared before &s2, the
4488            introcv op for &s1 is executed (on sub entry) before the one for
4489            &s2.  But the &foo sub inside &s1 (which is cloned when &s1 is
4490            cloned, since it is a state sub) closes over &s2 and expects
4491            to see it in its outer CV’s pad.  If the introcv op clones &s1,
4492            then &s2 is still marked stale.  Since &s1 is not active, and
4493            &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
4494            ble will not stay shared’ warning.  Because it is the same stub
4495            that will be used when the introcv op for &s2 is executed, clos-
4496            ing over it is safe.  Hence, we have to turn off the stale flag
4497            on all lexical subs in the block before we clone any of them.
4498            Hence, having introcv clone the sub cannot work.  So we create a
4499            list of ops like this:
4500
4501                lineseq
4502                   |
4503                   +-- introcv
4504                   |
4505                   +-- introcv
4506                   |
4507                   +-- introcv
4508                   |
4509                   .
4510                   .
4511                   .
4512                   |
4513                   +-- clonecv
4514                   |
4515                   +-- clonecv
4516                   |
4517                   +-- clonecv
4518                   |
4519                   .
4520                   .
4521                   .
4522          */
4523         OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
4524         OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
4525         for (;; kid = OpSIBLING(kid)) {
4526             OP *newkid = newOP(OP_CLONECV, 0);
4527             newkid->op_targ = kid->op_targ;
4528             o = op_append_elem(OP_LINESEQ, o, newkid);
4529             if (kid == last) break;
4530         }
4531         retval = op_prepend_elem(OP_LINESEQ, o, retval);
4532     }
4533
4534     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
4535
4536     return retval;
4537 }
4538
4539 /*
4540 =for apidoc_section $scope
4541
4542 =for apidoc blockhook_register
4543
4544 Register a set of hooks to be called when the Perl lexical scope changes
4545 at compile time.  See L<perlguts/"Compile-time scope hooks">.
4546
4547 =cut
4548 */
4549
4550 void
4551 Perl_blockhook_register(pTHX_ BHK *hk)
4552 {
4553     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
4554
4555     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
4556 }
4557
4558 void
4559 Perl_newPROG(pTHX_ OP *o)
4560 {
4561     OP *start;
4562
4563     PERL_ARGS_ASSERT_NEWPROG;
4564
4565     if (PL_in_eval) {
4566         PERL_CONTEXT *cx;
4567         I32 i;
4568         if (PL_eval_root)
4569                 return;
4570         PL_eval_root = newUNOP(OP_LEAVEEVAL,
4571                                ((PL_in_eval & EVAL_KEEPERR)
4572                                 ? OPf_SPECIAL : 0), o);
4573
4574         cx = CX_CUR();
4575         assert(CxTYPE(cx) == CXt_EVAL);
4576
4577         if ((cx->blk_gimme & G_WANT) == G_VOID)
4578             scalarvoid(PL_eval_root);
4579         else if ((cx->blk_gimme & G_WANT) == G_LIST)
4580             list(PL_eval_root);
4581         else
4582             scalar(PL_eval_root);
4583
4584         start = op_linklist(PL_eval_root);
4585         PL_eval_root->op_next = 0;
4586         i = PL_savestack_ix;
4587         SAVEFREEOP(o);
4588         ENTER;
4589         S_process_optree(aTHX_ NULL, PL_eval_root, start);
4590         LEAVE;
4591         PL_savestack_ix = i;
4592     }
4593     else {
4594         if (o->op_type == OP_STUB) {
4595             /* This block is entered if nothing is compiled for the main
4596                program. This will be the case for an genuinely empty main
4597                program, or one which only has BEGIN blocks etc, so already
4598                run and freed.
4599
4600                Historically (5.000) the guard above was !o. However, commit
4601                f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
4602                c71fccf11fde0068, changed perly.y so that newPROG() is now
4603                called with the output of block_end(), which returns a new
4604                OP_STUB for the case of an empty optree. ByteLoader (and
4605                maybe other things) also take this path, because they set up
4606                PL_main_start and PL_main_root directly, without generating an
4607                optree.
4608
4609                If the parsing the main program aborts (due to parse errors,
4610                or due to BEGIN or similar calling exit), then newPROG()
4611                isn't even called, and hence this code path and its cleanups
4612                are skipped. This shouldn't make a make a difference:
4613                * a non-zero return from perl_parse is a failure, and
4614                  perl_destruct() should be called immediately.
4615                * however, if exit(0) is called during the parse, then
4616                  perl_parse() returns 0, and perl_run() is called. As
4617                  PL_main_start will be NULL, perl_run() will return
4618                  promptly, and the exit code will remain 0.
4619             */
4620
4621             PL_comppad_name = 0;
4622             PL_compcv = 0;
4623             S_op_destroy(aTHX_ o);
4624             return;
4625         }
4626         PL_main_root = op_scope(sawparens(scalarvoid(o)));
4627         PL_curcop = &PL_compiling;
4628         start = LINKLIST(PL_main_root);
4629         PL_main_root->op_next = 0;
4630         S_process_optree(aTHX_ NULL, PL_main_root, start);
4631         if (!PL_parser->error_count)
4632             /* on error, leave CV slabbed so that ops left lying around
4633              * will eb cleaned up. Else unslab */
4634             cv_forget_slab(PL_compcv);
4635         PL_compcv = 0;
4636
4637         /* Register with debugger */
4638         if (PERLDB_INTER) {
4639             CV * const cv = get_cvs("DB::postponed", 0);
4640             if (cv) {
4641                 dSP;
4642                 PUSHMARK(SP);
4643                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
4644                 PUTBACK;
4645                 call_sv(MUTABLE_SV(cv), G_DISCARD);
4646             }
4647         }
4648     }
4649 }
4650
4651 OP *
4652 Perl_localize(pTHX_ OP *o, I32 lex)
4653 {
4654     PERL_ARGS_ASSERT_LOCALIZE;
4655
4656     if (o->op_flags & OPf_PARENS)
4657 /* [perl #17376]: this appears to be premature, and results in code such as
4658    C< our(%x); > executing in list mode rather than void mode */
4659 #if 0
4660         list(o);
4661 #else
4662         NOOP;
4663 #endif
4664     else {
4665         if ( PL_parser->bufptr > PL_parser->oldbufptr
4666             && PL_parser->bufptr[-1] == ','
4667             && ckWARN(WARN_PARENTHESIS))
4668         {
4669             char *s = PL_parser->bufptr;
4670             bool sigil = FALSE;
4671
4672             /* some heuristics to detect a potential error */
4673             while (*s && (memCHRs(", \t\n", *s)))
4674                 s++;
4675
4676             while (1) {
4677                 if (*s && (memCHRs("@$%", *s) || (!lex && *s == '*'))
4678                        && *++s
4679                        && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
4680                     s++;
4681                     sigil = TRUE;
4682                     while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
4683                         s++;
4684                     while (*s && (memCHRs(", \t\n", *s)))
4685                         s++;
4686                 }
4687                 else
4688                     break;
4689             }
4690             if (sigil && (*s == ';' || *s == '=')) {
4691                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
4692                                 "Parentheses missing around \"%s\" list",
4693                                 lex
4694                                     ? (PL_parser->in_my == KEY_our
4695                                         ? "our"
4696                                         : PL_parser->in_my == KEY_state
4697                                             ? "state"
4698                                             : "my")
4699                                     : "local");
4700             }
4701         }
4702     }
4703     if (lex)
4704         o = my(o);
4705     else
4706         o = op_lvalue(o, OP_NULL);              /* a bit kludgey */
4707     PL_parser->in_my = FALSE;
4708     PL_parser->in_my_stash = NULL;
4709     return o;
4710 }
4711
4712 OP *
4713 Perl_jmaybe(pTHX_ OP *o)
4714 {
4715     PERL_ARGS_ASSERT_JMAYBE;
4716
4717     if (o->op_type == OP_LIST) {
4718         if (FEATURE_MULTIDIMENSIONAL_IS_ENABLED) {
4719             OP * const o2
4720                 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
4721             o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
4722         }
4723         else {
4724             /* If the user disables this, then a warning might not be enough to alert
4725                them to a possible change of behaviour here, so throw an exception.
4726             */
4727             yyerror("Multidimensional hash lookup is disabled");
4728         }
4729     }
4730     return o;
4731 }
4732
4733 PERL_STATIC_INLINE OP *
4734 S_op_std_init(pTHX_ OP *o)
4735 {
4736     I32 type = o->op_type;
4737
4738     PERL_ARGS_ASSERT_OP_STD_INIT;
4739
4740     if (PL_opargs[type] & OA_RETSCALAR)
4741         scalar(o);
4742     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
4743         o->op_targ = pad_alloc(type, SVs_PADTMP);
4744
4745     return o;
4746 }
4747
4748 PERL_STATIC_INLINE OP *
4749 S_op_integerize(pTHX_ OP *o)
4750 {
4751     I32 type = o->op_type;
4752
4753     PERL_ARGS_ASSERT_OP_INTEGERIZE;
4754
4755     /* integerize op. */
4756     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
4757     {
4758         o->op_ppaddr = PL_ppaddr[++(o->op_type)];
4759     }
4760
4761     if (type == OP_NEGATE)
4762         /* XXX might want a ck_negate() for this */
4763         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
4764
4765     return o;
4766 }
4767
4768 /* This function exists solely to provide a scope to limit
4769    setjmp/longjmp() messing with auto variables.  It cannot be inlined because
4770    it uses setjmp
4771  */
4772 STATIC int
4773 S_fold_constants_eval(pTHX) {
4774     int ret = 0;
4775     dJMPENV;
4776
4777     JMPENV_PUSH(ret);
4778
4779     if (ret == 0) {
4780         CALLRUNOPS(aTHX);
4781     }
4782
4783     JMPENV_POP;
4784
4785     return ret;
4786 }
4787
4788 static OP *
4789 S_fold_constants(pTHX_ OP *const o)
4790 {
4791     OP *curop;
4792     OP *newop;
4793     I32 type = o->op_type;
4794     bool is_stringify;
4795     SV *sv = NULL;
4796     int ret = 0;
4797     OP *old_next;
4798     SV * const oldwarnhook = PL_warnhook;
4799     SV * const olddiehook  = PL_diehook;
4800     COP not_compiling;
4801     U8 oldwarn = PL_dowarn;
4802     I32 old_cxix;
4803
4804     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
4805
4806     if (!(PL_opargs[type] & OA_FOLDCONST))
4807         goto nope;
4808
4809     switch (type) {
4810     case OP_UCFIRST:
4811     case OP_LCFIRST:
4812     case OP_UC:
4813     case OP_LC:
4814     case OP_FC:
4815 #ifdef USE_LOCALE_CTYPE
4816         if (IN_LC_COMPILETIME(LC_CTYPE))
4817             goto nope;
4818 #endif
4819         break;
4820     case OP_SLT:
4821     case OP_SGT:
4822     case OP_SLE:
4823     case OP_SGE:
4824     case OP_SCMP:
4825 #ifdef USE_LOCALE_COLLATE
4826         if (IN_LC_COMPILETIME(LC_COLLATE))
4827             goto nope;
4828 #endif
4829         break;
4830     case OP_SPRINTF:
4831         /* XXX what about the numeric ops? */
4832 #ifdef USE_LOCALE_NUMERIC
4833         if (IN_LC_COMPILETIME(LC_NUMERIC))
4834             goto nope;
4835 #endif
4836         break;
4837     case OP_PACK:
4838         if (!OpHAS_SIBLING(cLISTOPo->op_first)
4839           || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
4840             goto nope;
4841         {
4842             SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
4843             if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
4844             {
4845                 const char *s = SvPVX_const(sv);
4846                 while (s < SvEND(sv)) {
4847                     if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
4848                     s++;
4849                 }
4850             }
4851         }
4852         break;
4853     case OP_REPEAT:
4854         if (o->op_private & OPpREPEAT_DOLIST) goto nope;
4855         break;
4856     case OP_SREFGEN:
4857         if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
4858          || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
4859             goto nope;
4860     }
4861
4862     if (PL_parser && PL_parser->error_count)
4863         goto nope;              /* Don't try to run w/ errors */
4864
4865     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4866         switch (curop->op_type) {
4867         case OP_CONST:
4868             if (   (curop->op_private & OPpCONST_BARE)
4869                 && (curop->op_private & OPpCONST_STRICT)) {
4870                 no_bareword_allowed(curop);
4871                 goto nope;
4872             }
4873             /* FALLTHROUGH */
4874         case OP_LIST:
4875         case OP_SCALAR:
4876         case OP_NULL:
4877         case OP_PUSHMARK:
4878             /* Foldable; move to next op in list */
4879             break;
4880
4881         default:
4882             /* No other op types are considered foldable */
4883             goto nope;
4884         }
4885     }
4886
4887     curop = LINKLIST(o);
4888     old_next = o->op_next;
4889     o->op_next = 0;
4890     PL_op = curop;
4891
4892     old_cxix = cxstack_ix;
4893     create_eval_scope(NULL, G_FAKINGEVAL);
4894
4895     /* Verify that we don't need to save it:  */
4896     assert(PL_curcop == &PL_compiling);
4897     StructCopy(&PL_compiling, &not_compiling, COP);
4898     PL_curcop = &not_compiling;
4899     /* The above ensures that we run with all the correct hints of the
4900        currently compiling COP, but that IN_PERL_RUNTIME is true. */
4901     assert(IN_PERL_RUNTIME);
4902     PL_warnhook = PERL_WARNHOOK_FATAL;
4903     PL_diehook  = NULL;
4904
4905     /* Effective $^W=1.  */
4906     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
4907         PL_dowarn |= G_WARN_ON;
4908
4909     ret = S_fold_constants_eval(aTHX);
4910
4911     switch (ret) {
4912     case 0:
4913         sv = *(PL_stack_sp--);
4914         if (o->op_targ && sv == PAD_SV(o->op_targ)) {   /* grab pad temp? */
4915             pad_swipe(o->op_targ,  FALSE);
4916         }
4917         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
4918             SvREFCNT_inc_simple_void(sv);
4919             SvTEMP_off(sv);
4920         }
4921         else { assert(SvIMMORTAL(sv)); }
4922         break;
4923     case 3:
4924         /* Something tried to die.  Abandon constant folding.  */
4925         /* Pretend the error never happened.  */
4926         CLEAR_ERRSV();
4927         o->op_next = old_next;
4928         break;
4929     default:
4930         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
4931         PL_warnhook = oldwarnhook;
4932         PL_diehook  = olddiehook;
4933         /* XXX note that this croak may fail as we've already blown away
4934          * the stack - eg any nested evals */
4935         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
4936     }
4937     PL_dowarn   = oldwarn;
4938     PL_warnhook = oldwarnhook;
4939     PL_diehook  = olddiehook;
4940     PL_curcop = &PL_compiling;
4941
4942     /* if we croaked, depending on how we croaked the eval scope
4943      * may or may not have already been popped */
4944     if (cxstack_ix > old_cxix) {
4945         assert(cxstack_ix == old_cxix + 1);
4946         assert(CxTYPE(CX_CUR()) == CXt_EVAL);
4947         delete_eval_scope();
4948     }
4949     if (ret)
4950         goto nope;
4951
4952     /* OP_STRINGIFY and constant folding are used to implement qq.
4953        Here the constant folding is an implementation detail that we
4954        want to hide.  If the stringify op is itself already marked
4955        folded, however, then it is actually a folded join.  */
4956     is_stringify = type == OP_STRINGIFY && !o->op_folded;
4957     op_free(o);
4958     assert(sv);
4959     if (is_stringify)
4960         SvPADTMP_off(sv);
4961     else if (!SvIMMORTAL(sv)) {
4962         SvPADTMP_on(sv);
4963         SvREADONLY_on(sv);
4964     }
4965     newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
4966     if (!is_stringify) newop->op_folded = 1;
4967     return newop;
4968
4969  nope:
4970     return o;
4971 }
4972
4973 /* convert a constant range in list context into an OP_RV2AV, OP_CONST pair;
4974  * the constant value being an AV holding the flattened range.
4975  */
4976
4977 static void
4978 S_gen_constant_list(pTHX_ OP *o)
4979 {
4980     OP *curop, *old_next;
4981     SV * const oldwarnhook = PL_warnhook;
4982     SV * const olddiehook  = PL_diehook;
4983     COP *old_curcop;
4984     U8 oldwarn = PL_dowarn;
4985     SV **svp;
4986     AV *av;
4987     I32 old_cxix;
4988     COP not_compiling;
4989     int ret = 0;
4990     dJMPENV;
4991     bool op_was_null;
4992
4993     list(o);
4994     if (PL_parser && PL_parser->error_count)
4995         return;         /* Don't attempt to run with errors */
4996
4997     curop = LINKLIST(o);
4998     old_next = o->op_next;
4999     o->op_next = 0;
5000     op_was_null = o->op_type == OP_NULL;
5001     if (op_was_null) /* b3698342565fb462291fba4b432cfcd05b6eb4e1 */
5002         o->op_type = OP_CUSTOM;
5003     CALL_PEEP(curop);
5004     if (op_was_null)
5005         o->op_type = OP_NULL;
5006     op_prune_chain_head(&curop);
5007     PL_op = curop;
5008
5009     old_cxix = cxstack_ix;
5010     create_eval_scope(NULL, G_FAKINGEVAL);
5011
5012     old_curcop = PL_curcop;
5013     StructCopy(old_curcop, &not_compiling, COP);
5014     PL_curcop = &not_compiling;
5015     /* The above ensures that we run with all the correct hints of the
5016        current COP, but that IN_PERL_RUNTIME is true. */
5017     assert(IN_PERL_RUNTIME);
5018     PL_warnhook = PERL_WARNHOOK_FATAL;
5019     PL_diehook  = NULL;
5020     JMPENV_PUSH(ret);
5021
5022     /* Effective $^W=1.  */
5023     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
5024         PL_dowarn |= G_WARN_ON;
5025
5026     switch (ret) {
5027     case 0:
5028 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
5029         PL_curstackinfo->si_stack_hwm = 0; /* stop valgrind complaining */
5030 #endif
5031         Perl_pp_pushmark(aTHX);
5032         CALLRUNOPS(aTHX);
5033         PL_op = curop;
5034         assert (!(curop->op_flags & OPf_SPECIAL));
5035         assert(curop->op_type == OP_RANGE);
5036         Perl_pp_anonlist(aTHX);
5037         break;
5038     case 3:
5039         CLEAR_ERRSV();
5040         o->op_next = old_next;
5041         break;
5042     default:
5043         JMPENV_POP;
5044         PL_warnhook = oldwarnhook;
5045         PL_diehook = olddiehook;
5046         Perl_croak(aTHX_ "panic: gen_constant_list JMPENV_PUSH returned %d",
5047             ret);
5048     }
5049
5050     JMPENV_POP;
5051     PL_dowarn = oldwarn;
5052     PL_warnhook = oldwarnhook;
5053     PL_diehook = olddiehook;
5054     PL_curcop = old_curcop;
5055
5056     if (cxstack_ix > old_cxix) {
5057         assert(cxstack_ix == old_cxix + 1);
5058         assert(CxTYPE(CX_CUR()) == CXt_EVAL);
5059         delete_eval_scope();
5060     }
5061     if (ret)
5062         return;
5063
5064     OpTYPE_set(o, OP_RV2AV);
5065     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
5066     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
5067     o->op_opt = 0;              /* needs to be revisited in rpeep() */
5068     av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
5069
5070     /* replace subtree with an OP_CONST */
5071     curop = cUNOPo->op_first;
5072     op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
5073     op_free(curop);
5074
5075     if (AvFILLp(av) != -1)
5076         for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
5077         {
5078             SvPADTMP_on(*svp);
5079             SvREADONLY_on(*svp);
5080         }
5081     LINKLIST(o);
5082     list(o);
5083     return;
5084 }
5085
5086 /*
5087 =for apidoc_section $optree_manipulation
5088 */
5089
5090 /* List constructors */
5091
5092 /*
5093 =for apidoc op_append_elem
5094
5095 Append an item to the list of ops contained directly within a list-type
5096 op, returning the lengthened list.  C<first> is the list-type op,
5097 and C<last> is the op to append to the list.  C<optype> specifies the
5098 intended opcode for the list.  If C<first> is not already a list of the
5099 right type, it will be upgraded into one.  If either C<first> or C<last>
5100 is null, the other is returned unchanged.
5101
5102 =cut
5103 */
5104
5105 OP *
5106 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
5107 {
5108     if (!first)
5109         return last;
5110
5111     if (!last)
5112         return first;
5113
5114     if (first->op_type != (unsigned)type
5115         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
5116     {
5117         return newLISTOP(type, 0, first, last);
5118     }
5119
5120     op_sibling_splice(first, cLISTOPx(first)->op_last, 0, last);
5121     first->op_flags |= OPf_KIDS;
5122     return first;
5123 }
5124
5125 /*
5126 =for apidoc op_append_list
5127
5128 Concatenate the lists of ops contained directly within two list-type ops,
5129 returning the combined list.  C<first> and C<last> are the list-type ops
5130 to concatenate.  C<optype> specifies the intended opcode for the list.
5131 If either C<first> or C<last> is not already a list of the right type,
5132 it will be upgraded into one.  If either C<first> or C<last> is null,
5133 the other is returned unchanged.
5134
5135 =cut
5136 */
5137
5138 OP *
5139 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
5140 {
5141     if (!first)
5142         return last;
5143
5144     if (!last)
5145         return first;
5146
5147     if (first->op_type != (unsigned)type)
5148         return op_prepend_elem(type, first, last);
5149
5150     if (last->op_type != (unsigned)type)
5151         return op_append_elem(type, first, last);
5152
5153     OpMORESIB_set(cLISTOPx(first)->op_last, cLISTOPx(last)->op_first);
5154     cLISTOPx(first)->op_last = cLISTOPx(last)->op_last;
5155     OpLASTSIB_set(cLISTOPx(first)->op_last, first);
5156     first->op_flags |= (last->op_flags & OPf_KIDS);
5157
5158     S_op_destroy(aTHX_ last);
5159
5160     return first;
5161 }
5162
5163 /*
5164 =for apidoc op_prepend_elem
5165
5166 Prepend an item to the list of ops contained directly within a list-type
5167 op, returning the lengthened list.  C<first> is the op to prepend to the
5168 list, and C<last> is the list-type op.  C<optype> specifies the intended
5169 opcode for the list.  If C<last> is not already a list of the right type,
5170 it will be upgraded into one.  If either C<first> or C<last> is null,
5171 the other is returned unchanged.
5172
5173 =cut
5174 */
5175
5176 OP *
5177 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
5178 {
5179     if (!first)
5180         return last;
5181
5182     if (!last)
5183         return first;
5184
5185     if (last->op_type == (unsigned)type) {
5186         if (type == OP_LIST) {  /* already a PUSHMARK there */
5187             /* insert 'first' after pushmark */
5188             op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
5189             if (!(first->op_flags & OPf_PARENS))
5190                 last->op_flags &= ~OPf_PARENS;
5191         }
5192         else
5193             op_sibling_splice(last, NULL, 0, first);
5194         last->op_flags |= OPf_KIDS;
5195         return last;
5196     }
5197
5198     return newLISTOP(type, 0, first, last);
5199 }
5200
5201 /*
5202 =for apidoc op_convert_list
5203
5204 Converts C<o> into a list op if it is not one already, and then converts it
5205 into the specified C<type>, calling its check function, allocating a target if
5206 it needs one, and folding constants.
5207
5208 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
5209 C<op_prepend_elem> and C<op_append_elem>.  Then finally it is passed to
5210 C<op_convert_list> to make it the right type.
5211
5212 =cut
5213 */
5214
5215 OP *
5216 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
5217 {
5218     if (type < 0) type = -type, flags |= OPf_SPECIAL;
5219     if (!o || o->op_type != OP_LIST)
5220         o = force_list(o, FALSE);
5221     else
5222     {
5223         o->op_flags &= ~OPf_WANT;
5224         o->op_private &= ~OPpLVAL_INTRO;
5225     }
5226
5227     if (!(PL_opargs[type] & OA_MARK))
5228         op_null(cLISTOPo->op_first);
5229     else {
5230         OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
5231         if (kid2 && kid2->op_type == OP_COREARGS) {
5232             op_null(cLISTOPo->op_first);
5233             kid2->op_private |= OPpCOREARGS_PUSHMARK;
5234         }
5235     }
5236
5237     if (type != OP_SPLIT)
5238         /* At this point o is a LISTOP, but OP_SPLIT is a PMOP; let
5239          * ck_split() create a real PMOP and leave the op's type as listop
5240          * for now. Otherwise op_free() etc will crash.
5241          */
5242         OpTYPE_set(o, type);
5243
5244     o->op_flags |= flags;
5245     if (flags & OPf_FOLDED)
5246         o->op_folded = 1;
5247
5248     o = CHECKOP(type, o);
5249     if (o->op_type != (unsigned)type)
5250         return o;
5251
5252     return fold_constants(op_integerize(op_std_init(o)));
5253 }
5254
5255 /* Constructors */
5256
5257
5258 /*
5259 =for apidoc_section $optree_construction
5260
5261 =for apidoc newNULLLIST
5262
5263 Constructs, checks, and returns a new C<stub> op, which represents an
5264 empty list expression.
5265
5266 =cut
5267 */
5268
5269 OP *
5270 Perl_newNULLLIST(pTHX)
5271 {
5272     return newOP(OP_STUB, 0);
5273 }
5274
5275 /* promote o and any siblings to be a list if its not already; i.e.
5276  *
5277  *  o - A - B
5278  *
5279  * becomes
5280  *
5281  *  list
5282  *    |
5283  *  pushmark - o - A - B
5284  *
5285  * If nullit it true, the list op is nulled.
5286  */
5287
5288 static OP *
5289 S_force_list(pTHX_ OP *o, bool nullit)
5290 {
5291     if (!o || o->op_type != OP_LIST) {
5292         OP *rest = NULL;
5293         if (o) {
5294             /* manually detach any siblings then add them back later */
5295             rest = OpSIBLING(o);
5296             OpLASTSIB_set(o, NULL);
5297         }
5298         o = newLISTOP(OP_LIST, 0, o, NULL);
5299         if (rest)
5300             op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
5301     }
5302     if (nullit)
5303         op_null(o);
5304     return o;
5305 }
5306
5307 /*
5308 =for apidoc newLISTOP
5309
5310 Constructs, checks, and returns an op of any list type.  C<type> is
5311 the opcode.  C<flags> gives the eight bits of C<op_flags>, except that
5312 C<OPf_KIDS> will be set automatically if required.  C<first> and C<last>
5313 supply up to two ops to be direct children of the list op; they are
5314 consumed by this function and become part of the constructed op tree.
5315
5316 For most list operators, the check function expects all the kid ops to be
5317 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
5318 appropriate.  What you want to do in that case is create an op of type
5319 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
5320 See L</op_convert_list> for more information.
5321
5322
5323 =cut
5324 */
5325
5326 OP *
5327 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
5328 {
5329     LISTOP *listop;
5330     /* Note that allocating an OP_PUSHMARK can die under Safe.pm if
5331      * pushmark is banned. So do it now while existing ops are in a
5332      * consistent state, in case they suddenly get freed */
5333     OP* const pushop = type == OP_LIST ? newOP(OP_PUSHMARK, 0) : NULL;
5334
5335     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
5336         || type == OP_CUSTOM);
5337
5338     NewOp(1101, listop, 1, LISTOP);
5339     OpTYPE_set(listop, type);
5340     if (first || last)
5341         flags |= OPf_KIDS;
5342     listop->op_flags = (U8)flags;
5343
5344     if (!last && first)
5345         last = first;
5346     else if (!first && last)
5347         first = last;
5348     else if (first)
5349         OpMORESIB_set(first, last);
5350     listop->op_first = first;
5351     listop->op_last = last;
5352
5353     if (pushop) {
5354         OpMORESIB_set(pushop, first);
5355         listop->op_first = pushop;
5356         listop->op_flags |= OPf_KIDS;
5357         if (!last)
5358             listop->op_last = pushop;
5359     }
5360     if (listop->op_last)
5361         OpLASTSIB_set(listop->op_last, (OP*)listop);
5362
5363     return CHECKOP(type, listop);
5364 }
5365
5366 /*
5367 =for apidoc newOP
5368
5369 Constructs, checks, and returns an op of any base type (any type that
5370 has no extra fields).  C<type> is the opcode.  C<flags> gives the
5371 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
5372 of C<op_private>.
5373
5374 =cut
5375 */
5376
5377 OP *
5378 Perl_newOP(pTHX_ I32 type, I32 flags)
5379 {
5380     OP *o;
5381
5382     if (type == -OP_ENTEREVAL) {
5383         type = OP_ENTEREVAL;
5384         flags |= OPpEVAL_BYTES<<8;
5385     }
5386
5387     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
5388         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
5389         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5390         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5391
5392     NewOp(1101, o, 1, OP);
5393     OpTYPE_set(o, type);
5394     o->op_flags = (U8)flags;
5395
5396     o->op_next = o;
5397     o->op_private = (U8)(0 | (flags >> 8));
5398     if (PL_opargs[type] & OA_RETSCALAR)
5399         scalar(o);
5400     if (PL_opargs[type] & OA_TARGET)
5401         o->op_targ = pad_alloc(type, SVs_PADTMP);
5402     return CHECKOP(type, o);
5403 }
5404
5405 /*
5406 =for apidoc newUNOP
5407
5408 Constructs, checks, and returns an op of any unary type.  C<type> is
5409 the opcode.  C<flags> gives the eight bits of C<op_flags>, except that
5410 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
5411 bits, the eight bits of C<op_private>, except that the bit with value 1
5412 is automatically set.  C<first> supplies an optional op to be the direct
5413 child of the unary op; it is consumed by this function and become part
5414 of the constructed op tree.
5415
5416 =for apidoc Amnh||OPf_KIDS
5417
5418 =cut
5419 */
5420
5421 OP *
5422 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
5423 {
5424     UNOP *unop;
5425
5426     if (type == -OP_ENTEREVAL) {
5427         type = OP_ENTEREVAL;
5428         flags |= OPpEVAL_BYTES<<8;
5429     }
5430
5431     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
5432         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
5433         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5434         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
5435         || type == OP_SASSIGN
5436         || type == OP_ENTERTRY
5437         || type == OP_ENTERTRYCATCH
5438         || type == OP_CUSTOM
5439         || type == OP_NULL );
5440
5441     if (!first)
5442         first = newOP(OP_STUB, 0);
5443     if (PL_opargs[type] & OA_MARK)
5444         first = force_list(first, TRUE);
5445
5446     NewOp(1101, unop, 1, UNOP);
5447     OpTYPE_set(unop, type);
5448     unop->op_first = first;
5449     unop->op_flags = (U8)(flags | OPf_KIDS);
5450     unop->op_private = (U8)(1 | (flags >> 8));
5451
5452     if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
5453         OpLASTSIB_set(first, (OP*)unop);
5454
5455     unop = (UNOP*) CHECKOP(type, unop);
5456     if (unop->op_next)
5457         return (OP*)unop;
5458
5459     return fold_constants(op_integerize(op_std_init((OP *) unop)));
5460 }
5461
5462 /*
5463 =for apidoc newUNOP_AUX
5464
5465 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
5466 initialised to C<aux>
5467
5468 =cut
5469 */
5470
5471 OP *
5472 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
5473 {
5474     UNOP_AUX *unop;
5475
5476     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
5477         || type == OP_CUSTOM);
5478
5479     NewOp(1101, unop, 1, UNOP_AUX);
5480     unop->op_type = (OPCODE)type;
5481     unop->op_ppaddr = PL_ppaddr[type];
5482     unop->op_first = first;
5483     unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
5484     unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
5485     unop->op_aux = aux;
5486
5487     if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
5488         OpLASTSIB_set(first, (OP*)unop);
5489
5490     unop = (UNOP_AUX*) CHECKOP(type, unop);
5491
5492     return op_std_init((OP *) unop);
5493 }
5494
5495 /*
5496 =for apidoc newMETHOP
5497
5498 Constructs, checks, and returns an op of method type with a method name
5499 evaluated at runtime.  C<type> is the opcode.  C<flags> gives the eight
5500 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
5501 and, shifted up eight bits, the eight bits of C<op_private>, except that
5502 the bit with value 1 is automatically set.  C<dynamic_meth> supplies an
5503 op which evaluates method name; it is consumed by this function and
5504 become part of the constructed op tree.
5505 Supported optypes: C<OP_METHOD>.
5506
5507 =cut
5508 */
5509
5510 static OP*
5511 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
5512     METHOP *methop;
5513
5514     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
5515         || type == OP_CUSTOM);
5516
5517     NewOp(1101, methop, 1, METHOP);
5518     if (dynamic_meth) {
5519         if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, TRUE);
5520         methop->op_flags = (U8)(flags | OPf_KIDS);
5521         methop->op_u.op_first = dynamic_meth;
5522         methop->op_private = (U8)(1 | (flags >> 8));
5523
5524         if (!OpHAS_SIBLING(dynamic_meth))
5525             OpLASTSIB_set(dynamic_meth, (OP*)methop);
5526     }
5527     else {
5528         assert(const_meth);
5529         methop->op_flags = (U8)(flags & ~OPf_KIDS);
5530         methop->op_u.op_meth_sv = const_meth;
5531         methop->op_private = (U8)(0 | (flags >> 8));
5532         methop->op_next = (OP*)methop;
5533     }
5534
5535 #ifdef USE_ITHREADS
5536     methop->op_rclass_targ = 0;
5537 #else
5538     methop->op_rclass_sv = NULL;
5539 #endif
5540
5541     OpTYPE_set(methop, type);
5542     return CHECKOP(type, methop);
5543 }
5544
5545 OP *
5546 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
5547     PERL_ARGS_ASSERT_NEWMETHOP;
5548     return newMETHOP_internal(type, flags, dynamic_meth, NULL);
5549 }
5550
5551 /*
5552 =for apidoc newMETHOP_named
5553
5554 Constructs, checks, and returns an op of method type with a constant
5555 method name.  C<type> is the opcode.  C<flags> gives the eight bits of
5556 C<op_flags>, and, shifted up eight bits, the eight bits of
5557 C<op_private>.  C<const_meth> supplies a constant method name;
5558 it must be a shared COW string.
5559 Supported optypes: C<OP_METHOD_NAMED>.
5560
5561 =cut
5562 */
5563
5564 OP *
5565 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
5566     PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
5567     return newMETHOP_internal(type, flags, NULL, const_meth);
5568 }
5569
5570 /*
5571 =for apidoc newBINOP
5572
5573 Constructs, checks, and returns an op of any binary type.  C<type>
5574 is the opcode.  C<flags> gives the eight bits of C<op_flags>, except
5575 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
5576 the eight bits of C<op_private>, except that the bit with value 1 or
5577 2 is automatically set as required.  C<first> and C<last> supply up to
5578 two ops to be the direct children of the binary op; they are consumed
5579 by this function and become part of the constructed op tree.
5580
5581 =cut
5582 */
5583
5584 OP *
5585 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
5586 {
5587     BINOP *binop;
5588
5589     ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
5590         || type == OP_NULL || type == OP_CUSTOM);
5591
5592     NewOp(1101, binop, 1, BINOP);
5593
5594     if (!first)
5595         first = newOP(OP_NULL, 0);
5596
5597     OpTYPE_set(binop, type);
5598     binop->op_first = first;
5599     binop->op_flags = (U8)(flags | OPf_KIDS);
5600     if (!last) {
5601         last = first;
5602         binop->op_private = (U8)(1 | (flags >> 8));
5603     }
5604     else {
5605         binop->op_private = (U8)(2 | (flags >> 8));
5606         OpMORESIB_set(first, last);
5607     }
5608
5609     if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
5610         OpLASTSIB_set(last, (OP*)binop);
5611
5612     binop->op_last = OpSIBLING(binop->op_first);
5613     if (binop->op_last)
5614         OpLASTSIB_set(binop->op_last, (OP*)binop);
5615
5616     binop = (BINOP*) CHECKOP(type, binop);
5617     if (binop->op_next || binop->op_type != (OPCODE)type)
5618         return (OP*)binop;
5619
5620     return fold_constants(op_integerize(op_std_init((OP *)binop)));
5621 }
5622
5623 void
5624 Perl_invmap_dump(pTHX_ SV* invlist, UV *map)
5625 {
5626     const char indent[] = "    ";
5627
5628     UV len = _invlist_len(invlist);
5629     UV * array = invlist_array(invlist);
5630     UV i;
5631
5632     PERL_ARGS_ASSERT_INVMAP_DUMP;
5633
5634     for (i = 0; i < len; i++) {
5635         UV start = array[i];
5636         UV end   = (i + 1 < len) ? array[i+1] - 1 : IV_MAX;
5637
5638         PerlIO_printf(Perl_debug_log, "%s[%" UVuf "] 0x%04" UVXf, indent, i, start);
5639         if (end == IV_MAX) {
5640             PerlIO_printf(Perl_debug_log, " .. INFTY");
5641         }
5642         else if (end != start) {
5643             PerlIO_printf(Perl_debug_log, " .. 0x%04" UVXf, end);
5644         }
5645         else {
5646             PerlIO_printf(Perl_debug_log, "            ");
5647         }
5648
5649         PerlIO_printf(Perl_debug_log, "\t");
5650
5651         if (map[i] == TR_UNLISTED) {
5652             PerlIO_printf(Perl_debug_log, "TR_UNLISTED\n");
5653         }
5654         else if (map[i] == TR_SPECIAL_HANDLING) {
5655             PerlIO_printf(Perl_debug_log, "TR_SPECIAL_HANDLING\n");
5656         }
5657         else {
5658             PerlIO_printf(Perl_debug_log, "0x%04" UVXf "\n", map[i]);
5659         }
5660     }
5661 }
5662
5663 /* Given an OP_TRANS / OP_TRANSR op o, plus OP_CONST ops expr and repl
5664  * containing the search and replacement strings, assemble into
5665  * a translation table attached as o->op_pv.
5666  * Free expr and repl.
5667  * It expects the toker to have already set the
5668  *   OPpTRANS_COMPLEMENT
5669  *   OPpTRANS_SQUASH
5670  *   OPpTRANS_DELETE
5671  * flags as appropriate; this function may add
5672  *   OPpTRANS_USE_SVOP
5673  *   OPpTRANS_CAN_FORCE_UTF8
5674  *   OPpTRANS_IDENTICAL
5675  *   OPpTRANS_GROWS
5676  * flags
5677  */
5678
5679 static OP *
5680 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
5681 {
5682     /* This function compiles a tr///, from data gathered from toke.c, into a
5683      * form suitable for use by do_trans() in doop.c at runtime.
5684      *
5685      * It first normalizes the data, while discarding extraneous inputs; then
5686      * writes out the compiled data.  The normalization allows for complete
5687      * analysis, and avoids some false negatives and positives earlier versions
5688      * of this code had.
5689      *
5690      * The normalization form is an inversion map (described below in detail).
5691      * This is essentially the compiled form for tr///'s that require UTF-8,
5692      * and its easy to use it to write the 257-byte table for tr///'s that
5693      * don't need UTF-8.  That table is identical to what's been in use for
5694      * many perl versions, except that it doesn't handle some edge cases that
5695      * it used to, involving code points above 255.  The UTF-8 form now handles
5696      * these.  (This could be changed with extra coding should it shown to be
5697      * desirable.)
5698      *
5699      * If the complement (/c) option is specified, the lhs string (tstr) is
5700      * parsed into an inversion list.  Complementing these is trivial.  Then a
5701      * complemented tstr is built from that, and used thenceforth.  This hides
5702      * the fact that it was complemented from almost all successive code.
5703      *
5704      * One of the important characteristics to know about the input is whether
5705      * the transliteration may be done in place, or does a temporary need to be
5706      * allocated, then copied.  If the replacement for every character in every
5707      * possible string takes up no more bytes than the character it
5708      * replaces, then it can be edited in place.  Otherwise the replacement
5709      * could overwrite a byte we are about to read, depending on the strings
5710      * being processed.  The comments and variable names here refer to this as
5711      * "growing".  Some inputs won't grow, and might even shrink under /d, but
5712      * some inputs could grow, so we have to assume any given one might grow.
5713      * On very long inputs, the temporary could eat up a lot of memory, so we
5714      * want to avoid it if possible.  For non-UTF-8 inputs, everything is
5715      * single-byte, so can be edited in place, unless there is something in the
5716      * pattern that could force it into UTF-8.  The inversion map makes it
5717      * feasible to determine this.  Previous versions of this code pretty much
5718      * punted on determining if UTF-8 could be edited in place.  Now, this code
5719      * is rigorous in making that determination.
5720      *
5721      * Another characteristic we need to know is whether the lhs and rhs are
5722      * identical.  If so, and no other flags are present, the only effect of
5723      * the tr/// is to count the characters present in the input that are
5724      * mentioned in the lhs string.  The implementation of that is easier and
5725      * runs faster than the more general case.  Normalizing here allows for
5726      * accurate determination of this.  Previously there were false negatives
5727      * possible.
5728      *
5729      * Instead of 'transliterated', the comments here use 'unmapped' for the
5730      * characters that are left unchanged by the operation; otherwise they are
5731      * 'mapped'
5732      *
5733      * The lhs of the tr/// is here referred to as the t side.
5734      * The rhs of the tr/// is here referred to as the r side.
5735      */
5736
5737     SV * const tstr = cSVOPx(expr)->op_sv;
5738     SV * const rstr = cSVOPx(repl)->op_sv;
5739     STRLEN tlen;
5740     STRLEN rlen;
5741     const U8 * t0 = (U8*)SvPV_const(tstr, tlen);
5742     const U8 * r0 = (U8*)SvPV_const(rstr, rlen);
5743     const U8 * t = t0;
5744     const U8 * r = r0;
5745     UV t_count = 0, r_count = 0;  /* Number of characters in search and
5746                                          replacement lists */
5747
5748     /* khw thinks some of the private flags for this op are quaintly named.
5749      * OPpTRANS_GROWS for example is TRUE if the replacement for some lhs
5750      * character when represented in UTF-8 is longer than the original
5751      * character's UTF-8 representation */
5752     const bool complement = cBOOL(o->op_private & OPpTRANS_COMPLEMENT);
5753     const bool squash     = cBOOL(o->op_private & OPpTRANS_SQUASH);
5754     const bool del        = cBOOL(o->op_private & OPpTRANS_DELETE);
5755
5756     /* Set to true if there is some character < 256 in the lhs that maps to
5757      * above 255.  If so, a non-UTF-8 match string can be forced into being in
5758      * UTF-8 by a tr/// operation. */
5759     bool can_force_utf8 = FALSE;
5760
5761     /* What is the maximum expansion factor in UTF-8 transliterations.  If a
5762      * 2-byte UTF-8 encoded character is to be replaced by a 3-byte one, its
5763      * expansion factor is 1.5.  This number is used at runtime to calculate
5764      * how much space to allocate for non-inplace transliterations.  Without
5765      * this number, the worst case is 14, which is extremely unlikely to happen
5766      * in real life, and could require significant memory overhead. */
5767     NV max_expansion = 1.;
5768
5769     UV t_range_count, r_range_count, min_range_count;
5770     UV* t_array;
5771     SV* t_invlist;
5772     UV* r_map;
5773     UV r_cp = 0, t_cp = 0;
5774     UV t_cp_end = (UV) -1;
5775     UV r_cp_end;
5776     Size_t len;
5777     AV* invmap;
5778     UV final_map = TR_UNLISTED;    /* The final character in the replacement
5779                                       list, updated as we go along.  Initialize
5780                                       to something illegal */
5781
5782     bool rstr_utf8 = cBOOL(SvUTF8(rstr));
5783     bool tstr_utf8 = cBOOL(SvUTF8(tstr));
5784
5785     const U8* tend = t + tlen;
5786     const U8* rend = r + rlen;
5787
5788     SV * inverted_tstr = NULL;
5789
5790     Size_t i;
5791     unsigned int pass2;
5792
5793     /* This routine implements detection of a transliteration having a longer
5794      * UTF-8 representation than its source, by partitioning all the possible
5795      * code points of the platform into equivalence classes of the same UTF-8
5796      * byte length in the first pass.  As it constructs the mappings, it carves
5797      * these up into smaller chunks, but doesn't merge any together.  This
5798      * makes it easy to find the instances it's looking for.  A second pass is
5799      * done after this has been determined which merges things together to
5800      * shrink the table for runtime.  The table below is used for both ASCII
5801      * and EBCDIC platforms.  On EBCDIC, the byte length is not monotonically
5802      * increasing for code points below 256.  To correct for that, the macro
5803      * CP_ADJUST defined below converts those code points to ASCII in the first
5804      * pass, and we use the ASCII partition values.  That works because the
5805      * growth factor will be unaffected, which is all that is calculated during
5806      * the first pass. */
5807     UV PL_partition_by_byte_length[] = {
5808         0,
5809         0x80,   /* Below this is 1 byte representations */
5810         (32 * (1UL << (    UTF_ACCUMULATION_SHIFT))),   /* 2 bytes below this */
5811         (16 * (1UL << (2 * UTF_ACCUMULATION_SHIFT))),   /* 3 bytes below this */
5812         ( 8 * (1UL << (3 * UTF_ACCUMULATION_SHIFT))),   /* 4 bytes below this */
5813         ( 4 * (1UL << (4 * UTF_ACCUMULATION_SHIFT))),   /* 5 bytes below this */
5814         ( 2 * (1UL << (5 * UTF_ACCUMULATION_SHIFT)))    /* 6 bytes below this */
5815
5816 #  ifdef UV_IS_QUAD
5817                                                     ,
5818         ( ((UV) 1U << (6 * UTF_ACCUMULATION_SHIFT)))    /* 7 bytes below this */
5819 #  endif
5820
5821     };
5822
5823     PERL_ARGS_ASSERT_PMTRANS;
5824
5825     PL_hints |= HINT_BLOCK_SCOPE;
5826
5827     /* If /c, the search list is sorted and complemented.  This is now done by
5828      * creating an inversion list from it, and then trivially inverting that.
5829      * The previous implementation used qsort, but creating the list
5830      * automatically keeps it sorted as we go along */
5831     if (complement) {
5832         UV start, end;
5833         SV * inverted_tlist = _new_invlist(tlen);
5834         Size_t temp_len;
5835
5836         DEBUG_y(PerlIO_printf(Perl_debug_log,
5837                     "%s: %d: tstr before inversion=\n%s\n",
5838                     __FILE__, __LINE__, _byte_dump_string(t, tend - t, 0)));
5839
5840         while (t < tend) {
5841
5842             /* Non-utf8 strings don't have ranges, so each character is listed
5843              * out */
5844             if (! tstr_utf8) {
5845                 inverted_tlist = add_cp_to_invlist(inverted_tlist, *t);
5846                 t++;
5847             }
5848             else {  /* But UTF-8 strings have been parsed in toke.c to have
5849                  * ranges if appropriate. */
5850                 UV t_cp;
5851                 Size_t t_char_len;
5852
5853                 /* Get the first character */
5854                 t_cp = valid_utf8_to_uvchr(t, &t_char_len);
5855                 t += t_char_len;
5856
5857                 /* If the next byte indicates that this wasn't the first
5858                  * element of a range, the range is just this one */
5859                 if (t >= tend || *t != RANGE_INDICATOR) {
5860                     inverted_tlist = add_cp_to_invlist(inverted_tlist, t_cp);
5861                 }
5862                 else { /* Otherwise, ignore the indicator byte, and get the
5863                           final element, and add the whole range */
5864                     t++;
5865                     t_cp_end = valid_utf8_to_uvchr(t, &t_char_len);
5866                     t += t_char_len;
5867
5868                     inverted_tlist = _add_range_to_invlist(inverted_tlist,
5869                                                       t_cp, t_cp_end);
5870                 }
5871             }
5872         } /* End of parse through tstr */
5873
5874         /* The inversion list is done; now invert it */
5875         _invlist_invert(inverted_tlist);
5876
5877         /* Now go through the inverted list and create a new tstr for the rest
5878          * of the routine to use.  Since the UTF-8 version can have ranges, and
5879          * can be much more compact than the non-UTF-8 version, we create the
5880          * string in UTF-8 even if not necessary.  (This is just an intermediate
5881          * value that gets thrown away anyway.) */
5882         invlist_iterinit(inverted_tlist);
5883         inverted_tstr = newSVpvs("");
5884         while (invlist_iternext(inverted_tlist, &start, &end)) {
5885             U8 temp[UTF8_MAXBYTES];
5886             U8 * temp_end_pos;
5887
5888             /* IV_MAX keeps things from going out of bounds */
5889             start = MIN(IV_MAX, start);
5890             end   = MIN(IV_MAX, end);
5891
5892             temp_end_pos = uvchr_to_utf8(temp, start);
5893             sv_catpvn(inverted_tstr, (char *) temp, temp_end_pos - temp);
5894
5895             if (start != end) {
5896                 Perl_sv_catpvf(aTHX_ inverted_tstr, "%c", RANGE_INDICATOR);
5897                 temp_end_pos = uvchr_to_utf8(temp, end);
5898                 sv_catpvn(inverted_tstr, (char *) temp, temp_end_pos - temp);
5899             }
5900         }
5901
5902         /* Set up so the remainder of the routine uses this complement, instead
5903          * of the actual input */
5904         t0 = t = (U8*)SvPV_const(inverted_tstr, temp_len);
5905         tend = t0 + temp_len;
5906         tstr_utf8 = TRUE;
5907
5908         SvREFCNT_dec_NN(inverted_tlist);
5909     }
5910
5911     /* For non-/d, an empty rhs means to use the lhs */
5912     if (rlen == 0 && ! del) {
5913         r0 = t0;
5914         rend = tend;
5915         rstr_utf8  = tstr_utf8;
5916     }
5917
5918     t_invlist = _new_invlist(1);
5919
5920     /* Initialize to a single range */
5921     t_invlist = _add_range_to_invlist(t_invlist, 0, UV_MAX);
5922
5923     /* Below, we parse the (potentially adjusted) input, creating the inversion
5924      * map.  This is done in two passes.  The first pass is just to determine
5925      * if the transliteration can be done in-place.  It can be done in place if
5926      * no possible inputs result in the replacement taking up more bytes than
5927      * the input.  To figure that out, in the first pass we start with all the
5928      * possible code points partitioned into ranges so that every code point in
5929      * a range occupies the same number of UTF-8 bytes as every other code
5930      * point in the range.  Constructing the inversion map doesn't merge ranges
5931      * together, but can split them into multiple ones.  Given the starting
5932      * partition, the ending state will also have the same characteristic,
5933      * namely that each code point in each partition requires the same number
5934      * of UTF-8 bytes to represent as every other code point in the same
5935      * partition.
5936      *
5937      * This partioning has been pre-compiled.  Copy it to initialize */
5938     len = C_ARRAY_LENGTH(PL_partition_by_byte_length);
5939     invlist_extend(t_invlist, len);
5940     t_array = invlist_array(t_invlist);
5941     Copy(PL_partition_by_byte_length, t_array, len, UV);
5942     invlist_set_len(t_invlist, len, *(get_invlist_offset_addr(t_invlist)));
5943     Newx(r_map, len + 1, UV);
5944
5945     /* The inversion map the first pass creates could be used as-is, but
5946      * generally would be larger and slower to run than the output of the
5947      * second pass.  */
5948
5949     for (pass2 = 0; pass2 < 2; pass2++) {
5950         if (pass2) {
5951             /* In the second pass, we start with a single range */
5952             t_invlist = _add_range_to_invlist(t_invlist, 0, UV_MAX);
5953             len = 1;
5954             t_array = invlist_array(t_invlist);
5955         }
5956
5957 /* As noted earlier, we convert EBCDIC code points to Unicode in the first pass
5958  * so as to get the well-behaved length 1 vs length 2 boundary.  Only code
5959  * points below 256 differ between the two character sets in this regard.  For
5960  * these, we also can't have any ranges, as they have to be individually
5961  * converted. */
5962 #ifdef EBCDIC
5963 #  define CP_ADJUST(x)          ((pass2) ? (x) : NATIVE_TO_UNI(x))
5964 #  define FORCE_RANGE_LEN_1(x)  ((pass2) ? 0 : ((x) < 256))
5965 #  define CP_SKIP(x)            ((pass2) ? UVCHR_SKIP(x) : OFFUNISKIP(x))
5966 #else
5967 #  define CP_ADJUST(x)          (x)
5968 #  define FORCE_RANGE_LEN_1(x)  0
5969 #  define CP_SKIP(x)            UVCHR_SKIP(x)
5970 #endif
5971
5972         /* And the mapping of each of the ranges is initialized.  Initially,
5973          * everything is TR_UNLISTED. */
5974         for (i = 0; i < len; i++) {
5975             r_map[i] = TR_UNLISTED;
5976         }
5977
5978         t = t0;
5979         t_count = 0;
5980         r = r0;
5981         r_count = 0;
5982         t_range_count = r_range_count = 0;
5983
5984         DEBUG_y(PerlIO_printf(Perl_debug_log, "%s: %d:\ntstr=%s\n",
5985                     __FILE__, __LINE__, _byte_dump_string(t, tend - t, 0)));
5986         DEBUG_y(PerlIO_printf(Perl_debug_log, "rstr=%s\n",
5987                                         _byte_dump_string(r, rend - r, 0)));
5988         DEBUG_y(PerlIO_printf(Perl_debug_log, "/c=%d; /s=%d; /d=%d\n",
5989                                                   complement, squash, del));
5990         DEBUG_y(invmap_dump(t_invlist, r_map));
5991
5992         /* Now go through the search list constructing an inversion map.  The
5993          * input is not necessarily in any particular order.  Making it an
5994          * inversion map orders it, potentially simplifying, and makes it easy
5995          * to deal with at run time.  This is the only place in core that
5996          * generates an inversion map; if others were introduced, it might be
5997          * better to create general purpose routines to handle them.
5998          * (Inversion maps are created in perl in other places.)
5999          *
6000          * An inversion map consists of two parallel arrays.  One is
6001          * essentially an inversion list: an ordered list of code points such
6002          * that each element gives the first code point of a range of
6003          * consecutive code points that map to the element in the other array
6004          * that has the same index as this one (in other words, the
6005          * corresponding element).  Thus the range extends up to (but not
6006          * including) the code point given by the next higher element.  In a
6007          * true inversion map, the corresponding element in the other array
6008          * gives the mapping of the first code point in the range, with the
6009          * understanding that the next higher code point in the inversion
6010          * list's range will map to the next higher code point in the map.
6011          *
6012          * So if at element [i], let's say we have:
6013          *
6014          *     t_invlist  r_map
6015          * [i]    A         a
6016          *
6017          * This means that A => a, B => b, C => c....  Let's say that the
6018          * situation is such that:
6019          *
6020          * [i+1]  L        -1
6021          *
6022          * This means the sequence that started at [i] stops at K => k.  This
6023          * illustrates that you need to look at the next element to find where
6024          * a sequence stops.  Except, the highest element in the inversion list
6025          * begins a range that is understood to extend to the platform's
6026          * infinity.
6027          *
6028          * This routine modifies traditional inversion maps to reserve two
6029          * mappings:
6030          *
6031          *  TR_UNLISTED (or -1) indicates that no code point in the range
6032          *      is listed in the tr/// searchlist.  At runtime, these are
6033          *      always passed through unchanged.  In the inversion map, all
6034          *      points in the range are mapped to -1, instead of increasing,
6035          *      like the 'L' in the example above.
6036          *
6037          *      We start the parse with every code point mapped to this, and as
6038          *      we parse and find ones that are listed in the search list, we
6039          *      carve out ranges as we go along that override that.
6040          *
6041          *  TR_SPECIAL_HANDLING (or -2) indicates that every code point in the
6042          *      range needs special handling.  Again, all code points in the
6043          *      range are mapped to -2, instead of increasing.
6044          *
6045          *      Under /d this value means the code point should be deleted from
6046          *      the transliteration when encountered.
6047          *
6048          *      Otherwise, it marks that every code point in the range is to
6049          *      map to the final character in the replacement list.  This
6050          *      happens only when the replacement list is shorter than the
6051          *      search one, so there are things in the search list that have no
6052          *      correspondence in the replacement list.  For example, in
6053          *      tr/a-z/A/, 'A' is the final value, and the inversion map
6054          *      generated for this would be like this:
6055          *          \0  =>  -1
6056          *          a   =>   A
6057          *          b-z =>  -2
6058          *          z+1 =>  -1
6059          *      'A' appears once, then the remainder of the range maps to -2.
6060          *      The use of -2 isn't strictly necessary, as an inversion map is
6061          *      capable of representing this situation, but not nearly so
6062          *      compactly, and this is actually quite commonly encountered.
6063          *      Indeed, the original design of this code used a full inversion
6064          *      map for this.  But things like
6065          *          tr/\0-\x{FFFF}/A/
6066          *      generated huge data structures, slowly, and the execution was
6067          *      also slow.  So the current scheme was implemented.
6068          *
6069          *  So, if the next element in our example is:
6070          *
6071          * [i+2]  Q        q
6072          *
6073          * Then all of L, M, N, O, and P map to TR_UNLISTED.  If the next
6074          * elements are
6075          *
6076          * [i+3]  R        z
6077          * [i+4]  S       TR_UNLISTED
6078          *
6079          * Then Q => q; R => z; and S => TR_UNLISTED.  If [i+4] (the 'S') is
6080          * the final element in the arrays, every code point from S to infinity
6081          * maps to TR_UNLISTED.
6082          *
6083          */
6084                            /* Finish up range started in what otherwise would
6085                             * have been the final iteration */
6086         while (t < tend || t_range_count > 0) {
6087             bool adjacent_to_range_above = FALSE;
6088             bool adjacent_to_range_below = FALSE;
6089
6090             bool merge_with_range_above = FALSE;
6091             bool merge_with_range_below = FALSE;
6092
6093             UV span, invmap_range_length_remaining;
6094             SSize_t j;
6095             Size_t i;
6096
6097             /* If we are in the middle of processing a range in the 'target'
6098              * side, the previous iteration has set us up.  Otherwise, look at
6099              * the next character in the search list */
6100             if (t_range_count <= 0) {
6101                 if (! tstr_utf8) {
6102
6103                     /* Here, not in the middle of a range, and not UTF-8.  The
6104                      * next code point is the single byte where we're at */
6105                     t_cp = CP_ADJUST(*t);
6106                     t_range_count = 1;
6107                     t++;
6108                 }
6109                 else {
6110                     Size_t t_char_len;
6111
6112                     /* Here, not in the middle of a range, and is UTF-8.  The
6113                      * next code point is the next UTF-8 char in the input.  We
6114                      * know the input is valid, because the toker constructed
6115                      * it */
6116                     t_cp = CP_ADJUST(valid_utf8_to_uvchr(t, &t_char_len));
6117                     t += t_char_len;
6118
6119                     /* UTF-8 strings (only) have been parsed in toke.c to have
6120                      * ranges.  See if the next byte indicates that this was
6121                      * the first element of a range.  If so, get the final
6122                      * element and calculate the range size.  If not, the range
6123                      * size is 1 */
6124                     if (   t < tend && *t == RANGE_INDICATOR
6125                         && ! FORCE_RANGE_LEN_1(t_cp))
6126                     {
6127                         t++;
6128                         t_range_count = valid_utf8_to_uvchr(t, &t_char_len)
6129                                       - t_cp + 1;
6130                         t += t_char_len;
6131                     }
6132                     else {
6133                         t_range_count = 1;
6134                     }
6135                 }
6136
6137                 /* Count the total number of listed code points * */
6138                 t_count += t_range_count;
6139             }
6140
6141             /* Similarly, get the next character in the replacement list */
6142             if (r_range_count <= 0) {
6143                 if (r >= rend) {
6144
6145                     /* But if we've exhausted the rhs, there is nothing to map
6146                      * to, except the special handling one, and we make the
6147                      * range the same size as the lhs one. */
6148                     r_cp = TR_SPECIAL_HANDLING;
6149                     r_range_count = t_range_count;
6150
6151                     if (! del) {
6152                         DEBUG_yv(PerlIO_printf(Perl_debug_log,
6153                                         "final_map =%" UVXf "\n", final_map));
6154                     }
6155                 }
6156                 else {
6157                     if (! rstr_utf8) {
6158                         r_cp = CP_ADJUST(*r);
6159                         r_range_count = 1;
6160                         r++;
6161                     }
6162                     else {
6163                         Size_t r_char_len;
6164
6165                         r_cp = CP_ADJUST(valid_utf8_to_uvchr(r, &r_char_len));
6166                         r += r_char_len;
6167                         if (   r < rend && *r == RANGE_INDICATOR
6168                             && ! FORCE_RANGE_LEN_1(r_cp))
6169                         {
6170                             r++;
6171                             r_range_count = valid_utf8_to_uvchr(r,
6172                                                     &r_char_len) - r_cp + 1;
6173                             r += r_char_len;
6174                         }
6175                         else {
6176                             r_range_count = 1;
6177                         }
6178                     }
6179
6180                     if (r_cp == TR_SPECIAL_HANDLING) {
6181                         r_range_count = t_range_count;
6182                     }
6183
6184                     /* This is the final character so far */
6185                     final_map = r_cp + r_range_count - 1;
6186
6187                     r_count += r_range_count;
6188                 }
6189             }
6190
6191             /* Here, we have the next things ready in both sides.  They are
6192              * potentially ranges.  We try to process as big a chunk as
6193              * possible at once, but the lhs and rhs must be synchronized, so
6194              * things like tr/A-Z/a-ij-z/ will need to be processed in 2 chunks
6195              * */
6196             min_range_count = MIN(t_range_count, r_range_count);
6197
6198             /* Search the inversion list for the entry that contains the input
6199              * code point <cp>.  The inversion map was initialized to cover the
6200              * entire range of possible inputs, so this should not fail.  So
6201              * the return value is the index into the list's array of the range
6202              * that contains <cp>, that is, 'i' such that array[i] <= cp <
6203              * array[i+1] */
6204             j = _invlist_search(t_invlist, t_cp);
6205             assert(j >= 0);
6206             i = j;
6207
6208             /* Here, the data structure might look like:
6209              *
6210              * index    t   r     Meaning
6211              * [i-1]    J   j   # J-L => j-l
6212              * [i]      M  -1   # M => default; as do N, O, P, Q
6213              * [i+1]    R   x   # R => x, S => x+1, T => x+2
6214              * [i+2]    U   y   # U => y, V => y+1, ...
6215              * ...
6216              * [-1]     Z  -1   # Z => default; as do Z+1, ... infinity
6217              *
6218              * where 'x' and 'y' above are not to be taken literally.
6219              *
6220              * The maximum chunk we can handle in this loop iteration, is the
6221              * smallest of the three components: the lhs 't_', the rhs 'r_',
6222              * and the remainder of the range in element [i].  (In pass 1, that
6223              * range will have everything in it be of the same class; we can't
6224              * cross into another class.)  'min_range_count' already contains
6225              * the smallest of the first two values.  The final one is
6226              * irrelevant if the map is to the special indicator */
6227
6228             invmap_range_length_remaining = (i + 1 < len)
6229                                             ? t_array[i+1] - t_cp
6230                                             : IV_MAX - t_cp;
6231             span = MAX(1, MIN(min_range_count, invmap_range_length_remaining));
6232
6233             /* The end point of this chunk is where we are, plus the span, but
6234              * never larger than the platform's infinity */
6235             t_cp_end = MIN(IV_MAX, t_cp + span - 1);
6236
6237             if (r_cp == TR_SPECIAL_HANDLING) {
6238
6239                 /* If unmatched lhs code points map to the final map, use that
6240                  * value.  This being set to TR_SPECIAL_HANDLING indicates that
6241                  * we don't have a final map: unmatched lhs code points are
6242                  * simply deleted */
6243                 r_cp_end = (del) ? TR_SPECIAL_HANDLING : final_map;
6244             }
6245             else {
6246                 r_cp_end = MIN(IV_MAX, r_cp + span - 1);
6247
6248                 /* If something on the lhs is below 256, and something on the
6249                  * rhs is above, there is a potential mapping here across that
6250                  * boundary.  Indeed the only way there isn't is if both sides
6251                  * start at the same point.  That means they both cross at the
6252                  * same time.  But otherwise one crosses before the other */
6253                 if (t_cp < 256 && r_cp_end > 255 && r_cp != t_cp) {
6254                     can_force_utf8 = TRUE;
6255                 }
6256             }
6257
6258             /* If a character appears in the search list more than once, the
6259              * 2nd and succeeding occurrences are ignored, so only do this
6260              * range if haven't already processed this character.  (The range
6261              * has been set up so that all members in it will be of the same
6262              * ilk) */
6263             if (r_map[i] == TR_UNLISTED) {
6264                 DEBUG_yv(PerlIO_printf(Perl_debug_log,
6265                     "Processing %" UVxf "-%" UVxf " => %" UVxf "-%" UVxf "\n",
6266                     t_cp, t_cp_end, r_cp, r_cp_end));
6267
6268                 /* This is the first definition for this chunk, hence is valid
6269                  * and needs to be processed.  Here and in the comments below,
6270                  * we use the above sample data.  The t_cp chunk must be any
6271                  * contiguous subset of M, N, O, P, and/or Q.
6272                  *
6273                  * In the first pass, calculate if there is any possible input
6274                  * string that has a character whose transliteration will be
6275                  * longer than it.  If none, the transliteration may be done
6276                  * in-place, as it can't write over a so-far unread byte.
6277                  * Otherwise, a copy must first be made.  This could be
6278                  * expensive for long inputs.
6279                  *
6280                  * In the first pass, the t_invlist has been partitioned so
6281                  * that all elements in any single range have the same number
6282                  * of bytes in their UTF-8 representations.  And the r space is
6283                  * either a single byte, or a range of strictly monotonically
6284                  * increasing code points.  So the final element in the range
6285                  * will be represented by no fewer bytes than the initial one.
6286                  * That means that if the final code point in the t range has
6287                  * at least as many bytes as the final code point in the r,
6288                  * then all code points in the t range have at least as many
6289                  * bytes as their corresponding r range element.  But if that's
6290                  * not true, the transliteration of at least the final code
6291                  * point grows in length.  As an example, suppose we had
6292                  *      tr/\x{fff0}-\x{fff1}/\x{ffff}-\x{10000}/
6293                  * The UTF-8 for all but 10000 occupies 3 bytes on ASCII
6294                  * platforms.  We have deliberately set up the data structure
6295                  * so that any range in the lhs gets split into chunks for
6296                  * processing, such that every code point in a chunk has the
6297                  * same number of UTF-8 bytes.  We only have to check the final
6298                  * code point in the rhs against any code point in the lhs. */
6299                 if ( ! pass2
6300                     && r_cp_end != TR_SPECIAL_HANDLING
6301                     && CP_SKIP(t_cp_end) < CP_SKIP(r_cp_end))
6302                 {
6303                     /* Here, we will need to make a copy of the input string
6304                      * before doing the transliteration.  The worst possible
6305                      * case is an expansion ratio of 14:1. This is rare, and
6306                      * we'd rather allocate only the necessary amount of extra
6307                      * memory for that copy.  We can calculate the worst case
6308                      * for this particular transliteration is by keeping track
6309                      * of the expansion factor for each range.
6310                      *
6311                      * Consider tr/\xCB/\X{E000}/.  The maximum expansion
6312                      * factor is 1 byte going to 3 if the target string is not
6313                      * UTF-8, but 2 bytes going to 3 if it is in UTF-8.  We
6314                      * could pass two different values so doop could choose
6315                      * based on the UTF-8ness of the target.  But khw thinks
6316                      * (perhaps wrongly) that is overkill.  It is used only to
6317                      * make sure we malloc enough space.
6318                      *
6319                      * If no target string can force the result to be UTF-8,
6320                      * then we don't have to worry about the case of the target
6321                      * string not being UTF-8 */
6322                     NV t_size = (can_force_utf8 && t_cp < 256)
6323                                 ? 1
6324                                 : CP_SKIP(t_cp_end);
6325                     NV ratio = CP_SKIP(r_cp_end) / t_size;
6326
6327                     o->op_private |= OPpTRANS_GROWS;
6328
6329                     /* Now that we know it grows, we can keep track of the
6330                      * largest ratio */
6331                     if (ratio > max_expansion) {
6332                         max_expansion = ratio;
6333                         DEBUG_y(PerlIO_printf(Perl_debug_log,
6334                                         "New expansion factor: %" NVgf "\n",
6335                                         max_expansion));
6336                     }
6337                 }
6338
6339                 /* The very first range is marked as adjacent to the
6340                  * non-existent range below it, as it causes things to "just
6341                  * work" (TradeMark)
6342                  *
6343                  * If the lowest code point in this chunk is M, it adjoins the
6344                  * J-L range */
6345                 if (t_cp == t_array[i]) {
6346                     adjacent_to_range_below = TRUE;
6347
6348                     /* And if the map has the same offset from the beginning of
6349                      * the range as does this new code point (or both are for
6350                      * TR_SPECIAL_HANDLING), this chunk can be completely
6351                      * merged with the range below.  EXCEPT, in the first pass,
6352                      * we don't merge ranges whose UTF-8 byte representations
6353                      * have different lengths, so that we can more easily
6354                      * detect if a replacement is longer than the source, that
6355                      * is if it 'grows'.  But in the 2nd pass, there's no
6356                      * reason to not merge */
6357                     if (   (i > 0 && (   pass2
6358                                       || CP_SKIP(t_array[i-1])
6359                                                             == CP_SKIP(t_cp)))
6360                         && (   (   r_cp == TR_SPECIAL_HANDLING
6361                                 && r_map[i-1] == TR_SPECIAL_HANDLING)
6362                             || (   r_cp != TR_SPECIAL_HANDLING
6363                                 && r_cp - r_map[i-1] == t_cp - t_array[i-1])))
6364                     {
6365                         merge_with_range_below = TRUE;
6366                     }
6367                 }
6368
6369                 /* Similarly, if the highest code point in this chunk is 'Q',
6370                  * it adjoins the range above, and if the map is suitable, can
6371                  * be merged with it */
6372                 if (    t_cp_end >= IV_MAX - 1
6373                     || (   i + 1 < len
6374                         && t_cp_end + 1 == t_array[i+1]))
6375                 {
6376                     adjacent_to_range_above = TRUE;
6377                     if (i + 1 < len)
6378                     if (    (   pass2
6379                              || CP_SKIP(t_cp) == CP_SKIP(t_array[i+1]))
6380                         && (   (   r_cp == TR_SPECIAL_HANDLING
6381                                 && r_map[i+1] == (UV) TR_SPECIAL_HANDLING)
6382                             || (   r_cp != TR_SPECIAL_HANDLING
6383                                 && r_cp_end == r_map[i+1] - 1)))
6384                     {
6385                         merge_with_range_above = TRUE;
6386                     }
6387                 }
6388
6389                 if (merge_with_range_below && merge_with_range_above) {
6390
6391                     /* Here the new chunk looks like M => m, ... Q => q; and
6392                      * the range above is like R => r, ....  Thus, the [i-1]
6393                      * and [i+1] ranges should be seamlessly melded so the
6394                      * result looks like
6395                      *
6396                      * [i-1]    J   j   # J-T => j-t
6397                      * [i]      U   y   # U => y, V => y+1, ...
6398                      * ...
6399                      * [-1]     Z  -1   # Z => default; as do Z+1, ... infinity
6400                      */
6401                     Move(t_array + i + 2, t_array + i, len - i - 2, UV);
6402                     Move(r_map   + i + 2, r_map   + i, len - i - 2, UV);
6403                     len -= 2;
6404                     invlist_set_len(t_invlist,
6405                                     len,
6406                                     *(get_invlist_offset_addr(t_invlist)));
6407                 }
6408                 else if (merge_with_range_below) {
6409
6410                     /* Here the new chunk looks like M => m, .... But either
6411                      * (or both) it doesn't extend all the way up through Q; or
6412                      * the range above doesn't start with R => r. */
6413                     if (! adjacent_to_range_above) {
6414
6415                         /* In the first case, let's say the new chunk extends
6416                          * through O.  We then want:
6417                          *
6418                          * [i-1]    J   j   # J-O => j-o
6419                          * [i]      P  -1   # P => -1, Q => -1
6420                          * [i+1]    R   x   # R => x, S => x+1, T => x+2
6421                          * [i+2]    U   y   # U => y, V => y+1, ...
6422                          * ...
6423                          * [-1]     Z  -1   # Z => default; as do Z+1, ...
6424                          *                                            infinity
6425                          */
6426                         t_array[i] = t_cp_end + 1;
6427                         r_map[i] = TR_UNLISTED;
6428                     }
6429                     else { /* Adjoins the range above, but can't merge with it
6430                               (because 'x' is not the next map after q) */
6431                         /*
6432                          * [i-1]    J   j   # J-Q => j-q
6433                          * [i]      R   x   # R => x, S => x+1, T => x+2
6434                          * [i+1]    U   y   # U => y, V => y+1, ...
6435                          * ...
6436                          * [-1]     Z  -1   # Z => default; as do Z+1, ...
6437                          *                                          infinity
6438                          */
6439
6440                         Move(t_array + i + 1, t_array + i, len - i - 1, UV);
6441                         Move(r_map + i + 1, r_map + i, len - i - 1, UV);
6442                         len--;
6443                         invlist_set_len(t_invlist, len,
6444                                         *(get_invlist_offset_addr(t_invlist)));
6445                     }
6446                 }
6447                 else if (merge_with_range_above) {
6448
6449                     /* Here the new chunk ends with Q => q, and the range above
6450                      * must start with R => r, so the two can be merged. But
6451                      * either (or both) the new chunk doesn't extend all the
6452                      * way down to M; or the mapping of the final code point
6453                      * range below isn't m */
6454                     if (! adjacent_to_range_below) {
6455
6456                         /* In the first case, let's assume the new chunk starts
6457                          * with P => p.  Then, because it's merge-able with the
6458                          * range above, that range must be R => r.  We want:
6459                          *
6460                          * [i-1]    J   j   # J-L => j-l
6461                          * [i]      M  -1   # M => -1, N => -1
6462                          * [i+1]    P   p   # P-T => p-t
6463                          * [i+2]    U   y   # U => y, V => y+1, ...
6464                          * ...
6465                          * [-1]     Z  -1   # Z => default; as do Z+1, ...
6466                          *                                          infinity
6467                          */
6468                         t_array[i+1] = t_cp;
6469                         r_map[i+1] = r_cp;
6470                     }
6471                     else { /* Adjoins the range below, but can't merge with it
6472                             */
6473                         /*
6474                          * [i-1]    J   j   # J-L => j-l
6475                          * [i]      M   x   # M-T => x-5 .. x+2
6476                          * [i+1]    U   y   # U => y, V => y+1, ...
6477                          * ...
6478                          * [-1]     Z  -1   # Z => default; as do Z+1, ...
6479                          *                                          infinity
6480                          */
6481                         Move(t_array + i + 1, t_array + i, len - i - 1, UV);
6482                         Move(r_map   + i + 1, r_map   + i, len - i - 1, UV);
6483                         len--;
6484                         t_array[i] = t_cp;
6485                         r_map[i] = r_cp;
6486                         invlist_set_len(t_invlist, len,
6487                                         *(get_invlist_offset_addr(t_invlist)));
6488                     }
6489                 }
6490                 else if (adjacent_to_range_below && adjacent_to_range_above) {
6491                     /* The new chunk completely fills the gap between the
6492                      * ranges on either side, but can't merge with either of
6493                      * them.
6494                      *
6495                      * [i-1]    J   j   # J-L => j-l
6496                      * [i]      M   z   # M => z, N => z+1 ... Q => z+4
6497                      * [i+1]    R   x   # R => x, S => x+1, T => x+2
6498                      * [i+2]    U   y   # U => y, V => y+1, ...
6499                      * ...
6500                      * [-1]     Z  -1   # Z => default; as do Z+1, ... infinity
6501                      */
6502                     r_map[i] = r_cp;
6503                 }
6504                 else if (adjacent_to_range_below) {
6505                     /* The new chunk adjoins the range below, but not the range
6506                      * above, and can't merge.  Let's assume the chunk ends at
6507                      * O.
6508                      *
6509                      * [i-1]    J   j   # J-L => j-l
6510                      * [i]      M   z   # M => z, N => z+1, O => z+2
6511                      * [i+1]    P   -1  # P => -1, Q => -1
6512                      * [i+2]    R   x   # R => x, S => x+1, T => x+2
6513                      * [i+3]    U   y   # U => y, V => y+1, ...
6514                      * ...
6515                      * [-w]     Z  -1   # Z => default; as do Z+1, ... infinity
6516                      */
6517                     invlist_extend(t_invlist, len + 1);
6518                     t_array = invlist_array(t_invlist);
6519                     Renew(r_map, len + 1, UV);
6520
6521                     Move(t_array + i + 1, t_array + i + 2, len - i - 1, UV);
6522                     Move(r_map + i + 1,   r_map   + i + 2, len - i - 1, UV);
6523                     r_map[i] = r_cp;
6524                     t_array[i+1] = t_cp_end + 1;
6525                     r_map[i+1] = TR_UNLISTED;
6526                     len++;
6527                     invlist_set_len(t_invlist, len,
6528                                     *(get_invlist_offset_addr(t_invlist)));
6529                 }
6530                 else if (adjacent_to_range_above) {
6531                     /* The new chunk adjoins the range above, but not the range
6532                      * below, and can't merge.  Let's assume the new chunk
6533                      * starts at O
6534                      *
6535                      * [i-1]    J   j   # J-L => j-l
6536                      * [i]      M  -1   # M => default, N => default
6537                      * [i+1]    O   z   # O => z, P => z+1, Q => z+2
6538                      * [i+2]    R   x   # R => x, S => x+1, T => x+2
6539                      * [i+3]    U   y   # U => y, V => y+1, ...
6540                      * ...
6541                      * [-1]     Z  -1   # Z => default; as do Z+1, ... infinity
6542                      */
6543                     invlist_extend(t_invlist, len + 1);
6544                     t_array = invlist_array(t_invlist);
6545                     Renew(r_map, len + 1, UV);
6546
6547                     Move(t_array + i + 1, t_array + i + 2, len - i - 1, UV);
6548                     Move(r_map   + i + 1, r_map   + i + 2, len - i - 1, UV);
6549                     t_array[i+1] = t_cp;
6550                     r_map[i+1] = r_cp;
6551                     len++;
6552                     invlist_set_len(t_invlist, len,
6553                                     *(get_invlist_offset_addr(t_invlist)));
6554                 }
6555                 else {
6556                     /* The new chunk adjoins neither the range above, nor the
6557                      * range below.  Lets assume it is N..P => n..p
6558                      *
6559                      * [i-1]    J   j   # J-L => j-l
6560                      * [i]      M  -1   # M => default
6561                      * [i+1]    N   n   # N..P => n..p
6562                      * [i+2]    Q  -1   # Q => default
6563                      * [i+3]    R   x   # R => x, S => x+1, T => x+2
6564                      * [i+4]    U   y   # U => y, V => y+1, ...
6565                      * ...
6566                      * [-1]     Z  -1   # Z => default; as do Z+1, ... infinity
6567                      */
6568
6569                     DEBUG_yv(PerlIO_printf(Perl_debug_log,
6570                                         "Before fixing up: len=%d, i=%d\n",
6571                                         (int) len, (int) i));
6572                     DEBUG_yv(invmap_dump(t_invlist, r_map));
6573
6574                     invlist_extend(t_invlist, len + 2);
6575                     t_array = invlist_array(t_invlist);
6576                     Renew(r_map, len + 2, UV);
6577
6578                     Move(t_array + i + 1,
6579                          t_array + i + 2 + 1, len - i - (2 - 1), UV);
6580                     Move(r_map   + i + 1,
6581                          r_map   + i + 2 + 1, len - i - (2 - 1), UV);
6582
6583                     len += 2;
6584                     invlist_set_len(t_invlist, len,
6585                                     *(get_invlist_offset_addr(t_invlist)));
6586
6587                     t_array[i+1] = t_cp;
6588                     r_map[i+1] = r_cp;
6589
6590                     t_array[i+2] = t_cp_end + 1;
6591                     r_map[i+2] = TR_UNLISTED;
6592                 }
6593                 DEBUG_yv(PerlIO_printf(Perl_debug_log,
6594                           "After iteration: span=%" UVuf ", t_range_count=%"
6595                           UVuf " r_range_count=%" UVuf "\n",
6596                           span, t_range_count, r_range_count));
6597                 DEBUG_yv(invmap_dump(t_invlist, r_map));
6598             } /* End of this chunk needs to be processed */
6599
6600             /* Done with this chunk. */
6601             t_cp += span;
6602             if (t_cp >= IV_MAX) {
6603                 break;
6604             }
6605             t_range_count -= span;
6606             if (r_cp != TR_SPECIAL_HANDLING) {
6607                 r_cp += span;
6608                 r_range_count -= span;
6609             }
6610             else {
6611                 r_range_count = 0;
6612             }
6613
6614         } /* End of loop through the search list */
6615
6616         /* We don't need an exact count, but we do need to know if there is
6617          * anything left over in the replacement list.  So, just assume it's
6618          * one byte per character */
6619         if (rend > r) {
6620             r_count++;
6621         }
6622     } /* End of passes */
6623
6624     SvREFCNT_dec(inverted_tstr);
6625
6626     DEBUG_y(PerlIO_printf(Perl_debug_log, "After everything: \n"));
6627     DEBUG_y(invmap_dump(t_invlist, r_map));
6628
6629     /* We now have normalized the input into an inversion map.
6630      *
6631      * See if the lhs and rhs are equivalent.  If so, this tr/// is a no-op
6632      * except for the count, and streamlined runtime code can be used */
6633     if (!del && !squash) {
6634
6635         /* They are identical if they point to the same address, or if
6636          * everything maps to UNLISTED or to itself.  This catches things that
6637          * not looking at the normalized inversion map doesn't catch, like
6638          * tr/aa/ab/ or tr/\x{100}-\x{104}/\x{100}-\x{102}\x{103}-\x{104}  */
6639         if (r0 != t0) {
6640             for (i = 0; i < len; i++) {
6641                 if (r_map[i] != TR_UNLISTED && r_map[i] != t_array[i]) {
6642                     goto done_identical_check;
6643                 }
6644             }
6645         }
6646
6647         /* Here have gone through entire list, and didn't find any
6648          * non-identical mappings */
6649         o->op_private |= OPpTRANS_IDENTICAL;
6650
6651       done_identical_check: ;
6652     }
6653
6654     t_array = invlist_array(t_invlist);
6655
6656     /* If has components above 255, we generally need to use the inversion map
6657      * implementation */
6658     if (   can_force_utf8
6659         || (   len > 0
6660             && t_array[len-1] > 255
6661                  /* If the final range is 0x100-INFINITY and is a special
6662                   * mapping, the table implementation can handle it */
6663             && ! (   t_array[len-1] == 256
6664                   && (   r_map[len-1] == TR_UNLISTED
6665                       || r_map[len-1] == TR_SPECIAL_HANDLING))))
6666     {
6667         SV* r_map_sv;
6668         SV* temp_sv;
6669
6670         /* A UTF-8 op is generated, indicated by this flag.  This op is an
6671          * sv_op */
6672         o->op_private |= OPpTRANS_USE_SVOP;
6673
6674         if (can_force_utf8) {
6675             o->op_private |= OPpTRANS_CAN_FORCE_UTF8;
6676         }
6677
6678         /* The inversion map is pushed; first the list. */
6679         invmap = MUTABLE_AV(newAV());
6680
6681         SvREADONLY_on(t_invlist);
6682         av_push(invmap, t_invlist);
6683
6684         /* 2nd is the mapping */
6685         r_map_sv = newSVpvn((char *) r_map, len * sizeof(UV));
6686         SvREADONLY_on(r_map_sv);
6687         av_push(invmap, r_map_sv);
6688
6689         /* 3rd is the max possible expansion factor */
6690         temp_sv = newSVnv(max_expansion);
6691         SvREADONLY_on(temp_sv);
6692         av_push(invmap, temp_sv);
6693
6694         /* Characters that are in the search list, but not in the replacement
6695          * list are mapped to the final character in the replacement list */
6696         if (! del && r_count < t_count) {
6697             temp_sv = newSVuv(final_map);
6698             SvREADONLY_on(temp_sv);
6699             av_push(invmap, temp_sv);
6700         }
6701
6702 #ifdef USE_ITHREADS
6703         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
6704         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
6705         PAD_SETSV(cPADOPo->op_padix, (SV *) invmap);
6706         SvPADTMP_on(invmap);
6707         SvREADONLY_on(invmap);
6708 #else
6709         cSVOPo->op_sv = (SV *) invmap;
6710 #endif
6711
6712     }
6713     else {
6714         OPtrans_map *tbl;
6715         unsigned short i;
6716
6717         /* The OPtrans_map struct already contains one slot; hence the -1. */
6718         SSize_t struct_size = sizeof(OPtrans_map)
6719                             + (256 - 1 + 1)*sizeof(short);
6720
6721         /* Non-utf8 case: set o->op_pv to point to a simple 256+ entry lookup
6722          * table. Entries with the value TR_UNMAPPED indicate chars not to be
6723          * translated, while TR_DELETE indicates a search char without a
6724          * corresponding replacement char under /d.
6725          *
6726          * In addition, an extra slot at the end is used to store the final
6727          * repeating char, or TR_R_EMPTY under an empty replacement list, or
6728          * TR_DELETE under /d; which makes the runtime code easier. */
6729
6730         /* Indicate this is an op_pv */
6731         o->op_private &= ~OPpTRANS_USE_SVOP;
6732
6733         tbl = (OPtrans_map*)PerlMemShared_calloc(struct_size, 1);
6734         tbl->size = 256;
6735         cPVOPo->op_pv = (char*)tbl;
6736
6737         for (i = 0; i < len; i++) {
6738             STATIC_ASSERT_DECL(TR_SPECIAL_HANDLING == TR_DELETE);
6739             short upper = i >= len - 1 ? 256 : (short) t_array[i+1];
6740             short to = (short) r_map[i];
6741             short j;
6742             bool do_increment = TRUE;
6743
6744             /* Any code points above our limit should be irrelevant */
6745             if (t_array[i] >= tbl->size) break;
6746
6747             /* Set up the map */
6748             if (to == (short) TR_SPECIAL_HANDLING && ! del) {
6749                 to = (short) final_map;
6750                 do_increment = FALSE;
6751             }
6752             else if (to < 0) {
6753                 do_increment = FALSE;
6754             }
6755
6756             /* Create a map for everything in this range.  The value increases
6757              * except for the special cases */
6758             for (j = (short) t_array[i]; j < upper; j++) {
6759                 tbl->map[j] = to;
6760                 if (do_increment) to++;
6761             }
6762         }
6763
6764         tbl->map[tbl->size] = del
6765                               ? (short) TR_DELETE
6766                               : (short) rlen
6767                                 ? (short) final_map
6768                                 : (short) TR_R_EMPTY;
6769         DEBUG_y(PerlIO_printf(Perl_debug_log,"%s: %d\n", __FILE__, __LINE__));
6770         for (i = 0; i < tbl->size; i++) {
6771             if (tbl->map[i] < 0) {
6772                 DEBUG_y(PerlIO_printf(Perl_debug_log," %02x=>%d",
6773                                                 (unsigned) i, tbl->map[i]));
6774             }
6775             else {
6776                 DEBUG_y(PerlIO_printf(Perl_debug_log," %02x=>%02x",
6777                                                 (unsigned) i, tbl->map[i]));
6778             }
6779             if ((i+1) % 8 == 0 || i + 1 == (short) tbl->size) {
6780                 DEBUG_y(PerlIO_printf(Perl_debug_log,"\n"));
6781             }
6782         }
6783         DEBUG_y(PerlIO_printf(Perl_debug_log,"Final map 0x%x=>%02x\n",
6784                                 (unsigned) tbl->size, tbl->map[tbl->size]));
6785
6786         SvREFCNT_dec(t_invlist);
6787
6788 #if 0   /* code that added excess above-255 chars at the end of the table, in
6789            case we ever want to not use the inversion map implementation for
6790            this */
6791
6792         ASSUME(j <= rlen);
6793         excess = rlen - j;
6794
6795         if (excess) {
6796             /* More replacement chars than search chars:
6797              * store excess replacement chars at end of main table.
6798              */
6799
6800             struct_size += excess;
6801             tbl = (OPtrans_map*)PerlMemShared_realloc(tbl,
6802                         struct_size + excess * sizeof(short));
6803             tbl->size += excess;
6804             cPVOPo->op_pv = (char*)tbl;
6805
6806             for (i = 0; i < excess; i++)
6807                 tbl->map[i + 256] = r[j+i];
6808         }
6809         else {
6810             /* no more replacement chars than search chars */
6811         }
6812 #endif
6813
6814     }
6815
6816     DEBUG_y(PerlIO_printf(Perl_debug_log,
6817             "/d=%d, /s=%d, /c=%d, identical=%d, grows=%d,"
6818             " use_svop=%d, can_force_utf8=%d,\nexpansion=%" NVgf "\n",
6819             del, squash, complement,
6820             cBOOL(o->op_private & OPpTRANS_IDENTICAL),
6821             cBOOL(o->op_private & OPpTRANS_USE_SVOP),
6822             cBOOL(o->op_private & OPpTRANS_GROWS),
6823             cBOOL(o->op_private & OPpTRANS_CAN_FORCE_UTF8),
6824             max_expansion));
6825
6826     Safefree(r_map);
6827
6828     if(del && rlen != 0 && r_count == t_count) {
6829         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
6830     } else if(r_count > t_count) {
6831         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
6832     }
6833
6834     op_free(expr);
6835     op_free(repl);
6836
6837     return o;
6838 }
6839
6840
6841 /*
6842 =for apidoc newPMOP
6843
6844 Constructs, checks, and returns an op of any pattern matching type.
6845 C<type> is the opcode.  C<flags> gives the eight bits of C<op_flags>
6846 and, shifted up eight bits, the eight bits of C<op_private>.
6847
6848 =cut
6849 */
6850
6851 OP *
6852 Perl_newPMOP(pTHX_ I32 type, I32 flags)
6853 {
6854     PMOP *pmop;
6855
6856     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
6857         || type == OP_CUSTOM);
6858
6859     NewOp(1101, pmop, 1, PMOP);
6860     OpTYPE_set(pmop, type);
6861     pmop->op_flags = (U8)flags;
6862     pmop->op_private = (U8)(0 | (flags >> 8));
6863     if (PL_opargs[type] & OA_RETSCALAR)
6864         scalar((OP *)pmop);
6865
6866     if (PL_hints & HINT_RE_TAINT)
6867         pmop->op_pmflags |= PMf_RETAINT;
6868 #ifdef USE_LOCALE_CTYPE
6869     if (IN_LC_COMPILETIME(LC_CTYPE)) {
6870         set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
6871     }
6872     else
6873 #endif
6874          if (IN_UNI_8_BIT) {
6875         set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
6876     }
6877     if (PL_hints & HINT_RE_FLAGS) {
6878         SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
6879          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
6880         );
6881         if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
6882         reflags = Perl_refcounted_he_fetch_pvn(aTHX_
6883          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
6884         );
6885         if (reflags && SvOK(reflags)) {
6886             set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
6887         }
6888     }
6889
6890
6891 #ifdef USE_ITHREADS
6892     assert(SvPOK(PL_regex_pad[0]));
6893     if (SvCUR(PL_regex_pad[0])) {
6894         /* Pop off the "packed" IV from the end.  */
6895         SV *const repointer_list = PL_regex_pad[0];
6896         const char *p = SvEND(repointer_list) - sizeof(IV);
6897         const IV offset = *((IV*)p);
6898
6899         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
6900
6901         SvEND_set(repointer_list, p);
6902
6903         pmop->op_pmoffset = offset;
6904         /* This slot should be free, so assert this:  */
6905         assert(PL_regex_pad[offset] == &PL_sv_undef);
6906     } else {
6907         SV * const repointer = &PL_sv_undef;
6908         av_push(PL_regex_padav, repointer);
6909         pmop->op_pmoffset = av_top_index(PL_regex_padav);
6910         PL_regex_pad = AvARRAY(PL_regex_padav);
6911     }
6912 #endif
6913
6914     return CHECKOP(type, pmop);
6915 }
6916
6917 static void
6918 S_set_haseval(pTHX)
6919 {
6920     PADOFFSET i = 1;
6921     PL_cv_has_eval = 1;
6922     /* Any pad names in scope are potentially lvalues.  */
6923     for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
6924         PADNAME *pn = PAD_COMPNAME_SV(i);
6925         if (!pn || !PadnameLEN(pn))
6926             continue;
6927         if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
6928             S_mark_padname_lvalue(aTHX_ pn);
6929     }
6930 }
6931
6932 /* Given some sort of match op o, and an expression expr containing a
6933  * pattern, either compile expr into a regex and attach it to o (if it's
6934  * constant), or convert expr into a runtime regcomp op sequence (if it's
6935  * not)
6936  *
6937  * Flags currently has 2 bits of meaning:
6938  * 1: isreg indicates that the pattern is part of a regex construct, eg
6939  *      $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
6940  *      split "pattern", which aren't. In the former case, expr will be a list
6941  *      if the pattern contains more than one term (eg /a$b/).
6942  * 2: The pattern is for a split.
6943  *
6944  * When the pattern has been compiled within a new anon CV (for
6945  * qr/(?{...})/ ), then floor indicates the savestack level just before
6946  * the new sub was created
6947  *
6948  * tr/// is also handled.
6949  */
6950
6951 OP *
6952 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor)
6953 {
6954     PMOP *pm;
6955     LOGOP *rcop;
6956     I32 repl_has_vars = 0;
6957     bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
6958     bool is_compiletime;
6959     bool has_code;
6960     bool isreg    = cBOOL(flags & 1);
6961     bool is_split = cBOOL(flags & 2);
6962
6963     PERL_ARGS_ASSERT_PMRUNTIME;
6964
6965     if (is_trans) {
6966         return pmtrans(o, expr, repl);
6967     }
6968
6969     /* find whether we have any runtime or code elements;
6970      * at the same time, temporarily set the op_next of each DO block;
6971      * then when we LINKLIST, this will cause the DO blocks to be excluded
6972      * from the op_next chain (and from having LINKLIST recursively
6973      * applied to them). We fix up the DOs specially later */
6974
6975     is_compiletime = 1;
6976     has_code = 0;
6977     if (expr->op_type == OP_LIST) {
6978         OP *child;
6979         for (child = cLISTOPx(expr)->op_first; child; child = OpSIBLING(child)) {
6980             if (child->op_type == OP_NULL && (child->op_flags & OPf_SPECIAL)) {
6981                 has_code = 1;
6982                 assert(!child->op_next);
6983                 if (UNLIKELY(!OpHAS_SIBLING(child))) {
6984                     assert(PL_parser && PL_parser->error_count);
6985                     /* This can happen with qr/ (?{(^{})/.  Just fake up
6986                        the op we were expecting to see, to avoid crashing
6987                        elsewhere.  */
6988                     op_sibling_splice(expr, child, 0,
6989                               newSVOP(OP_CONST, 0, &PL_sv_no));
6990                 }
6991                 child->op_next = OpSIBLING(child);
6992             }
6993             else if (child->op_type != OP_CONST && child->op_type != OP_PUSHMARK)
6994             is_compiletime = 0;
6995         }
6996     }
6997     else if (expr->op_type != OP_CONST)
6998         is_compiletime = 0;
6999
7000     LINKLIST(expr);
7001
7002     /* fix up DO blocks; treat each one as a separate little sub;
7003      * also, mark any arrays as LIST/REF */
7004
7005     if (expr->op_type == OP_LIST) {
7006         OP *child;
7007         for (child = cLISTOPx(expr)->op_first; child; child = OpSIBLING(child)) {
7008
7009             if (child->op_type == OP_PADAV || child->op_type == OP_RV2AV) {
7010                 assert( !(child->op_flags  & OPf_WANT));
7011                 /* push the array rather than its contents. The regex
7012                  * engine will retrieve and join the elements later */
7013                 child->op_flags |= (OPf_WANT_LIST | OPf_REF);
7014                 continue;
7015             }
7016
7017             if (!(child->op_type == OP_NULL && (child->op_flags & OPf_SPECIAL)))
7018                 continue;
7019             child->op_next = NULL; /* undo temporary hack from above */
7020             scalar(child);
7021             LINKLIST(child);
7022             if (cLISTOPx(child)->op_first->op_type == OP_LEAVE) {
7023                 LISTOP *leaveop = cLISTOPx(cLISTOPx(child)->op_first);
7024                 /* skip ENTER */
7025                 assert(leaveop->op_first->op_type == OP_ENTER);
7026                 assert(OpHAS_SIBLING(leaveop->op_first));
7027                 child->op_next = OpSIBLING(leaveop->op_first);
7028                 /* skip leave */
7029                 assert(leaveop->op_flags & OPf_KIDS);
7030                 assert(leaveop->op_last->op_next == (OP*)leaveop);
7031                 leaveop->op_next = NULL; /* stop on last op */
7032                 op_null((OP*)leaveop);
7033             }
7034             else {
7035                 /* skip SCOPE */
7036                 OP *scope = cLISTOPx(child)->op_first;
7037                 assert(scope->op_type == OP_SCOPE);
7038                 assert(scope->op_flags & OPf_KIDS);
7039                 scope->op_next = NULL; /* stop on last op */
7040                 op_null(scope);
7041             }
7042
7043             /* XXX optimize_optree() must be called on o before
7044              * CALL_PEEP(), as currently S_maybe_multiconcat() can't
7045              * currently cope with a peephole-optimised optree.
7046              * Calling optimize_optree() here ensures that condition
7047              * is met, but may mean optimize_optree() is applied
7048              * to the same optree later (where hopefully it won't do any
7049              * harm as it can't convert an op to multiconcat if it's
7050              * already been converted */
7051             optimize_optree(child);
7052
7053             /* have to peep the DOs individually as we've removed it from
7054              * the op_next chain */
7055             CALL_PEEP(child);
7056             op_prune_chain_head(&(child->op_next));
7057             if (is_compiletime)
7058                 /* runtime finalizes as part of finalizing whole tree */
7059                 finalize_optree(child);
7060         }
7061     }
7062     else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
7063         assert( !(expr->op_flags  & OPf_WANT));
7064         /* push the array rather than its contents. The regex
7065          * engine will retrieve and join the elements later */
7066         expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
7067     }
7068
7069     PL_hints |= HINT_BLOCK_SCOPE;
7070     pm = cPMOPo;
7071     assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
7072
7073     if (is_compiletime) {
7074         U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
7075         regexp_engine const *eng = current_re_engine();
7076
7077         if (is_split) {
7078             /* make engine handle split ' ' specially */
7079             pm->op_pmflags |= PMf_SPLIT;
7080             rx_flags |= RXf_SPLIT;
7081         }
7082
7083         if (!has_code || !eng->op_comp) {
7084             /* compile-time simple constant pattern */
7085
7086             if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
7087                 /* whoops! we guessed that a qr// had a code block, but we
7088                  * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
7089                  * that isn't required now. Note that we have to be pretty
7090                  * confident that nothing used that CV's pad while the
7091                  * regex was parsed, except maybe op targets for \Q etc.
7092                  * If there were any op targets, though, they should have
7093                  * been stolen by constant folding.
7094                  */
7095 #ifdef DEBUGGING
7096                 SSize_t i = 0;
7097                 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
7098                 while (++i <= AvFILLp(PL_comppad)) {
7099 #  ifdef USE_PAD_RESET
7100                     /* under USE_PAD_RESET, pad swipe replaces a swiped
7101                      * folded constant with a fresh padtmp */
7102                     assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i]));
7103 #  else
7104                     assert(!PL_curpad[i]);
7105 #  endif
7106                 }
7107 #endif
7108                 /* This LEAVE_SCOPE will restore PL_compcv to point to the
7109                  * outer CV (the one whose slab holds the pm op). The
7110                  * inner CV (which holds expr) will be freed later, once
7111                  * all the entries on the parse stack have been popped on
7112                  * return from this function. Which is why its safe to
7113                  * call op_free(expr) below.
7114                  */
7115                 LEAVE_SCOPE(floor);
7116                 pm->op_pmflags &= ~PMf_HAS_CV;
7117             }
7118
7119             /* Skip compiling if parser found an error for this pattern */
7120             if (pm->op_pmflags & PMf_HAS_ERROR) {
7121                 return o;
7122             }
7123
7124             PM_SETRE(pm,
7125                 eng->op_comp
7126                     ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7127                                         rx_flags, pm->op_pmflags)
7128                     : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7129                                         rx_flags, pm->op_pmflags)
7130             );
7131             op_free(expr);
7132         }
7133         else {
7134             /* compile-time pattern that includes literal code blocks */
7135
7136             REGEXP* re;
7137
7138             /* Skip compiling if parser found an error for this pattern */
7139             if (pm->op_pmflags & PMf_HAS_ERROR) {
7140                 return o;
7141             }
7142
7143             re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7144                         rx_flags,
7145                         (pm->op_pmflags |
7146                             ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
7147                     );
7148             PM_SETRE(pm, re);
7149             if (pm->op_pmflags & PMf_HAS_CV) {
7150                 CV *cv;
7151                 /* this QR op (and the anon sub we embed it in) is never
7152                  * actually executed. It's just a placeholder where we can
7153                  * squirrel away expr in op_code_list without the peephole
7154                  * optimiser etc processing it for a second time */
7155                 OP *qr = newPMOP(OP_QR, 0);
7156                 cPMOPx(qr)->op_code_list = expr;
7157
7158                 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
7159                 SvREFCNT_inc_simple_void(PL_compcv);
7160                 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
7161                 ReANY(re)->qr_anoncv = cv;
7162
7163                 /* attach the anon CV to the pad so that
7164                  * pad_fixup_inner_anons() can find it */
7165                 (void)pad_add_anon(cv, o->op_type);
7166                 SvREFCNT_inc_simple_void(cv);
7167             }
7168             else {
7169                 pm->op_code_list = expr;
7170             }
7171         }
7172     }
7173     else {
7174         /* runtime pattern: build chain of regcomp etc ops */
7175         bool reglist;
7176         PADOFFSET cv_targ = 0;
7177
7178         reglist = isreg && expr->op_type == OP_LIST;
7179         if (reglist)
7180             op_null(expr);
7181
7182         if (has_code) {
7183             pm->op_code_list = expr;
7184             /* don't free op_code_list; its ops are embedded elsewhere too */
7185             pm->op_pmflags |= PMf_CODELIST_PRIVATE;
7186         }
7187
7188         if (is_split)
7189             /* make engine handle split ' ' specially */
7190             pm->op_pmflags |= PMf_SPLIT;
7191
7192         /* the OP_REGCMAYBE is a placeholder in the non-threaded case
7193          * to allow its op_next to be pointed past the regcomp and
7194          * preceding stacking ops;
7195          * OP_REGCRESET is there to reset taint before executing the
7196          * stacking ops */
7197         if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
7198             expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
7199
7200         if (pm->op_pmflags & PMf_HAS_CV) {
7201             /* we have a runtime qr with literal code. This means
7202              * that the qr// has been wrapped in a new CV, which
7203              * means that runtime consts, vars etc will have been compiled
7204              * against a new pad. So... we need to execute those ops
7205              * within the environment of the new CV. So wrap them in a call
7206              * to a new anon sub. i.e. for
7207              *
7208              *     qr/a$b(?{...})/,
7209              *
7210              * we build an anon sub that looks like
7211              *
7212              *     sub { "a", $b, '(?{...})' }
7213              *
7214              * and call it, passing the returned list to regcomp.
7215              * Or to put it another way, the list of ops that get executed
7216              * are:
7217              *
7218              *     normal              PMf_HAS_CV
7219              *     ------              -------------------
7220              *                         pushmark (for regcomp)
7221              *                         pushmark (for entersub)
7222              *                         anoncode
7223              *                         srefgen
7224              *                         entersub
7225              *     regcreset                  regcreset
7226              *     pushmark                   pushmark
7227              *     const("a")                 const("a")
7228              *     gvsv(b)                    gvsv(b)
7229              *     const("(?{...})")          const("(?{...})")
7230              *                                leavesub
7231              *     regcomp             regcomp
7232              */
7233
7234             SvREFCNT_inc_simple_void(PL_compcv);
7235             CvLVALUE_on(PL_compcv);
7236             /* these lines are just an unrolled newANONATTRSUB */
7237             expr = newSVOP(OP_ANONCODE, 0,
7238                     MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
7239             cv_targ = expr->op_targ;
7240             expr = newUNOP(OP_REFGEN, 0, expr);
7241
7242             expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), TRUE));
7243         }
7244
7245         rcop = alloc_LOGOP(OP_REGCOMP, scalar(expr), o);
7246         rcop->op_flags |=  ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
7247                            | (reglist ? OPf_STACKED : 0);
7248         rcop->op_targ = cv_targ;
7249
7250         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
7251         if (PL_hints & HINT_RE_EVAL)
7252             S_set_haseval(aTHX);
7253
7254         /* establish postfix order */
7255         if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
7256             LINKLIST(expr);
7257             rcop->op_next = expr;
7258             cUNOPx(expr)->op_first->op_next = (OP*)rcop;
7259         }
7260         else {
7261             rcop->op_next = LINKLIST(expr);
7262             expr->op_next = (OP*)rcop;
7263         }
7264
7265         op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
7266     }
7267
7268     if (repl) {
7269         OP *curop = repl;
7270         bool konst;
7271         /* If we are looking at s//.../e with a single statement, get past
7272            the implicit do{}. */
7273         if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
7274              && cUNOPx(curop)->op_first->op_type == OP_SCOPE
7275              && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
7276          {
7277             OP *sib;
7278             OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
7279             if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
7280              && !OpHAS_SIBLING(sib))
7281                 curop = sib;
7282         }
7283         if (curop->op_type == OP_CONST)
7284             konst = TRUE;
7285         else if (( (curop->op_type == OP_RV2SV ||
7286                     curop->op_type == OP_RV2AV ||
7287                     curop->op_type == OP_RV2HV ||
7288                     curop->op_type == OP_RV2GV)
7289                    && cUNOPx(curop)->op_first
7290                    && cUNOPx(curop)->op_first->op_type == OP_GV )
7291                 || curop->op_type == OP_PADSV
7292                 || curop->op_type == OP_PADAV
7293                 || curop->op_type == OP_PADHV
7294                 || curop->op_type == OP_PADANY) {
7295             repl_has_vars = 1;
7296             konst = TRUE;
7297         }
7298         else konst = FALSE;
7299         if (konst
7300             && !(repl_has_vars
7301                  && (!PM_GETRE(pm)
7302                      || !RX_PRELEN(PM_GETRE(pm))
7303                      || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
7304         {
7305             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
7306             op_prepend_elem(o->op_type, scalar(repl), o);
7307         }
7308         else {
7309             rcop = alloc_LOGOP(OP_SUBSTCONT, scalar(repl), o);
7310             rcop->op_private = 1;
7311
7312             /* establish postfix order */
7313             rcop->op_next = LINKLIST(repl);
7314             repl->op_next = (OP*)rcop;
7315
7316             pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
7317             assert(!(pm->op_pmflags & PMf_ONCE));
7318             pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
7319             rcop->op_next = 0;
7320         }
7321     }
7322
7323     return (OP*)pm;
7324 }
7325
7326 /*
7327 =for apidoc newSVOP
7328
7329 Constructs, checks, and returns an op of any type that involves an
7330 embedded SV.  C<type> is the opcode.  C<flags> gives the eight bits
7331 of C<op_flags>.  C<sv> gives the SV to embed in the op; this function
7332 takes ownership of one reference to it.
7333
7334 =cut
7335 */
7336
7337 OP *
7338 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
7339 {
7340     SVOP *svop;
7341
7342     PERL_ARGS_ASSERT_NEWSVOP;
7343
7344     /* OP_RUNCV is allowed specially so rpeep has room to convert it into an
7345      * OP_CONST */
7346     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
7347         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7348         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
7349         || type == OP_RUNCV
7350         || type == OP_CUSTOM);
7351
7352     NewOp(1101, svop, 1, SVOP);
7353     OpTYPE_set(svop, type);
7354     svop->op_sv = sv;
7355     svop->op_next = (OP*)svop;
7356     svop->op_flags = (U8)flags;
7357     svop->op_private = (U8)(0 | (flags >> 8));
7358     if (PL_opargs[type] & OA_RETSCALAR)
7359         scalar((OP*)svop);
7360     if (PL_opargs[type] & OA_TARGET)
7361         svop->op_targ = pad_alloc(type, SVs_PADTMP);
7362     return CHECKOP(type, svop);
7363 }
7364
7365 /*
7366 =for apidoc newDEFSVOP
7367
7368 Constructs and returns an op to access C<$_>.
7369
7370 =cut
7371 */
7372
7373 OP *
7374 Perl_newDEFSVOP(pTHX)
7375 {
7376         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
7377 }
7378
7379 #ifdef USE_ITHREADS
7380
7381 /*
7382 =for apidoc newPADOP
7383
7384 Constructs, checks, and returns an op of any type that involves a
7385 reference to a pad element.  C<type> is the opcode.  C<flags> gives the
7386 eight bits of C<op_flags>.  A pad slot is automatically allocated, and
7387 is populated with C<sv>; this function takes ownership of one reference
7388 to it.
7389
7390 This function only exists if Perl has been compiled to use ithreads.
7391
7392 =cut
7393 */
7394
7395 OP *
7396 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
7397 {
7398     PADOP *padop;
7399
7400     PERL_ARGS_ASSERT_NEWPADOP;
7401
7402     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
7403         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7404         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
7405         || type == OP_CUSTOM);
7406
7407     NewOp(1101, padop, 1, PADOP);
7408     OpTYPE_set(padop, type);
7409     padop->op_padix =
7410         pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
7411     SvREFCNT_dec(PAD_SVl(padop->op_padix));
7412     PAD_SETSV(padop->op_padix, sv);
7413     assert(sv);
7414     padop->op_next = (OP*)padop;
7415     padop->op_flags = (U8)flags;
7416     if (PL_opargs[type] & OA_RETSCALAR)
7417         scalar((OP*)padop);
7418     if (PL_opargs[type] & OA_TARGET)
7419         padop->op_targ = pad_alloc(type, SVs_PADTMP);
7420     return CHECKOP(type, padop);
7421 }
7422
7423 #endif /* USE_ITHREADS */
7424
7425 /*
7426 =for apidoc newGVOP
7427
7428 Constructs, checks, and returns an op of any type that involves an
7429 embedded reference to a GV.  C<type> is the opcode.  C<flags> gives the
7430 eight bits of C<op_flags>.  C<gv> identifies the GV that the op should
7431 reference; calling this function does not transfer ownership of any
7432 reference to it.
7433
7434 =cut
7435 */
7436
7437 OP *
7438 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
7439 {
7440     PERL_ARGS_ASSERT_NEWGVOP;
7441
7442 #ifdef USE_ITHREADS
7443     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
7444 #else
7445     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
7446 #endif
7447 }
7448
7449 /*
7450 =for apidoc newPVOP
7451
7452 Constructs, checks, and returns an op of any type that involves an
7453 embedded C-level pointer (PV).  C<type> is the opcode.  C<flags> gives
7454 the eight bits of C<op_flags>.  C<pv> supplies the C-level pointer.
7455 Depending on the op type, the memory referenced by C<pv> may be freed
7456 when the op is destroyed.  If the op is of a freeing type, C<pv> must
7457 have been allocated using C<PerlMemShared_malloc>.
7458
7459 =cut
7460 */
7461
7462 OP *
7463 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
7464 {
7465     const bool utf8 = cBOOL(flags & SVf_UTF8);
7466     PVOP *pvop;
7467
7468     flags &= ~SVf_UTF8;
7469
7470     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7471         || type == OP_CUSTOM
7472         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
7473
7474     NewOp(1101, pvop, 1, PVOP);
7475     OpTYPE_set(pvop, type);
7476     pvop->op_pv = pv;
7477     pvop->op_next = (OP*)pvop;
7478     pvop->op_flags = (U8)flags;
7479     pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
7480     if (PL_opargs[type] & OA_RETSCALAR)
7481         scalar((OP*)pvop);
7482     if (PL_opargs[type] & OA_TARGET)
7483         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
7484     return CHECKOP(type, pvop);
7485 }
7486
7487 void
7488 Perl_package(pTHX_ OP *o)
7489 {
7490     SV *const sv = cSVOPo->op_sv;
7491
7492     PERL_ARGS_ASSERT_PACKAGE;
7493
7494     SAVEGENERICSV(PL_curstash);
7495     save_item(PL_curstname);
7496
7497     PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
7498
7499     sv_setsv(PL_curstname, sv);
7500
7501     PL_hints |= HINT_BLOCK_SCOPE;
7502     PL_parser->copline = NOLINE;
7503
7504     op_free(o);
7505 }
7506
7507 void
7508 Perl_package_version( pTHX_ OP *v )
7509 {
7510     U32 savehints = PL_hints;
7511     PERL_ARGS_ASSERT_PACKAGE_VERSION;
7512     PL_hints &= ~HINT_STRICT_VARS;
7513     sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
7514     PL_hints = savehints;
7515     op_free(v);
7516 }
7517
7518 /* Extract the first two components of a "version" object as two 8bit integers
7519  * and return them packed into a single U16 in the format of PL_prevailing_version.
7520  * This function only ever has to cope with version objects already known
7521  * bounded by the current perl version, so we know its components will fit
7522  * (Up until we reach perl version 5.256 anyway) */
7523 static U16 S_extract_shortver(pTHX_ SV *sv)
7524 {
7525     SV *rv;
7526     if(!SvRV(sv) || !SvOBJECT(rv = SvRV(sv)) || !sv_derived_from(sv, "version"))
7527         return 0;
7528
7529     AV *av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rv), "version", 0)));
7530
7531     U16 shortver = 0;
7532
7533     IV major = av_count(av) > 0 ? SvIV(*av_fetch(av, 0, false)) : 0;
7534     if(major > 255)
7535         shortver |= 255 << 8;
7536     else
7537         shortver |= major << 8;
7538
7539     IV minor = av_count(av) > 1 ? SvIV(*av_fetch(av, 1, false)) : 0;
7540     if(minor > 255)
7541         shortver |= 255;
7542     else
7543         shortver |= minor;
7544
7545     return shortver;
7546 }
7547 #define SHORTVER(maj,min) ((maj << 8) | min)
7548
7549 void
7550 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
7551 {
7552     OP *pack;
7553     OP *imop;
7554     OP *veop;
7555     SV *use_version = NULL;
7556
7557     PERL_ARGS_ASSERT_UTILIZE;
7558
7559     if (idop->op_type != OP_CONST)
7560         Perl_croak(aTHX_ "Module name must be constant");
7561
7562     veop = NULL;
7563
7564     if (version) {
7565         SV * const vesv = cSVOPx(version)->op_sv;
7566
7567         if (!arg && !SvNIOKp(vesv)) {
7568             arg = version;
7569         }
7570         else {
7571             OP *pack;
7572             SV *meth;
7573
7574             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
7575                 Perl_croak(aTHX_ "Version number must be a constant number");
7576
7577             /* Make copy of idop so we don't free it twice */
7578             pack = newSVOP(OP_CONST, 0, newSVsv(cSVOPx(idop)->op_sv));
7579
7580             /* Fake up a method call to VERSION */
7581             meth = newSVpvs_share("VERSION");
7582             veop = op_convert_list(OP_ENTERSUB, OPf_STACKED,
7583                             op_append_elem(OP_LIST,
7584                                         op_prepend_elem(OP_LIST, pack, version),
7585                                         newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
7586         }
7587     }
7588
7589     /* Fake up an import/unimport */
7590     if (arg && arg->op_type == OP_STUB) {
7591         imop = arg;             /* no import on explicit () */
7592     }
7593     else if (SvNIOKp(cSVOPx(idop)->op_sv)) {
7594         imop = NULL;            /* use 5.0; */
7595         if (aver)
7596             use_version = cSVOPx(idop)->op_sv;
7597         else
7598             idop->op_private |= OPpCONST_NOVER;
7599     }
7600     else {
7601         SV *meth;
7602
7603         /* Make copy of idop so we don't free it twice */
7604         pack = newSVOP(OP_CONST, 0, newSVsv(cSVOPx(idop)->op_sv));
7605
7606         /* Fake up a method call to import/unimport */
7607         meth = aver
7608             ? newSVpvs_share("import") : newSVpvs_share("unimport");
7609         imop = op_convert_list(OP_ENTERSUB, OPf_STACKED,
7610                        op_append_elem(OP_LIST,
7611                                    op_prepend_elem(OP_LIST, pack, arg),
7612                                    newMETHOP_named(OP_METHOD_NAMED, 0, meth)
7613                        ));
7614     }
7615
7616     /* Fake up the BEGIN {}, which does its thing immediately. */
7617     newATTRSUB(floor,
7618         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
7619         NULL,
7620         NULL,
7621         op_append_elem(OP_LINESEQ,
7622             op_append_elem(OP_LINESEQ,
7623                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
7624                 newSTATEOP(0, NULL, veop)),
7625             newSTATEOP(0, NULL, imop) ));
7626
7627     if (use_version) {
7628         /* Enable the
7629          * feature bundle that corresponds to the required version. */
7630         use_version = sv_2mortal(new_version(use_version));
7631         S_enable_feature_bundle(aTHX_ use_version);
7632
7633         U16 shortver = S_extract_shortver(aTHX_ use_version);
7634
7635         /* If a version >= 5.11.0 is requested, strictures are on by default! */
7636         if (shortver >= SHORTVER(5, 11)) {
7637             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
7638                 PL_hints |= HINT_STRICT_REFS;
7639             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
7640                 PL_hints |= HINT_STRICT_SUBS;
7641             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
7642                 PL_hints |= HINT_STRICT_VARS;
7643
7644             if (shortver >= SHORTVER(5, 35))
7645                 free_and_set_cop_warnings(&PL_compiling, pWARN_ALL);
7646         }
7647         /* otherwise they are off */
7648         else {
7649             if(PL_prevailing_version >= SHORTVER(5, 11))
7650                 deprecate_fatal_in("5.40",
7651                     "Downgrading a use VERSION declaration to below v5.11");
7652
7653             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
7654                 PL_hints &= ~HINT_STRICT_REFS;
7655             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
7656                 PL_hints &= ~HINT_STRICT_SUBS;
7657             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
7658                 PL_hints &= ~HINT_STRICT_VARS;
7659         }
7660
7661         PL_prevailing_version = shortver;
7662     }
7663
7664     /* The "did you use incorrect case?" warning used to be here.
7665      * The problem is that on case-insensitive filesystems one
7666      * might get false positives for "use" (and "require"):
7667      * "use Strict" or "require CARP" will work.  This causes
7668      * portability problems for the script: in case-strict
7669      * filesystems the script will stop working.
7670      *
7671      * The "incorrect case" warning checked whether "use Foo"
7672      * imported "Foo" to your namespace, but that is wrong, too:
7673      * there is no requirement nor promise in the language that
7674      * a Foo.pm should or would contain anything in package "Foo".
7675      *
7676      * There is very little Configure-wise that can be done, either:
7677      * the case-sensitivity of the build filesystem of Perl does not
7678      * help in guessing the case-sensitivity of the runtime environment.
7679      */
7680
7681     PL_hints |= HINT_BLOCK_SCOPE;
7682     PL_parser->copline = NOLINE;
7683     COP_SEQMAX_INC; /* Purely for B::*'s benefit */
7684 }
7685
7686 /*
7687 =for apidoc_section $embedding
7688
7689 =for apidoc      load_module
7690 =for apidoc_item load_module_nocontext
7691
7692 These load the module whose name is pointed to by the string part of C<name>.
7693 Note that the actual module name, not its filename, should be given.
7694 Eg, "Foo::Bar" instead of "Foo/Bar.pm". ver, if specified and not NULL,
7695 provides version semantics similar to C<use Foo::Bar VERSION>. The optional
7696 trailing arguments can be used to specify arguments to the module's C<import()>
7697 method, similar to C<use Foo::Bar VERSION LIST>; their precise handling depends
7698 on the flags. The flags argument is a bitwise-ORed collection of any of
7699 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
7700 (or 0 for no flags).
7701
7702 If C<PERL_LOADMOD_NOIMPORT> is set, the module is loaded as if with an empty
7703 import list, as in C<use Foo::Bar ()>; this is the only circumstance in which
7704 the trailing optional arguments may be omitted entirely. Otherwise, if
7705 C<PERL_LOADMOD_IMPORT_OPS> is set, the trailing arguments must consist of
7706 exactly one C<OP*>, containing the op tree that produces the relevant import
7707 arguments. Otherwise, the trailing arguments must all be C<SV*> values that
7708 will be used as import arguments; and the list must be terminated with C<(SV*)
7709 NULL>. If neither C<PERL_LOADMOD_NOIMPORT> nor C<PERL_LOADMOD_IMPORT_OPS> is
7710 set, the trailing C<NULL> pointer is needed even if no import arguments are
7711 desired. The reference count for each specified C<SV*> argument is
7712 decremented. In addition, the C<name> argument is modified.
7713
7714 If C<PERL_LOADMOD_DENY> is set, the module is loaded as if with C<no> rather
7715 than C<use>.
7716
7717 C<load_module> and C<load_module_nocontext> have the same apparent signature,
7718 but the former hides the fact that it is accessing a thread context parameter.
7719 So use the latter when you get a compilation error about C<pTHX>.
7720
7721 =for apidoc Amnh||PERL_LOADMOD_DENY
7722 =for apidoc Amnh||PERL_LOADMOD_NOIMPORT
7723 =for apidoc Amnh||PERL_LOADMOD_IMPORT_OPS
7724
7725 =for apidoc vload_module
7726 Like C<L</load_module>> but the arguments are an encapsulated argument list.
7727
7728 =cut */
7729
7730 void
7731 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
7732 {
7733     va_list args;
7734
7735     PERL_ARGS_ASSERT_LOAD_MODULE;
7736
7737     va_start(args, ver);
7738     vload_module(flags, name, ver, &args);
7739     va_end(args);
7740 }
7741
7742 #ifdef MULTIPLICITY
7743 void
7744 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
7745 {
7746     dTHX;
7747     va_list args;
7748     PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
7749     va_start(args, ver);
7750     vload_module(flags, name, ver, &args);
7751     va_end(args);
7752 }
7753 #endif
7754
7755 void
7756 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
7757 {
7758     OP *veop, *imop;
7759     OP * modname;
7760     I32 floor;
7761
7762     PERL_ARGS_ASSERT_VLOAD_MODULE;
7763
7764     /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
7765      * that it has a PL_parser to play with while doing that, and also
7766      * that it doesn't mess with any existing parser, by creating a tmp
7767      * new parser with lex_start(). This won't actually be used for much,
7768      * since pp_require() will create another parser for the real work.
7769      * The ENTER/LEAVE pair protect callers from any side effects of use.
7770      *
7771      * start_subparse() creates a new PL_compcv. This means that any ops
7772      * allocated below will be allocated from that CV's op slab, and so
7773      * will be automatically freed if the utilise() fails
7774      */
7775
7776     ENTER;
7777     SAVEVPTR(PL_curcop);
7778     lex_start(NULL, NULL, LEX_START_SAME_FILTER);
7779     floor = start_subparse(FALSE, 0);
7780
7781     modname = newSVOP(OP_CONST, 0, name);
7782     modname->op_private |= OPpCONST_BARE;
7783     if (ver) {
7784         veop = newSVOP(OP_CONST, 0, ver);
7785     }
7786     else
7787         veop = NULL;
7788     if (flags & PERL_LOADMOD_NOIMPORT) {
7789         imop = sawparens(newNULLLIST());
7790     }
7791     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
7792         imop = va_arg(*args, OP*);
7793     }
7794     else {
7795         SV *sv;
7796         imop = NULL;
7797         sv = va_arg(*args, SV*);
7798         while (sv) {
7799             imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
7800             sv = va_arg(*args, SV*);
7801         }
7802     }
7803
7804     utilize(!(flags & PERL_LOADMOD_DENY), floor, veop, modname, imop);
7805     LEAVE;
7806 }
7807
7808 PERL_STATIC_INLINE OP *
7809 S_new_entersubop(pTHX_ GV *gv, OP *arg)
7810 {
7811     return newUNOP(OP_ENTERSUB, OPf_STACKED,
7812                    newLISTOP(OP_LIST, 0, arg,
7813                              newUNOP(OP_RV2CV, 0,
7814                                      newGVOP(OP_GV, 0, gv))));
7815 }
7816
7817 OP *
7818 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
7819 {
7820     OP *doop;
7821     GV *gv;
7822
7823     PERL_ARGS_ASSERT_DOFILE;
7824
7825     if (!force_builtin && (gv = gv_override("do", 2))) {
7826         doop = S_new_entersubop(aTHX_ gv, term);
7827     }
7828     else {
7829         doop = newUNOP(OP_DOFILE, 0, scalar(term));
7830     }
7831     return doop;
7832 }
7833
7834 /*
7835 =for apidoc_section $optree_construction
7836
7837 =for apidoc newSLICEOP
7838
7839 Constructs, checks, and returns an C<lslice> (list slice) op.  C<flags>
7840 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
7841 be set automatically, and, shifted up eight bits, the eight bits of
7842 C<op_private>, except that the bit with value 1 or 2 is automatically
7843 set as required.  C<listval> and C<subscript> supply the parameters of
7844 the slice; they are consumed by this function and become part of the
7845 constructed op tree.
7846
7847 =cut
7848 */
7849
7850 OP *
7851 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
7852 {
7853     return newBINOP(OP_LSLICE, flags,
7854             list(force_list(subscript, TRUE)),
7855             list(force_list(listval,   TRUE)));
7856 }
7857
7858 #define ASSIGN_SCALAR 0
7859 #define ASSIGN_LIST   1
7860 #define ASSIGN_REF    2
7861
7862 /* given the optree o on the LHS of an assignment, determine whether its:
7863  *  ASSIGN_SCALAR   $x  = ...
7864  *  ASSIGN_LIST    ($x) = ...
7865  *  ASSIGN_REF     \$x  = ...
7866  */
7867
7868 STATIC I32
7869 S_assignment_type(pTHX_ const OP *o)
7870 {
7871     unsigned type;
7872     U8 flags;
7873     U8 ret;
7874
7875     if (!o)
7876         return ASSIGN_LIST;
7877
7878     if (o->op_type == OP_SREFGEN)
7879     {
7880         OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
7881         type = kid->op_type;
7882         flags = o->op_flags | kid->op_flags;
7883         if (!(flags & OPf_PARENS)
7884           && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
7885               kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
7886             return ASSIGN_REF;
7887         ret = ASSIGN_REF;
7888     } else {
7889         if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
7890             o = cUNOPo->op_first;
7891         flags = o->op_flags;
7892         type = o->op_type;
7893         ret = ASSIGN_SCALAR;
7894     }
7895
7896     if (type == OP_COND_EXPR) {
7897         OP * const sib = OpSIBLING(cLOGOPo->op_first);
7898         const I32 t = assignment_type(sib);
7899         const I32 f = assignment_type(OpSIBLING(sib));
7900
7901         if (t == ASSIGN_LIST && f == ASSIGN_LIST)
7902             return ASSIGN_LIST;
7903         if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
7904             yyerror("Assignment to both a list and a scalar");
7905         return ASSIGN_SCALAR;
7906     }
7907
7908     if (type == OP_LIST &&
7909         (flags & OPf_WANT) == OPf_WANT_SCALAR &&
7910         o->op_private & OPpLVAL_INTRO)
7911         return ret;
7912
7913     if (type == OP_LIST || flags & OPf_PARENS ||
7914         type == OP_RV2AV || type == OP_RV2HV ||
7915         type == OP_ASLICE || type == OP_HSLICE ||
7916         type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
7917         return ASSIGN_LIST;
7918
7919     if (type == OP_PADAV || type == OP_PADHV)
7920         return ASSIGN_LIST;
7921
7922     if (type == OP_RV2SV)
7923         return ret;
7924
7925     return ret;
7926 }
7927
7928 static OP *
7929 S_newONCEOP(pTHX_ OP *initop, OP *padop)
7930 {
7931     const PADOFFSET target = padop->op_targ;
7932     OP *const other = newOP(OP_PADSV,
7933                             padop->op_flags
7934                             | ((padop->op_private & ~OPpLVAL_INTRO) << 8));
7935     OP *const first = newOP(OP_NULL, 0);
7936     OP *const nullop = newCONDOP(0, first, initop, other);
7937     /* XXX targlex disabled for now; see ticket #124160
7938         newCONDOP(0, first, S_maybe_targlex(aTHX_ initop), other);
7939      */
7940     OP *const condop = first->op_next;
7941
7942     OpTYPE_set(condop, OP_ONCE);
7943     other->op_targ = target;
7944     nullop->op_flags |= OPf_WANT_SCALAR;
7945
7946     /* Store the initializedness of state vars in a separate
7947        pad entry.  */
7948     condop->op_targ =
7949       pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
7950     /* hijacking PADSTALE for uninitialized state variables */
7951     SvPADSTALE_on(PAD_SVl(condop->op_targ));
7952
7953     return nullop;
7954 }
7955
7956 /*
7957 =for apidoc newASSIGNOP
7958
7959 Constructs, checks, and returns an assignment op.  C<left> and C<right>
7960 supply the parameters of the assignment; they are consumed by this
7961 function and become part of the constructed op tree.
7962
7963 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
7964 a suitable conditional optree is constructed.  If C<optype> is the opcode
7965 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
7966 performs the binary operation and assigns the result to the left argument.
7967 Either way, if C<optype> is non-zero then C<flags> has no effect.
7968
7969 If C<optype> is zero, then a plain scalar or list assignment is
7970 constructed.  Which type of assignment it is is automatically determined.
7971 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
7972 will be set automatically, and, shifted up eight bits, the eight bits
7973 of C<op_private>, except that the bit with value 1 or 2 is automatically
7974 set as required.
7975
7976 =cut
7977 */
7978
7979 OP *
7980 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
7981 {
7982     OP *o;
7983     I32 assign_type;
7984
7985     switch (optype) {
7986         case 0: break;
7987         case OP_ANDASSIGN:
7988         case OP_ORASSIGN:
7989         case OP_DORASSIGN:
7990             right = scalar(right);
7991             return newLOGOP(optype, 0,
7992                 op_lvalue(scalar(left), optype),
7993                 newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right));
7994         default:
7995             return newBINOP(optype, OPf_STACKED,
7996                 op_lvalue(scalar(left), optype), scalar(right));
7997     }
7998
7999     if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
8000         OP *state_var_op = NULL;
8001         static const char no_list_state[] = "Initialization of state variables"
8002             " in list currently forbidden";
8003         OP *curop;
8004
8005         if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
8006             left->op_private &= ~ OPpSLICEWARNING;
8007
8008         PL_modcount = 0;
8009         left = op_lvalue(left, OP_AASSIGN);
8010         curop = list(force_list(left, TRUE));
8011         o = newBINOP(OP_AASSIGN, flags, list(force_list(right, TRUE)), curop);
8012         o->op_private = (U8)(0 | (flags >> 8));
8013
8014         if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
8015         {
8016             OP *lop = cLISTOPx(left)->op_first, *vop, *eop;
8017             if (!(left->op_flags & OPf_PARENS) &&
8018                     lop->op_type == OP_PUSHMARK &&
8019                     (vop = OpSIBLING(lop)) &&
8020                     (vop->op_type == OP_PADAV || vop->op_type == OP_PADHV) &&
8021                     !(vop->op_flags & OPf_PARENS) &&
8022                     (vop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) ==
8023                         (OPpLVAL_INTRO|OPpPAD_STATE) &&
8024                     (eop = OpSIBLING(vop)) &&
8025                     eop->op_type == OP_ENTERSUB &&
8026                     !OpHAS_SIBLING(eop)) {
8027                 state_var_op = vop;
8028             } else {
8029                 while (lop) {
8030                     if ((lop->op_type == OP_PADSV ||
8031                          lop->op_type == OP_PADAV ||
8032                          lop->op_type == OP_PADHV ||
8033                          lop->op_type == OP_PADANY)
8034                       && (lop->op_private & OPpPAD_STATE)
8035                     )
8036                         yyerror(no_list_state);
8037                     lop = OpSIBLING(lop);
8038                 }
8039             }
8040         }
8041         else if (  (left->op_private & OPpLVAL_INTRO)
8042                 && (left->op_private & OPpPAD_STATE)
8043                 && (   left->op_type == OP_PADSV
8044                     || left->op_type == OP_PADAV
8045                     || left->op_type == OP_PADHV
8046                     || left->op_type == OP_PADANY)
8047         ) {
8048                 /* All single variable list context state assignments, hence
8049                    state ($a) = ...
8050                    (state $a) = ...
8051                    state @a = ...
8052                    state (@a) = ...
8053                    (state @a) = ...
8054                    state %a = ...
8055                    state (%a) = ...
8056                    (state %a) = ...
8057                 */
8058                 if (left->op_flags & OPf_PARENS)
8059                     yyerror(no_list_state);
8060                 else
8061                     state_var_op = left;
8062         }
8063
8064         /* optimise @a = split(...) into:
8065         * @{expr}:              split(..., @{expr}) (where @a is not flattened)
8066         * @a, my @a, local @a:  split(...)          (where @a is attached to
8067         *                                            the split op itself)
8068         */
8069
8070         if (   right
8071             && right->op_type == OP_SPLIT
8072             /* don't do twice, e.g. @b = (@a = split) */
8073             && !(right->op_private & OPpSPLIT_ASSIGN))
8074         {
8075             OP *gvop = NULL;
8076
8077             if (   (  left->op_type == OP_RV2AV
8078                    && (gvop=cUNOPx(left)->op_first)->op_type==OP_GV)
8079                 || left->op_type == OP_PADAV)
8080             {
8081                 /* @pkg or @lex or local @pkg' or 'my @lex' */
8082                 OP *tmpop;
8083                 if (gvop) {
8084 #ifdef USE_ITHREADS
8085                     cPMOPx(right)->op_pmreplrootu.op_pmtargetoff
8086                         = cPADOPx(gvop)->op_padix;
8087                     cPADOPx(gvop)->op_padix = 0;        /* steal it */
8088 #else
8089                     cPMOPx(right)->op_pmreplrootu.op_pmtargetgv
8090                         = MUTABLE_GV(cSVOPx(gvop)->op_sv);
8091                     cSVOPx(gvop)->op_sv = NULL; /* steal it */
8092 #endif
8093                     right->op_private |=
8094                         left->op_private & OPpOUR_INTRO;
8095                 }
8096                 else {
8097                     cPMOPx(right)->op_pmreplrootu.op_pmtargetoff = left->op_targ;
8098                     left->op_targ = 0;  /* steal it */
8099                     right->op_private |= OPpSPLIT_LEX;
8100                 }
8101                 right->op_private |= left->op_private & OPpLVAL_INTRO;
8102
8103               detach_split:
8104                 tmpop = cUNOPo->op_first;       /* to list (nulled) */
8105                 tmpop = cUNOPx(tmpop)->op_first; /* to pushmark */
8106                 assert(OpSIBLING(tmpop) == right);
8107                 assert(!OpHAS_SIBLING(right));
8108                 /* detach the split subtreee from the o tree,
8109                  * then free the residual o tree */
8110                 op_sibling_splice(cUNOPo->op_first, tmpop, 1, NULL);
8111                 op_free(o);                     /* blow off assign */
8112                 right->op_private |= OPpSPLIT_ASSIGN;
8113                 right->op_flags &= ~OPf_WANT;
8114                         /* "I don't know and I don't care." */
8115                 return right;
8116             }
8117             else if (left->op_type == OP_RV2AV) {
8118                 /* @{expr} */
8119
8120                 OP *pushop = cUNOPx(cBINOPo->op_last)->op_first;
8121                 assert(OpSIBLING(pushop) == left);
8122                 /* Detach the array ...  */
8123                 op_sibling_splice(cBINOPo->op_last, pushop, 1, NULL);
8124                 /* ... and attach it to the split.  */
8125                 op_sibling_splice(right, cLISTOPx(right)->op_last,
8126                                   0, left);
8127                 right->op_flags |= OPf_STACKED;
8128                 /* Detach split and expunge aassign as above.  */
8129                 goto detach_split;
8130             }
8131             else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
8132                     cLISTOPx(right)->op_last->op_type == OP_CONST)
8133             {
8134                 /* convert split(...,0) to split(..., PL_modcount+1) */
8135                 SV ** const svp =
8136                     &cSVOPx(cLISTOPx(right)->op_last)->op_sv;
8137                 SV * const sv = *svp;
8138                 if (SvIOK(sv) && SvIVX(sv) == 0)
8139                 {
8140                   if (right->op_private & OPpSPLIT_IMPLIM) {
8141                     /* our own SV, created in ck_split */
8142                     SvREADONLY_off(sv);
8143                     sv_setiv(sv, PL_modcount+1);
8144                   }
8145                   else {
8146                     /* SV may belong to someone else */
8147                     SvREFCNT_dec(sv);
8148                     *svp = newSViv(PL_modcount+1);
8149                   }
8150                 }
8151             }
8152         }
8153
8154         if (state_var_op)
8155             o = S_newONCEOP(aTHX_ o, state_var_op);
8156         return o;
8157     }
8158     if (assign_type == ASSIGN_REF)
8159         return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
8160     if (!right)
8161         right = newOP(OP_UNDEF, 0);
8162     if (right->op_type == OP_READLINE) {
8163         right->op_flags |= OPf_STACKED;
8164         return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
8165                 scalar(right));
8166     }
8167     else {
8168         o = newBINOP(OP_SASSIGN, flags,
8169             scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
8170     }
8171     return o;
8172 }
8173
8174 /*
8175 =for apidoc newSTATEOP
8176
8177 Constructs a state op (COP).  The state op is normally a C<nextstate> op,
8178 but will be a C<dbstate> op if debugging is enabled for currently-compiled
8179 code.  The state op is populated from C<PL_curcop> (or C<PL_compiling>).
8180 If C<label> is non-null, it supplies the name of a label to attach to
8181 the state op; this function takes ownership of the memory pointed at by
8182 C<label>, and will free it.  C<flags> gives the eight bits of C<op_flags>
8183 for the state op.
8184
8185 If C<o> is null, the state op is returned.  Otherwise the state op is
8186 combined with C<o> into a C<lineseq> list op, which is returned.  C<o>
8187 is consumed by this function and becomes part of the returned op tree.
8188
8189 =cut
8190 */
8191
8192 OP *
8193 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
8194 {
8195     const U32 seq = intro_my();
8196     const U32 utf8 = flags & SVf_UTF8;
8197     COP *cop;
8198
8199     assert(PL_parser);
8200     PL_parser->parsed_sub = 0;
8201
8202     flags &= ~SVf_UTF8;
8203
8204     NewOp(1101, cop, 1, COP);
8205     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
8206         OpTYPE_set(cop, OP_DBSTATE);
8207     }
8208     else {
8209         OpTYPE_set(cop, OP_NEXTSTATE);
8210     }
8211     cop->op_flags = (U8)flags;
8212     CopHINTS_set(cop, PL_hints);
8213 #ifdef VMS
8214     if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
8215 #endif
8216     cop->op_next = (OP*)cop;
8217
8218     cop->cop_seq = seq;
8219     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
8220     CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
8221     if (label) {
8222         Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
8223
8224         PL_hints |= HINT_BLOCK_SCOPE;
8225         /* It seems that we need to defer freeing this pointer, as other parts
8226            of the grammar end up wanting to copy it after this op has been
8227            created. */
8228         SAVEFREEPV(label);
8229     }
8230
8231     if (PL_parser->preambling != NOLINE) {
8232         CopLINE_set(cop, PL_parser->preambling);
8233         PL_parser->copline = NOLINE;
8234     }
8235     else if (PL_parser->copline == NOLINE)
8236         CopLINE_set(cop, CopLINE(PL_curcop));
8237     else {
8238         CopLINE_set(cop, PL_parser->copline);
8239         PL_parser->copline = NOLINE;
8240     }
8241 #ifdef USE_ITHREADS
8242     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
8243 #else
8244     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
8245 #endif
8246     CopSTASH_set(cop, PL_curstash);
8247
8248     if (cop->op_type == OP_DBSTATE) {
8249         /* this line can have a breakpoint - store the cop in IV */
8250         AV *av = CopFILEAVx(PL_curcop);
8251         if (av) {
8252             SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
8253             if (svp && *svp != &PL_sv_undef ) {
8254                 (void)SvIOK_on(*svp);
8255                 SvIV_set(*svp, PTR2IV(cop));
8256             }
8257         }
8258     }
8259
8260     if (flags & OPf_SPECIAL)
8261         op_null((OP*)cop);
8262     return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
8263 }
8264
8265 /*
8266 =for apidoc newLOGOP
8267
8268 Constructs, checks, and returns a logical (flow control) op.  C<type>
8269 is the opcode.  C<flags> gives the eight bits of C<op_flags>, except
8270 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
8271 the eight bits of C<op_private>, except that the bit with value 1 is
8272 automatically set.  C<first> supplies the expression controlling the
8273 flow, and C<other> supplies the side (alternate) chain of ops; they are
8274 consumed by this function and become part of the constructed op tree.
8275
8276 =cut
8277 */
8278
8279 OP *
8280 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
8281 {
8282     PERL_ARGS_ASSERT_NEWLOGOP;
8283
8284     return new_logop(type, flags, &first, &other);
8285 }
8286
8287
8288 /* See if the optree o contains a single OP_CONST (plus possibly
8289  * surrounding enter/nextstate/null etc). If so, return it, else return
8290  * NULL.
8291  */
8292
8293 STATIC OP *
8294 S_search_const(pTHX_ OP *o)
8295 {
8296     PERL_ARGS_ASSERT_SEARCH_CONST;
8297
8298   redo:
8299     switch (o->op_type) {
8300         case OP_CONST:
8301             return o;
8302         case OP_NULL:
8303             if (o->op_flags & OPf_KIDS) {
8304                 o = cUNOPo->op_first;
8305                 goto redo;
8306             }
8307             break;
8308         case OP_LEAVE:
8309         case OP_SCOPE:
8310         case OP_LINESEQ:
8311         {
8312             OP *kid;
8313             if (!(o->op_flags & OPf_KIDS))
8314                 return NULL;
8315             kid = cLISTOPo->op_first;
8316
8317             do {
8318                 switch (kid->op_type) {
8319                     case OP_ENTER:
8320                     case OP_NULL:
8321                     case OP_NEXTSTATE:
8322                         kid = OpSIBLING(kid);
8323                         break;
8324                     default:
8325                         if (kid != cLISTOPo->op_last)
8326                             return NULL;
8327                         goto last;
8328                 }
8329             } while (kid);
8330
8331             if (!kid)
8332                 kid = cLISTOPo->op_last;
8333           last:
8334              o = kid;
8335              goto redo;
8336         }
8337     }
8338
8339     return NULL;
8340 }
8341
8342
8343 STATIC OP *
8344 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
8345 {
8346     LOGOP *logop;
8347     OP *o;
8348     OP *first;
8349     OP *other;
8350     OP *cstop = NULL;
8351     int prepend_not = 0;
8352
8353     PERL_ARGS_ASSERT_NEW_LOGOP;
8354
8355     first = *firstp;
8356     other = *otherp;
8357
8358     /* [perl #59802]: Warn about things like "return $a or $b", which
8359        is parsed as "(return $a) or $b" rather than "return ($a or
8360        $b)".  NB: This also applies to xor, which is why we do it
8361        here.
8362      */
8363     switch (first->op_type) {
8364     case OP_NEXT:
8365     case OP_LAST:
8366     case OP_REDO:
8367         /* XXX: Perhaps we should emit a stronger warning for these.
8368            Even with the high-precedence operator they don't seem to do
8369            anything sensible.
8370
8371            But until we do, fall through here.
8372          */
8373     case OP_RETURN:
8374     case OP_EXIT:
8375     case OP_DIE:
8376     case OP_GOTO:
8377         /* XXX: Currently we allow people to "shoot themselves in the
8378            foot" by explicitly writing "(return $a) or $b".
8379
8380            Warn unless we are looking at the result from folding or if
8381            the programmer explicitly grouped the operators like this.
8382            The former can occur with e.g.
8383
8384                 use constant FEATURE => ( $] >= ... );
8385                 sub { not FEATURE and return or do_stuff(); }
8386          */
8387         if (!first->op_folded && !(first->op_flags & OPf_PARENS))
8388             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
8389                            "Possible precedence issue with control flow operator");
8390         /* XXX: Should we optimze this to "return $a;" (i.e. remove
8391            the "or $b" part)?
8392         */
8393         break;
8394     }
8395
8396     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
8397         return newBINOP(type, flags, scalar(first), scalar(other));
8398
8399     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
8400         || type == OP_CUSTOM);
8401
8402     scalarboolean(first);
8403
8404     /* search for a constant op that could let us fold the test */
8405     if ((cstop = search_const(first))) {
8406         if (cstop->op_private & OPpCONST_STRICT)
8407             no_bareword_allowed(cstop);
8408         else if ((cstop->op_private & OPpCONST_BARE))
8409                 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
8410         if ((type == OP_AND &&  SvTRUE(cSVOPx(cstop)->op_sv)) ||
8411             (type == OP_OR  && !SvTRUE(cSVOPx(cstop)->op_sv)) ||
8412             (type == OP_DOR && !SvOK(cSVOPx(cstop)->op_sv))) {
8413             /* Elide the (constant) lhs, since it can't affect the outcome */
8414             *firstp = NULL;
8415             if (other->op_type == OP_CONST)
8416                 other->op_private |= OPpCONST_SHORTCIRCUIT;
8417             op_free(first);
8418             if (other->op_type == OP_LEAVE)
8419                 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
8420             else if (other->op_type == OP_MATCH
8421                   || other->op_type == OP_SUBST
8422                   || other->op_type == OP_TRANSR
8423                   || other->op_type == OP_TRANS)
8424                 /* Mark the op as being unbindable with =~ */
8425                 other->op_flags |= OPf_SPECIAL;
8426
8427             other->op_folded = 1;
8428             return other;
8429         }
8430         else {
8431             /* Elide the rhs, since the outcome is entirely determined by
8432              * the (constant) lhs */
8433
8434             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
8435             const OP *o2 = other;
8436             if ( ! (o2->op_type == OP_LIST
8437                     && (( o2 = cUNOPx(o2)->op_first))
8438                     && o2->op_type == OP_PUSHMARK
8439                     && (( o2 = OpSIBLING(o2))) )
8440             )
8441                 o2 = other;
8442             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
8443                         || o2->op_type == OP_PADHV)
8444                 && o2->op_private & OPpLVAL_INTRO
8445                 && !(o2->op_private & OPpPAD_STATE))
8446             {
8447         Perl_croak(aTHX_ "This use of my() in false conditional is "
8448                           "no longer allowed");
8449             }
8450
8451             *otherp = NULL;
8452             if (cstop->op_type == OP_CONST)
8453                 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
8454             op_free(other);
8455             return first;
8456         }
8457     }
8458     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
8459         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
8460     {
8461         const OP * const k1 = cUNOPx(first)->op_first;
8462         const OP * const k2 = OpSIBLING(k1);
8463         OPCODE warnop = 0;
8464         switch (first->op_type)
8465         {
8466         case OP_NULL:
8467             if (k2 && k2->op_type == OP_READLINE
8468                   && (k2->op_flags & OPf_STACKED)
8469                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8470             {
8471                 warnop = k2->op_type;
8472             }
8473             break;
8474
8475         case OP_SASSIGN:
8476             if (k1->op_type == OP_READDIR
8477                   || k1->op_type == OP_GLOB
8478                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8479                  || k1->op_type == OP_EACH
8480                  || k1->op_type == OP_AEACH)
8481             {
8482                 warnop = ((k1->op_type == OP_NULL)
8483                           ? (OPCODE)k1->op_targ : k1->op_type);
8484             }
8485             break;
8486         }
8487         if (warnop) {
8488             const line_t oldline = CopLINE(PL_curcop);
8489             /* This ensures that warnings are reported at the first line
8490                of the construction, not the last.  */
8491             CopLINE_set(PL_curcop, PL_parser->copline);
8492             Perl_warner(aTHX_ packWARN(WARN_MISC),
8493                  "Value of %s%s can be \"0\"; test with defined()",
8494                  PL_op_desc[warnop],
8495                  ((warnop == OP_READLINE || warnop == OP_GLOB)
8496                   ? " construct" : "() operator"));
8497             CopLINE_set(PL_curcop, oldline);
8498         }
8499     }
8500
8501     /* optimize AND and OR ops that have NOTs as children */
8502     if (first->op_type == OP_NOT
8503         && (first->op_flags & OPf_KIDS)
8504         && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
8505             || (other->op_type == OP_NOT))  /* if (!$x && !$y) { } */
8506         ) {
8507         if (type == OP_AND || type == OP_OR) {
8508             if (type == OP_AND)
8509                 type = OP_OR;
8510             else
8511                 type = OP_AND;
8512             op_null(first);
8513             if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
8514                 op_null(other);
8515                 prepend_not = 1; /* prepend a NOT op later */
8516             }
8517         }
8518     }
8519
8520     logop = alloc_LOGOP(type, first, LINKLIST(other));
8521     logop->op_flags |= (U8)flags;
8522     logop->op_private = (U8)(1 | (flags >> 8));
8523
8524     /* establish postfix order */
8525     logop->op_next = LINKLIST(first);
8526     first->op_next = (OP*)logop;
8527     assert(!OpHAS_SIBLING(first));
8528     op_sibling_splice((OP*)logop, first, 0, other);
8529
8530     CHECKOP(type,logop);
8531
8532     o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
8533                 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
8534                 (OP*)logop);
8535     other->op_next = o;
8536
8537     return o;
8538 }
8539
8540 /*
8541 =for apidoc newCONDOP
8542
8543 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
8544 op.  C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
8545 will be set automatically, and, shifted up eight bits, the eight bits of
8546 C<op_private>, except that the bit with value 1 is automatically set.
8547 C<first> supplies the expression selecting between the two branches,
8548 and C<trueop> and C<falseop> supply the branches; they are consumed by
8549 this function and become part of the constructed op tree.
8550
8551 =cut
8552 */
8553
8554 OP *
8555 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
8556 {
8557     LOGOP *logop;
8558     OP *start;
8559     OP *o;
8560     OP *cstop;
8561
8562     PERL_ARGS_ASSERT_NEWCONDOP;
8563
8564     if (!falseop)
8565         return newLOGOP(OP_AND, 0, first, trueop);
8566     if (!trueop)
8567         return newLOGOP(OP_OR, 0, first, falseop);
8568
8569     scalarboolean(first);
8570     if ((cstop = search_const(first))) {
8571         /* Left or right arm of the conditional?  */
8572         const bool left = SvTRUE(cSVOPx(cstop)->op_sv);
8573         OP *live = left ? trueop : falseop;
8574         OP *const dead = left ? falseop : trueop;
8575         if (cstop->op_private & OPpCONST_BARE &&
8576             cstop->op_private & OPpCONST_STRICT) {
8577             no_bareword_allowed(cstop);
8578         }
8579         op_free(first);
8580         op_free(dead);
8581         if (live->op_type == OP_LEAVE)
8582             live = newUNOP(OP_NULL, OPf_SPECIAL, live);
8583         else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
8584               || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
8585             /* Mark the op as being unbindable with =~ */
8586             live->op_flags |= OPf_SPECIAL;
8587         live->op_folded = 1;
8588         return live;
8589     }
8590     logop = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop));
8591     logop->op_flags |= (U8)flags;
8592     logop->op_private = (U8)(1 | (flags >> 8));
8593     logop->op_next = LINKLIST(falseop);
8594
8595     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
8596             logop);
8597
8598     /* establish postfix order */
8599     start = LINKLIST(first);
8600     first->op_next = (OP*)logop;
8601
8602     /* make first, trueop, falseop siblings */
8603     op_sibling_splice((OP*)logop, first,  0, trueop);
8604     op_sibling_splice((OP*)logop, trueop, 0, falseop);
8605
8606     o = newUNOP(OP_NULL, 0, (OP*)logop);
8607
8608     trueop->op_next = falseop->op_next = o;
8609
8610     o->op_next = start;
8611     return o;
8612 }
8613
8614 /*
8615 =for apidoc newTRYCATCHOP
8616
8617 Constructs and returns a conditional execution statement that implements
8618 the C<try>/C<catch> semantics.  First the op tree in C<tryblock> is executed,
8619 inside a context that traps exceptions.  If an exception occurs then the
8620 optree in C<catchblock> is executed, with the trapped exception set into the
8621 lexical variable given by C<catchvar> (which must be an op of type
8622 C<OP_PADSV>).  All the optrees are consumed by this function and become part
8623 of the returned op tree.
8624
8625 The C<flags> argument is currently ignored.
8626
8627 =cut
8628  */
8629
8630 OP *
8631 Perl_newTRYCATCHOP(pTHX_ I32 flags, OP *tryblock, OP *catchvar, OP *catchblock)
8632 {
8633     OP *o, *catchop;
8634
8635     PERL_ARGS_ASSERT_NEWTRYCATCHOP;
8636     assert(catchvar->op_type == OP_PADSV);
8637
8638     PERL_UNUSED_ARG(flags);
8639
8640     /* The returned optree is shaped as:
8641      *   LISTOP leavetrycatch
8642      *       LOGOP entertrycatch
8643      *       LISTOP poptry
8644      *           $tryblock here
8645      *       LOGOP catch
8646      *           $catchblock here
8647      */
8648
8649     if(tryblock->op_type != OP_LINESEQ)
8650         tryblock = op_convert_list(OP_LINESEQ, 0, tryblock);
8651     OpTYPE_set(tryblock, OP_POPTRY);
8652
8653     /* Manually construct a naked LOGOP.
8654      * Normally if we call newLOGOP the returned value is a UNOP(OP_NULL)
8655      * containing the LOGOP we wanted as its op_first */
8656     catchop = (OP *)alloc_LOGOP(OP_CATCH, newOP(OP_NULL, 0), catchblock);
8657     OpMORESIB_set(cUNOPx(catchop)->op_first, catchblock);
8658     OpLASTSIB_set(catchblock, catchop);
8659
8660     /* Inject the catchvar's pad offset into the OP_CATCH targ */
8661     cLOGOPx(catchop)->op_targ = catchvar->op_targ;
8662     op_free(catchvar);
8663
8664     /* Build the optree structure */
8665     o = newLISTOP(OP_LIST, 0, tryblock, catchop);
8666     o = op_convert_list(OP_ENTERTRYCATCH, 0, o);
8667
8668     return o;
8669 }
8670
8671 /*
8672 =for apidoc newRANGE
8673
8674 Constructs and returns a C<range> op, with subordinate C<flip> and
8675 C<flop> ops.  C<flags> gives the eight bits of C<op_flags> for the
8676 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
8677 for both the C<flip> and C<range> ops, except that the bit with value
8678 1 is automatically set.  C<left> and C<right> supply the expressions
8679 controlling the endpoints of the range; they are consumed by this function
8680 and become part of the constructed op tree.
8681
8682 =cut
8683 */
8684
8685 OP *
8686 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
8687 {
8688     LOGOP *range;
8689     OP *flip;
8690     OP *flop;
8691     OP *leftstart;
8692     OP *o;
8693
8694     PERL_ARGS_ASSERT_NEWRANGE;
8695
8696     range = alloc_LOGOP(OP_RANGE, left, LINKLIST(right));
8697     range->op_flags = OPf_KIDS;
8698     leftstart = LINKLIST(left);
8699     range->op_private = (U8)(1 | (flags >> 8));
8700
8701     /* make left and right siblings */
8702     op_sibling_splice((OP*)range, left, 0, right);
8703
8704     range->op_next = (OP*)range;
8705     flip = newUNOP(OP_FLIP, flags, (OP*)range);
8706     flop = newUNOP(OP_FLOP, 0, flip);
8707     o = newUNOP(OP_NULL, 0, flop);
8708     LINKLIST(flop);
8709     range->op_next = leftstart;
8710
8711     left->op_next = flip;
8712     right->op_next = flop;
8713
8714     range->op_targ =
8715         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
8716     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
8717     flip->op_targ =
8718         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
8719     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
8720     SvPADTMP_on(PAD_SV(flip->op_targ));
8721
8722     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
8723     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
8724
8725     /* check barewords before they might be optimized aways */
8726     if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
8727         no_bareword_allowed(left);
8728     if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
8729         no_bareword_allowed(right);
8730
8731     flip->op_next = o;
8732     if (!flip->op_private || !flop->op_private)
8733         LINKLIST(o);            /* blow off optimizer unless constant */
8734
8735     return o;
8736 }
8737
8738 /*
8739 =for apidoc newLOOPOP
8740
8741 Constructs, checks, and returns an op tree expressing a loop.  This is
8742 only a loop in the control flow through the op tree; it does not have
8743 the heavyweight loop structure that allows exiting the loop by C<last>
8744 and suchlike.  C<flags> gives the eight bits of C<op_flags> for the
8745 top-level op, except that some bits will be set automatically as required.
8746 C<expr> supplies the expression controlling loop iteration, and C<block>
8747 supplies the body of the loop; they are consumed by this function and
8748 become part of the constructed op tree.  C<debuggable> is currently
8749 unused and should always be 1.
8750
8751 =cut
8752 */
8753
8754 OP *
8755 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
8756 {
8757     PERL_ARGS_ASSERT_NEWLOOPOP;
8758
8759     OP* listop;
8760     OP* o;
8761     const bool once = block && block->op_flags & OPf_SPECIAL &&
8762                       block->op_type == OP_NULL;
8763
8764     PERL_UNUSED_ARG(debuggable);
8765
8766     if (once && (
8767           (expr->op_type == OP_CONST && !SvTRUE(cSVOPx(expr)->op_sv))
8768        || (  expr->op_type == OP_NOT
8769           && cUNOPx(expr)->op_first->op_type == OP_CONST
8770           && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
8771           )
8772        ))
8773         /* Return the block now, so that S_new_logop does not try to
8774            fold it away. */
8775     {
8776         op_free(expr);
8777         return block;   /* do {} while 0 does once */
8778     }
8779
8780     if (expr->op_type == OP_READLINE
8781         || expr->op_type == OP_READDIR
8782         || expr->op_type == OP_GLOB
8783         || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
8784         || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
8785         expr = newUNOP(OP_DEFINED, 0,
8786             newASSIGNOP(0, newDEFSVOP(), 0, expr) );
8787     } else if (expr->op_flags & OPf_KIDS) {
8788         const OP * const k1 = cUNOPx(expr)->op_first;
8789         const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
8790         switch (expr->op_type) {
8791           case OP_NULL:
8792             if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
8793                   && (k2->op_flags & OPf_STACKED)
8794                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8795                 expr = newUNOP(OP_DEFINED, 0, expr);
8796             break;
8797
8798           case OP_SASSIGN:
8799             if (k1 && (k1->op_type == OP_READDIR
8800                   || k1->op_type == OP_GLOB
8801                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8802                   || k1->op_type == OP_EACH
8803                   || k1->op_type == OP_AEACH))
8804                 expr = newUNOP(OP_DEFINED, 0, expr);
8805             break;
8806         }
8807     }
8808
8809     /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
8810      * op, in listop. This is wrong. [perl #27024] */
8811     if (!block)
8812         block = newOP(OP_NULL, 0);
8813     listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
8814     o = new_logop(OP_AND, 0, &expr, &listop);
8815
8816     if (once) {
8817         ASSUME(listop);
8818     }
8819
8820     if (listop)
8821         cLISTOPx(listop)->op_last->op_next = LINKLIST(o);
8822
8823     if (once && o != listop)
8824     {
8825         assert(cUNOPo->op_first->op_type == OP_AND
8826             || cUNOPo->op_first->op_type == OP_OR);
8827         o->op_next = cLOGOPx(cUNOPo->op_first)->op_other;
8828     }
8829
8830     if (o == listop)
8831         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
8832
8833     o->op_flags |= flags;
8834     o = op_scope(o);
8835     o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
8836     return o;
8837 }
8838
8839 /*
8840 =for apidoc newWHILEOP
8841
8842 Constructs, checks, and returns an op tree expressing a C<while> loop.
8843 This is a heavyweight loop, with structure that allows exiting the loop
8844 by C<last> and suchlike.
8845
8846 C<loop> is an optional preconstructed C<enterloop> op to use in the
8847 loop; if it is null then a suitable op will be constructed automatically.
8848 C<expr> supplies the loop's controlling expression.  C<block> supplies the
8849 main body of the loop, and C<cont> optionally supplies a C<continue> block
8850 that operates as a second half of the body.  All of these optree inputs
8851 are consumed by this function and become part of the constructed op tree.
8852
8853 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
8854 op and, shifted up eight bits, the eight bits of C<op_private> for
8855 the C<leaveloop> op, except that (in both cases) some bits will be set
8856 automatically.  C<debuggable> is currently unused and should always be 1.
8857 C<has_my> can be supplied as true to force the
8858 loop body to be enclosed in its own scope.
8859
8860 =cut
8861 */
8862
8863 OP *
8864 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
8865         OP *expr, OP *block, OP *cont, I32 has_my)
8866 {
8867     OP *redo;
8868     OP *next = NULL;
8869     OP *listop;
8870     OP *o;
8871     U8 loopflags = 0;
8872
8873     PERL_UNUSED_ARG(debuggable);
8874
8875     if (expr) {
8876         if (expr->op_type == OP_READLINE
8877          || expr->op_type == OP_READDIR
8878          || expr->op_type == OP_GLOB
8879          || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
8880                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
8881             expr = newUNOP(OP_DEFINED, 0,
8882                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
8883         } else if (expr->op_flags & OPf_KIDS) {
8884             const OP * const k1 = cUNOPx(expr)->op_first;
8885             const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
8886             switch (expr->op_type) {
8887               case OP_NULL:
8888                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
8889                       && (k2->op_flags & OPf_STACKED)
8890                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8891                     expr = newUNOP(OP_DEFINED, 0, expr);
8892                 break;
8893
8894               case OP_SASSIGN:
8895                 if (k1 && (k1->op_type == OP_READDIR
8896                       || k1->op_type == OP_GLOB
8897                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8898                      || k1->op_type == OP_EACH
8899                      || k1->op_type == OP_AEACH))
8900                     expr = newUNOP(OP_DEFINED, 0, expr);
8901                 break;
8902             }
8903         }
8904     }
8905
8906     if (!block)
8907         block = newOP(OP_NULL, 0);
8908     else if (cont || has_my) {
8909         block = op_scope(block);
8910     }
8911
8912     if (cont) {
8913         next = LINKLIST(cont);
8914     }
8915     if (expr) {
8916         OP * const unstack = newOP(OP_UNSTACK, 0);
8917         if (!next)
8918             next = unstack;
8919         cont = op_append_elem(OP_LINESEQ, cont, unstack);
8920     }
8921
8922     assert(block);
8923     listop = op_append_list(OP_LINESEQ, block, cont);
8924     assert(listop);
8925     redo = LINKLIST(listop);
8926
8927     if (expr) {
8928         scalar(listop);
8929         o = new_logop(OP_AND, 0, &expr, &listop);
8930         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
8931             op_free((OP*)loop);
8932             return expr;                /* listop already freed by new_logop */
8933         }
8934         if (listop)
8935             cLISTOPx(listop)->op_last->op_next =
8936                 (o == listop ? redo : LINKLIST(o));
8937     }
8938     else
8939         o = listop;
8940
8941     if (!loop) {
8942         NewOp(1101,loop,1,LOOP);
8943         OpTYPE_set(loop, OP_ENTERLOOP);
8944         loop->op_private = 0;
8945         loop->op_next = (OP*)loop;
8946     }
8947
8948     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
8949
8950     loop->op_redoop = redo;
8951     loop->op_lastop = o;
8952     o->op_private |= loopflags;
8953
8954     if (next)
8955         loop->op_nextop = next;
8956     else
8957         loop->op_nextop = o;
8958
8959     o->op_flags |= flags;
8960     o->op_private |= (flags >> 8);
8961     return o;
8962 }
8963
8964 /*
8965 =for apidoc newFOROP
8966
8967 Constructs, checks, and returns an op tree expressing a C<foreach>
8968 loop (iteration through a list of values).  This is a heavyweight loop,
8969 with structure that allows exiting the loop by C<last> and suchlike.
8970
8971 C<sv> optionally supplies the variable(s) that will be aliased to each
8972 item in turn; if null, it defaults to C<$_>.
8973 C<expr> supplies the list of values to iterate over.  C<block> supplies
8974 the main body of the loop, and C<cont> optionally supplies a C<continue>
8975 block that operates as a second half of the body.  All of these optree
8976 inputs are consumed by this function and become part of the constructed
8977 op tree.
8978
8979 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
8980 op and, shifted up eight bits, the eight bits of C<op_private> for
8981 the C<leaveloop> op, except that (in both cases) some bits will be set
8982 automatically.
8983
8984 =cut
8985 */
8986
8987 OP *
8988 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
8989 {
8990     LOOP *loop;
8991     OP *iter;
8992     PADOFFSET padoff = 0;
8993     PADOFFSET how_many_more = 0;
8994     I32 iterflags = 0;
8995     I32 iterpflags = 0;
8996     bool parens = 0;
8997
8998     PERL_ARGS_ASSERT_NEWFOROP;
8999
9000     if (sv) {
9001         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
9002             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
9003             OpTYPE_set(sv, OP_RV2GV);
9004
9005             /* The op_type check is needed to prevent a possible segfault
9006              * if the loop variable is undeclared and 'strict vars' is in
9007              * effect. This is illegal but is nonetheless parsed, so we
9008              * may reach this point with an OP_CONST where we're expecting
9009              * an OP_GV.
9010              */
9011             if (cUNOPx(sv)->op_first->op_type == OP_GV
9012              && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
9013                 iterpflags |= OPpITER_DEF;
9014         }
9015         else if (sv->op_type == OP_PADSV) { /* private variable */
9016             if (sv->op_flags & OPf_PARENS) {
9017                 /* handle degenerate 1-var form of "for my ($x, ...)" */
9018                 sv->op_private |= OPpLVAL_INTRO;
9019                 parens = 1;
9020             }
9021             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
9022             padoff = sv->op_targ;
9023             sv->op_targ = 0;
9024             op_free(sv);
9025             sv = NULL;
9026             PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
9027         }
9028         else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
9029             NOOP;
9030         else if (sv->op_type == OP_LIST) {
9031             LISTOP *list = cLISTOPx(sv);
9032             OP *pushmark = list->op_first;
9033             OP *first_padsv;
9034             UNOP *padsv;
9035             PADOFFSET i;
9036
9037             iterpflags = OPpLVAL_INTRO; /* for my ($k, $v) () */
9038             parens = 1;
9039
9040             if (!pushmark || pushmark->op_type != OP_PUSHMARK) {
9041                 Perl_croak(aTHX_ "panic: newFORLOOP, found %s, expecting pushmark",
9042                            pushmark ? PL_op_desc[pushmark->op_type] : "NULL");
9043             }
9044             first_padsv = OpSIBLING(pushmark);
9045             if (!first_padsv || first_padsv->op_type != OP_PADSV) {
9046                 Perl_croak(aTHX_ "panic: newFORLOOP, found %s, expecting padsv",
9047                            first_padsv ? PL_op_desc[first_padsv->op_type] : "NULL");
9048             }
9049             padoff = first_padsv->op_targ;
9050
9051             /* There should be at least one more PADSV to find, and the ops
9052                should have consecutive values in targ: */
9053             padsv = cUNOPx(OpSIBLING(first_padsv));
9054             do {
9055                 if (!padsv || padsv->op_type != OP_PADSV) {
9056                     Perl_croak(aTHX_ "panic: newFORLOOP, found %s at %zd, expecting padsv",
9057                                padsv ? PL_op_desc[padsv->op_type] : "NULL",
9058                                how_many_more);
9059                 }
9060                 ++how_many_more;
9061                 if (padsv->op_targ != padoff + how_many_more) {
9062                     Perl_croak(aTHX_ "panic: newFORLOOP, padsv at %zd targ is %zd, not %zd",
9063                                how_many_more, padsv->op_targ, padoff + how_many_more);
9064                 }
9065
9066                 padsv = cUNOPx(OpSIBLING(padsv));
9067             } while (padsv);
9068
9069             /* OK, this optree has the shape that we expected. So now *we*
9070                "claim" the Pad slots: */
9071             first_padsv->op_targ = 0;
9072             PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
9073
9074             i = padoff;
9075
9076             padsv = cUNOPx(OpSIBLING(first_padsv));
9077             do {
9078                 ++i;
9079                 padsv->op_targ = 0;
9080                 PAD_COMPNAME_GEN_set(i, PERL_INT_MAX);
9081
9082                 padsv = cUNOPx(OpSIBLING(padsv));
9083             } while (padsv);
9084
9085             op_free(sv);
9086             sv = NULL;
9087         }
9088         else
9089             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
9090         if (padoff) {
9091             PADNAME * const pn = PAD_COMPNAME(padoff);
9092             const char * const name = PadnamePV(pn);
9093
9094             if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
9095                 iterpflags |= OPpITER_DEF;
9096         }
9097     }
9098     else {
9099         sv = newGVOP(OP_GV, 0, PL_defgv);
9100         iterpflags |= OPpITER_DEF;
9101     }
9102
9103     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
9104         expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), TRUE), OP_GREPSTART);
9105         iterflags |= OPf_STACKED;
9106     }
9107     else if (expr->op_type == OP_NULL &&
9108              (expr->op_flags & OPf_KIDS) &&
9109              cBINOPx(expr)->op_first->op_type == OP_FLOP)
9110     {
9111         /* Basically turn for($x..$y) into the same as for($x,$y), but we
9112          * set the STACKED flag to indicate that these values are to be
9113          * treated as min/max values by 'pp_enteriter'.
9114          */
9115         const UNOP* const flip = cUNOPx(cUNOPx(cBINOPx(expr)->op_first)->op_first);
9116         LOGOP* const range = cLOGOPx(flip->op_first);
9117         OP* const left  = range->op_first;
9118         OP* const right = OpSIBLING(left);
9119         LISTOP* listop;
9120
9121         range->op_flags &= ~OPf_KIDS;
9122         /* detach range's children */
9123         op_sibling_splice((OP*)range, NULL, -1, NULL);
9124
9125         listop = cLISTOPx(newLISTOP(OP_LIST, 0, left, right));
9126         listop->op_first->op_next = range->op_next;
9127         left->op_next = range->op_other;
9128         right->op_next = (OP*)listop;
9129         listop->op_next = listop->op_first;
9130
9131         op_free(expr);
9132         expr = (OP*)(listop);
9133         op_null(expr);
9134         iterflags |= OPf_STACKED;
9135     }
9136     else {
9137         expr = op_lvalue(force_list(expr, TRUE), OP_GREPSTART);
9138     }
9139
9140     loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
9141                                   op_append_elem(OP_LIST, list(expr),
9142                                                  scalar(sv)));
9143     assert(!loop->op_next);
9144     /* for my  $x () sets OPpLVAL_INTRO;
9145      * for our $x () sets OPpOUR_INTRO */
9146     loop->op_private = (U8)iterpflags;
9147
9148     /* upgrade loop from a LISTOP to a LOOPOP;
9149      * keep it in-place if there's space */
9150     if (loop->op_slabbed
9151         &&    OpSLOT(loop)->opslot_size
9152             < SIZE_TO_PSIZE(sizeof(LOOP) + OPSLOT_HEADER))
9153     {
9154         /* no space; allocate new op */
9155         LOOP *tmp;
9156         NewOp(1234,tmp,1,LOOP);
9157         Copy(loop,tmp,1,LISTOP);
9158         assert(loop->op_last->op_sibparent == (OP*)loop);
9159         OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
9160         S_op_destroy(aTHX_ (OP*)loop);
9161         loop = tmp;
9162     }
9163     else if (!loop->op_slabbed)
9164     {
9165         /* loop was malloc()ed */
9166         loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
9167         OpLASTSIB_set(loop->op_last, (OP*)loop);
9168     }
9169     loop->op_targ = padoff;
9170     if (parens)
9171         /* hint to deparser that this:  for my (...) ... */
9172         loop->op_flags |= OPf_PARENS;
9173     iter = newOP(OP_ITER, 0);
9174     iter->op_targ = how_many_more;
9175     return newWHILEOP(flags, 1, loop, iter, block, cont, 0);
9176 }
9177
9178 /*
9179 =for apidoc newLOOPEX
9180
9181 Constructs, checks, and returns a loop-exiting op (such as C<goto>
9182 or C<last>).  C<type> is the opcode.  C<label> supplies the parameter
9183 determining the target of the op; it is consumed by this function and
9184 becomes part of the constructed op tree.
9185
9186 =cut
9187 */
9188
9189 OP*
9190 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
9191 {
9192     OP *o = NULL;
9193
9194     PERL_ARGS_ASSERT_NEWLOOPEX;
9195
9196     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
9197         || type == OP_CUSTOM);
9198
9199     if (type != OP_GOTO) {
9200         /* "last()" means "last" */
9201         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
9202             o = newOP(type, OPf_SPECIAL);
9203         }
9204     }
9205     else {
9206         /* Check whether it's going to be a goto &function */
9207         if (label->op_type == OP_ENTERSUB
9208                 && !(label->op_flags & OPf_STACKED))
9209             label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
9210     }
9211
9212     /* Check for a constant argument */
9213     if (label->op_type == OP_CONST) {
9214             SV * const sv = cSVOPx(label)->op_sv;
9215             STRLEN l;
9216             const char *s = SvPV_const(sv,l);
9217             if (l == strlen(s)) {
9218                 o = newPVOP(type,
9219                             SvUTF8(cSVOPx(label)->op_sv),
9220                             savesharedpv(
9221                                 SvPV_nolen_const(cSVOPx(label)->op_sv)));
9222             }
9223     }
9224
9225     /* If we have already created an op, we do not need the label. */
9226     if (o)
9227                 op_free(label);
9228     else o = newUNOP(type, OPf_STACKED, label);
9229
9230     PL_hints |= HINT_BLOCK_SCOPE;
9231     return o;
9232 }
9233
9234 /* if the condition is a literal array or hash
9235    (or @{ ... } etc), make a reference to it.
9236  */
9237 STATIC OP *
9238 S_ref_array_or_hash(pTHX_ OP *cond)
9239 {
9240     if (cond
9241     && (cond->op_type == OP_RV2AV
9242     ||  cond->op_type == OP_PADAV
9243     ||  cond->op_type == OP_RV2HV
9244     ||  cond->op_type == OP_PADHV))
9245
9246         return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
9247
9248     else if(cond
9249     && (cond->op_type == OP_ASLICE
9250     ||  cond->op_type == OP_KVASLICE
9251     ||  cond->op_type == OP_HSLICE
9252     ||  cond->op_type == OP_KVHSLICE)) {
9253
9254         /* anonlist now needs a list from this op, was previously used in
9255          * scalar context */
9256         cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
9257         cond->op_flags |= OPf_WANT_LIST;
9258
9259         return newANONLIST(op_lvalue(cond, OP_ANONLIST));
9260     }
9261
9262     else
9263         return cond;
9264 }
9265
9266 /* These construct the optree fragments representing given()
9267    and when() blocks.
9268
9269    entergiven and enterwhen are LOGOPs; the op_other pointer
9270    points up to the associated leave op. We need this so we
9271    can put it in the context and make break/continue work.
9272    (Also, of course, pp_enterwhen will jump straight to
9273    op_other if the match fails.)
9274  */
9275
9276 STATIC OP *
9277 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
9278                    I32 enter_opcode, I32 leave_opcode,
9279                    PADOFFSET entertarg)
9280 {
9281     LOGOP *enterop;
9282     OP *o;
9283
9284     PERL_ARGS_ASSERT_NEWGIVWHENOP;
9285     PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
9286
9287     enterop = alloc_LOGOP(enter_opcode, block, NULL);
9288     enterop->op_targ = 0;
9289     enterop->op_private = 0;
9290
9291     o = newUNOP(leave_opcode, 0, (OP *) enterop);
9292
9293     if (cond) {
9294         /* prepend cond if we have one */
9295         op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
9296
9297         o->op_next = LINKLIST(cond);
9298         cond->op_next = (OP *) enterop;
9299     }
9300     else {
9301         /* This is a default {} block */
9302         enterop->op_flags |= OPf_SPECIAL;
9303         o      ->op_flags |= OPf_SPECIAL;
9304
9305         o->op_next = (OP *) enterop;
9306     }
9307
9308     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
9309                                        entergiven and enterwhen both
9310                                        use ck_null() */
9311
9312     enterop->op_next = LINKLIST(block);
9313     block->op_next = enterop->op_other = o;
9314
9315     return o;
9316 }
9317
9318
9319 /* For the purposes of 'when(implied_smartmatch)'
9320  *              versus 'when(boolean_expression)',
9321  * does this look like a boolean operation? For these purposes
9322    a boolean operation is:
9323      - a subroutine call [*]
9324      - a logical connective
9325      - a comparison operator
9326      - a filetest operator, with the exception of -s -M -A -C
9327      - defined(), exists() or eof()
9328      - /$re/ or $foo =~ /$re/
9329
9330    [*] possibly surprising
9331  */
9332 STATIC bool
9333 S_looks_like_bool(pTHX_ const OP *o)
9334 {
9335     PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
9336
9337     switch(o->op_type) {
9338         case OP_OR:
9339         case OP_DOR:
9340             return looks_like_bool(cLOGOPo->op_first);
9341
9342         case OP_AND:
9343         {
9344             OP* sibl = OpSIBLING(cLOGOPo->op_first);
9345             ASSUME(sibl);
9346             return (
9347                 looks_like_bool(cLOGOPo->op_first)
9348              && looks_like_bool(sibl));
9349         }
9350
9351         case OP_NULL:
9352         case OP_SCALAR:
9353             return (
9354                 o->op_flags & OPf_KIDS
9355             && looks_like_bool(cUNOPo->op_first));
9356
9357         case OP_ENTERSUB:
9358
9359         case OP_NOT:    case OP_XOR:
9360
9361         case OP_EQ:     case OP_NE:     case OP_LT:
9362         case OP_GT:     case OP_LE:     case OP_GE:
9363
9364         case OP_I_EQ:   case OP_I_NE:   case OP_I_LT:
9365         case OP_I_GT:   case OP_I_LE:   case OP_I_GE:
9366
9367         case OP_SEQ:    case OP_SNE:    case OP_SLT:
9368         case OP_SGT:    case OP_SLE:    case OP_SGE:
9369
9370         case OP_SMARTMATCH:
9371
9372         case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
9373         case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
9374         case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
9375         case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
9376         case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
9377         case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
9378         case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
9379         case OP_FTTEXT:   case OP_FTBINARY:
9380
9381         case OP_DEFINED: case OP_EXISTS:
9382         case OP_MATCH:   case OP_EOF:
9383
9384         case OP_FLOP:
9385
9386             return TRUE;
9387
9388         case OP_INDEX:
9389         case OP_RINDEX:
9390             /* optimised-away (index() != -1) or similar comparison */
9391             if (o->op_private & OPpTRUEBOOL)
9392                 return TRUE;
9393             return FALSE;
9394
9395         case OP_CONST:
9396             /* Detect comparisons that have been optimized away */
9397             if (cSVOPo->op_sv == &PL_sv_yes
9398             ||  cSVOPo->op_sv == &PL_sv_no)
9399
9400                 return TRUE;
9401             else
9402                 return FALSE;
9403         /* FALLTHROUGH */
9404         default:
9405             return FALSE;
9406     }
9407 }
9408
9409
9410 /*
9411 =for apidoc newGIVENOP
9412
9413 Constructs, checks, and returns an op tree expressing a C<given> block.
9414 C<cond> supplies the expression to whose value C<$_> will be locally
9415 aliased, and C<block> supplies the body of the C<given> construct; they
9416 are consumed by this function and become part of the constructed op tree.
9417 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
9418
9419 =cut
9420 */
9421
9422 OP *
9423 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
9424 {
9425     PERL_ARGS_ASSERT_NEWGIVENOP;
9426     PERL_UNUSED_ARG(defsv_off);
9427
9428     assert(!defsv_off);
9429     return newGIVWHENOP(
9430         ref_array_or_hash(cond),
9431         block,
9432         OP_ENTERGIVEN, OP_LEAVEGIVEN,
9433         0);
9434 }
9435
9436 /*
9437 =for apidoc newWHENOP
9438
9439 Constructs, checks, and returns an op tree expressing a C<when> block.
9440 C<cond> supplies the test expression, and C<block> supplies the block
9441 that will be executed if the test evaluates to true; they are consumed
9442 by this function and become part of the constructed op tree.  C<cond>
9443 will be interpreted DWIMically, often as a comparison against C<$_>,
9444 and may be null to generate a C<default> block.
9445
9446 =cut
9447 */
9448
9449 OP *
9450 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
9451 {
9452     const bool cond_llb = (!cond || looks_like_bool(cond));
9453     OP *cond_op;
9454
9455     PERL_ARGS_ASSERT_NEWWHENOP;
9456
9457     if (cond_llb)
9458         cond_op = cond;
9459     else {
9460         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
9461                 newDEFSVOP(),
9462                 scalar(ref_array_or_hash(cond)));
9463     }
9464
9465     return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
9466 }
9467
9468 /*
9469 =for apidoc newDEFEROP
9470
9471 Constructs and returns a deferred-block statement that implements the
9472 C<defer> semantics.  The C<block> optree is consumed by this function and
9473 becomes part of the returned optree.
9474
9475 The C<flags> argument carries additional flags to set on the returned op,
9476 including the C<op_private> field.
9477
9478 =cut
9479  */
9480
9481 OP *
9482 Perl_newDEFEROP(pTHX_ I32 flags, OP *block)
9483 {
9484     OP *o, *start, *blockfirst;
9485
9486     PERL_ARGS_ASSERT_NEWDEFEROP;
9487
9488     start = LINKLIST(block);
9489
9490     /* Hide the block inside an OP_NULL with no exection */
9491     block = newUNOP(OP_NULL, 0, block);
9492     block->op_next = block;
9493
9494     o = (OP *)alloc_LOGOP(OP_PUSHDEFER, block, start);
9495     o->op_flags |= OPf_WANT_VOID | (U8)(flags);
9496     o->op_private = (U8)(flags >> 8);
9497
9498     /* Terminate the block */
9499     blockfirst = cUNOPx(block)->op_first;
9500     assert(blockfirst->op_type == OP_SCOPE || blockfirst->op_type == OP_LEAVE);
9501     blockfirst->op_next = NULL;
9502
9503     return o;
9504 }
9505
9506 /*
9507 =for apidoc op_wrap_finally
9508
9509 Wraps the given C<block> optree fragment in its own scoped block, arranging
9510 for the C<finally> optree fragment to be invoked when leaving that block for
9511 any reason. Both optree fragments are consumed and the combined result is
9512 returned.
9513
9514 =cut
9515 */
9516
9517 OP *
9518 Perl_op_wrap_finally(pTHX_ OP *block, OP *finally)
9519 {
9520     PERL_ARGS_ASSERT_OP_WRAP_FINALLY;
9521
9522     /* TODO: If block is already an ENTER/LEAVE-wrapped line sequence we can
9523      * just splice the DEFEROP in at the top, for efficiency.
9524      */
9525
9526     OP *o = newLISTOP(OP_LINESEQ, 0, newDEFEROP((OPpDEFER_FINALLY << 8), finally), block);
9527     o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
9528     OpTYPE_set(o, OP_LEAVE);
9529
9530     return o;
9531 }
9532
9533 /* must not conflict with SVf_UTF8 */
9534 #define CV_CKPROTO_CURSTASH     0x1
9535
9536 void
9537 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
9538                     const STRLEN len, const U32 flags)
9539 {
9540     SV *name = NULL, *msg;
9541     const char * cvp = SvROK(cv)
9542                         ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
9543                            ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
9544                            : ""
9545                         : CvPROTO(cv);
9546     STRLEN clen = CvPROTOLEN(cv), plen = len;
9547
9548     PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
9549
9550     if (p == NULL && cvp == NULL)
9551         return;
9552
9553     if (!ckWARN_d(WARN_PROTOTYPE))
9554         return;
9555
9556     if (p && cvp) {
9557         p = S_strip_spaces(aTHX_ p, &plen);
9558         cvp = S_strip_spaces(aTHX_ cvp, &clen);
9559         if ((flags & SVf_UTF8) == SvUTF8(cv)) {
9560             if (plen == clen && memEQ(cvp, p, plen))
9561                 return;
9562         } else {
9563             if (flags & SVf_UTF8) {
9564                 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
9565                     return;
9566             }
9567             else {
9568                 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
9569                     return;
9570             }
9571         }
9572     }
9573
9574     msg = sv_newmortal();
9575
9576     if (gv)
9577     {
9578         if (isGV(gv))
9579             gv_efullname3(name = sv_newmortal(), gv, NULL);
9580         else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
9581             name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
9582         else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
9583             name = newSVhek_mortal(HvNAME_HEK(PL_curstash));
9584             sv_catpvs(name, "::");
9585             if (SvROK(gv)) {
9586                 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
9587                 assert (CvNAMED(SvRV_const(gv)));
9588                 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
9589             }
9590             else sv_catsv(name, (SV *)gv);
9591         }
9592         else name = (SV *)gv;
9593     }
9594     sv_setpvs(msg, "Prototype mismatch:");
9595     if (name)
9596         Perl_sv_catpvf(aTHX_ msg, " sub %" SVf, SVfARG(name));
9597     if (cvp)
9598         Perl_sv_catpvf(aTHX_ msg, " (%" UTF8f ")",
9599             UTF8fARG(SvUTF8(cv),clen,cvp)
9600         );
9601     else
9602         sv_catpvs(msg, ": none");
9603     sv_catpvs(msg, " vs ");
9604     if (p)
9605         Perl_sv_catpvf(aTHX_ msg, "(%" UTF8f ")", UTF8fARG(flags & SVf_UTF8,len,p));
9606     else
9607         sv_catpvs(msg, "none");
9608     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%" SVf, SVfARG(msg));
9609 }
9610
9611 static void const_sv_xsub(pTHX_ CV* cv);
9612 static void const_av_xsub(pTHX_ CV* cv);
9613
9614 /*
9615
9616 =for apidoc_section $optree_manipulation
9617
9618 =for apidoc cv_const_sv
9619
9620 If C<cv> is a constant sub eligible for inlining, returns the constant
9621 value returned by the sub.  Otherwise, returns C<NULL>.
9622
9623 Constant subs can be created with C<newCONSTSUB> or as described in
9624 L<perlsub/"Constant Functions">.
9625
9626 =cut
9627 */
9628 SV *
9629 Perl_cv_const_sv(const CV *const cv)
9630 {
9631     SV *sv;
9632     if (!cv)
9633         return NULL;
9634     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
9635         return NULL;
9636     sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
9637     if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
9638     return sv;
9639 }
9640
9641 SV *
9642 Perl_cv_const_sv_or_av(const CV * const cv)
9643 {
9644     if (!cv)
9645         return NULL;
9646     if (SvROK(cv)) return SvRV((SV *)cv);
9647     assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
9648     return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
9649 }
9650
9651 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
9652  * Can be called in 2 ways:
9653  *
9654  * !allow_lex
9655  *      look for a single OP_CONST with attached value: return the value
9656  *
9657  * allow_lex && !CvCONST(cv);
9658  *
9659  *      examine the clone prototype, and if contains only a single
9660  *      OP_CONST, return the value; or if it contains a single PADSV ref-
9661  *      erencing an outer lexical, turn on CvCONST to indicate the CV is
9662  *      a candidate for "constizing" at clone time, and return NULL.
9663  */
9664
9665 static SV *
9666 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
9667 {
9668     SV *sv = NULL;
9669     bool padsv = FALSE;
9670
9671     assert(o);
9672     assert(cv);
9673
9674     for (; o; o = o->op_next) {
9675         const OPCODE type = o->op_type;
9676
9677         if (type == OP_NEXTSTATE || type == OP_LINESEQ
9678              || type == OP_NULL
9679              || type == OP_PUSHMARK)
9680                 continue;
9681         if (type == OP_DBSTATE)
9682                 continue;
9683         if (type == OP_LEAVESUB)
9684             break;
9685         if (sv)
9686             return NULL;
9687         if (type == OP_CONST && cSVOPo->op_sv)
9688             sv = cSVOPo->op_sv;
9689         else if (type == OP_UNDEF && !o->op_private) {
9690             sv = newSV_type(SVt_NULL);
9691             SAVEFREESV(sv);
9692         }
9693         else if (allow_lex && type == OP_PADSV) {
9694                 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEf_OUTER)
9695                 {
9696                     sv = &PL_sv_undef; /* an arbitrary non-null value */
9697                     padsv = TRUE;
9698                 }
9699                 else
9700                     return NULL;
9701         }
9702         else {
9703             return NULL;
9704         }
9705     }
9706     if (padsv) {
9707         CvCONST_on(cv);
9708         return NULL;
9709     }
9710     return sv;
9711 }
9712
9713 static void
9714 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
9715                         PADNAME * const name, SV ** const const_svp)
9716 {
9717     assert (cv);
9718     assert (o || name);
9719     assert (const_svp);
9720     if (!block) {
9721         if (CvFLAGS(PL_compcv)) {
9722             /* might have had built-in attrs applied */
9723             const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
9724             if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
9725              && ckWARN(WARN_MISC))
9726             {
9727                 /* protect against fatal warnings leaking compcv */
9728                 SAVEFREESV(PL_compcv);
9729                 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
9730                 SvREFCNT_inc_simple_void_NN(PL_compcv);
9731             }
9732             CvFLAGS(cv) |=
9733                 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
9734                   & ~(CVf_LVALUE * pureperl));
9735         }
9736         return;
9737     }
9738
9739     /* redundant check for speed: */
9740     if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
9741         const line_t oldline = CopLINE(PL_curcop);
9742         SV *namesv = o
9743             ? cSVOPo->op_sv
9744             : newSVpvn_flags( PadnamePV(name)+1,PadnameLEN(name)-1,
9745                (PadnameUTF8(name)) ? SVf_UTF8|SVs_TEMP : SVs_TEMP
9746               );
9747         if (PL_parser && PL_parser->copline != NOLINE)
9748             /* This ensures that warnings are reported at the first
9749                line of a redefinition, not the last.  */
9750             CopLINE_set(PL_curcop, PL_parser->copline);
9751         /* protect against fatal warnings leaking compcv */
9752         SAVEFREESV(PL_compcv);
9753         report_redefined_cv(namesv, cv, const_svp);
9754         SvREFCNT_inc_simple_void_NN(PL_compcv);
9755         CopLINE_set(PL_curcop, oldline);
9756     }
9757     SAVEFREESV(cv);
9758     return;
9759 }
9760
9761 CV *
9762 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
9763 {
9764     CV **spot;
9765     SV **svspot;
9766     const char *ps;
9767     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
9768     U32 ps_utf8 = 0;
9769     CV *cv = NULL;
9770     CV *compcv = PL_compcv;
9771     SV *const_sv;
9772     PADNAME *name;
9773     PADOFFSET pax = o->op_targ;
9774     CV *outcv = CvOUTSIDE(PL_compcv);
9775     CV *clonee = NULL;
9776     HEK *hek = NULL;
9777     bool reusable = FALSE;
9778     OP *start = NULL;
9779 #ifdef PERL_DEBUG_READONLY_OPS
9780     OPSLAB *slab = NULL;
9781 #endif
9782
9783     PERL_ARGS_ASSERT_NEWMYSUB;
9784
9785     PL_hints |= HINT_BLOCK_SCOPE;
9786
9787     /* Find the pad slot for storing the new sub.
9788        We cannot use PL_comppad, as it is the pad owned by the new sub.  We
9789        need to look in CvOUTSIDE and find the pad belonging to the enclos-
9790        ing sub.  And then we need to dig deeper if this is a lexical from
9791        outside, as in:
9792            my sub foo; sub { sub foo { } }
9793      */
9794   redo:
9795     name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
9796     if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
9797         pax = PARENT_PAD_INDEX(name);
9798         outcv = CvOUTSIDE(outcv);
9799         assert(outcv);
9800         goto redo;
9801     }
9802     svspot =
9803         &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
9804                         [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
9805     spot = (CV **)svspot;
9806
9807     if (!(PL_parser && PL_parser->error_count))
9808         move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name), 0);
9809
9810     if (proto) {
9811         assert(proto->op_type == OP_CONST);
9812         ps = SvPV_const(cSVOPx(proto)->op_sv, ps_len);
9813         ps_utf8 = SvUTF8(cSVOPx(proto)->op_sv);
9814     }
9815     else
9816         ps = NULL;
9817
9818     if (proto)
9819         SAVEFREEOP(proto);
9820     if (attrs)
9821         SAVEFREEOP(attrs);
9822
9823     if (PL_parser && PL_parser->error_count) {
9824         op_free(block);
9825         SvREFCNT_dec(PL_compcv);
9826         PL_compcv = 0;
9827         goto done;
9828     }
9829
9830     if (CvDEPTH(outcv) && CvCLONE(compcv)) {
9831         cv = *spot;
9832         svspot = (SV **)(spot = &clonee);
9833     }
9834     else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
9835         cv = *spot;
9836     else {
9837         assert (SvTYPE(*spot) == SVt_PVCV);
9838         if (CvNAMED(*spot))
9839             hek = CvNAME_HEK(*spot);
9840         else {
9841             U32 hash;
9842             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
9843             CvNAME_HEK_set(*spot, hek =
9844                 share_hek(
9845                     PadnamePV(name)+1,
9846                     (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
9847                     hash
9848                 )
9849             );
9850             CvLEXICAL_on(*spot);
9851         }
9852         cv = PadnamePROTOCV(name);
9853         svspot = (SV **)(spot = &PadnamePROTOCV(name));
9854     }
9855
9856     if (block) {
9857         /* This makes sub {}; work as expected.  */
9858         if (block->op_type == OP_STUB) {
9859             const line_t l = PL_parser->copline;
9860             op_free(block);
9861             block = newSTATEOP(0, NULL, 0);
9862             PL_parser->copline = l;
9863         }
9864         block = CvLVALUE(compcv)
9865              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
9866                    ? newUNOP(OP_LEAVESUBLV, 0,
9867                              op_lvalue(voidnonfinal(block), OP_LEAVESUBLV))
9868                    : newUNOP(OP_LEAVESUB, 0, voidnonfinal(block));
9869         start = LINKLIST(block);
9870         block->op_next = 0;
9871         if (ps && !*ps && !attrs && !CvLVALUE(compcv))
9872             const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
9873         else
9874             const_sv = NULL;
9875     }
9876     else
9877         const_sv = NULL;
9878
9879     if (cv) {
9880         const bool exists = CvROOT(cv) || CvXSUB(cv);
9881
9882         /* if the subroutine doesn't exist and wasn't pre-declared
9883          * with a prototype, assume it will be AUTOLOADed,
9884          * skipping the prototype check
9885          */
9886         if (exists || SvPOK(cv))
9887             cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
9888                                  ps_utf8);
9889         /* already defined? */
9890         if (exists) {
9891             S_already_defined(aTHX_ cv, block, NULL, name, &const_sv);
9892             if (block)
9893                 cv = NULL;
9894             else {
9895                 if (attrs)
9896                     goto attrs;
9897                 /* just a "sub foo;" when &foo is already defined */
9898                 SAVEFREESV(compcv);
9899                 goto done;
9900             }
9901         }
9902         else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
9903             cv = NULL;
9904             reusable = TRUE;
9905         }
9906     }
9907
9908     if (const_sv) {
9909         SvREFCNT_inc_simple_void_NN(const_sv);
9910         SvFLAGS(const_sv) |= SVs_PADTMP;
9911         if (cv) {
9912             assert(!CvROOT(cv) && !CvCONST(cv));
9913             cv_forget_slab(cv);
9914         }
9915         else {
9916             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9917             CvFILE_set_from_cop(cv, PL_curcop);
9918             CvSTASH_set(cv, PL_curstash);
9919             *spot = cv;
9920         }
9921         SvPVCLEAR(MUTABLE_SV(cv));  /* prototype is "" */
9922         CvXSUBANY(cv).any_ptr = const_sv;
9923         CvXSUB(cv) = const_sv_xsub;
9924         CvCONST_on(cv);
9925         CvISXSUB_on(cv);
9926         PoisonPADLIST(cv);
9927         CvFLAGS(cv) |= CvNOWARN_AMBIGUOUS(compcv);
9928         op_free(block);
9929         SvREFCNT_dec(compcv);
9930         PL_compcv = NULL;
9931         goto setname;
9932     }
9933
9934     /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
9935        determine whether this sub definition is in the same scope as its
9936        declaration.  If this sub definition is inside an inner named pack-
9937        age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
9938        the package sub.  So check PadnameOUTER(name) too.
9939      */
9940     if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
9941         assert(!CvWEAKOUTSIDE(compcv));
9942         SvREFCNT_dec(CvOUTSIDE(compcv));
9943         CvWEAKOUTSIDE_on(compcv);
9944     }
9945     /* XXX else do we have a circular reference? */
9946
9947     if (cv) {   /* must reuse cv in case stub is referenced elsewhere */
9948         /* transfer PL_compcv to cv */
9949         if (block) {
9950             bool free_file = CvFILE(cv) && CvDYNFILE(cv);
9951             cv_flags_t preserved_flags =
9952                 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
9953             PADLIST *const temp_padl = CvPADLIST(cv);
9954             CV *const temp_cv = CvOUTSIDE(cv);
9955             const cv_flags_t other_flags =
9956                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
9957             OP * const cvstart = CvSTART(cv);
9958
9959             SvPOK_off(cv);
9960             CvFLAGS(cv) =
9961                 CvFLAGS(compcv) | preserved_flags;
9962             CvOUTSIDE(cv) = CvOUTSIDE(compcv);
9963             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
9964             CvPADLIST_set(cv, CvPADLIST(compcv));
9965             CvOUTSIDE(compcv) = temp_cv;
9966             CvPADLIST_set(compcv, temp_padl);
9967             CvSTART(cv) = CvSTART(compcv);
9968             CvSTART(compcv) = cvstart;
9969             CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
9970             CvFLAGS(compcv) |= other_flags;
9971
9972             if (free_file) {
9973                 Safefree(CvFILE(cv));
9974                 CvFILE(cv) = NULL;
9975             }
9976
9977             /* inner references to compcv must be fixed up ... */
9978             pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
9979             if (PERLDB_INTER)/* Advice debugger on the new sub. */
9980                 ++PL_sub_generation;
9981         }
9982         else {
9983             /* Might have had built-in attributes applied -- propagate them. */
9984             CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
9985         }
9986         /* ... before we throw it away */
9987         SvREFCNT_dec(compcv);
9988         PL_compcv = compcv = cv;
9989     }
9990     else {
9991         cv = compcv;
9992         *spot = cv;
9993     }
9994
9995   setname:
9996     CvLEXICAL_on(cv);
9997     if (!CvNAME_HEK(cv)) {
9998         if (hek) (void)share_hek_hek(hek);
9999         else {
10000             U32 hash;
10001             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
10002             hek = share_hek(PadnamePV(name)+1,
10003                       (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
10004                       hash);
10005         }
10006         CvNAME_HEK_set(cv, hek);
10007     }
10008
10009     if (const_sv)
10010         goto clone;
10011
10012     if (CvFILE(cv) && CvDYNFILE(cv))
10013         Safefree(CvFILE(cv));
10014     CvFILE_set_from_cop(cv, PL_curcop);
10015     CvSTASH_set(cv, PL_curstash);
10016
10017     if (ps) {
10018         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
10019         if (ps_utf8)
10020             SvUTF8_on(MUTABLE_SV(cv));
10021     }
10022
10023     if (block) {
10024         /* If we assign an optree to a PVCV, then we've defined a
10025          * subroutine that the debugger could be able to set a breakpoint
10026          * in, so signal to pp_entereval that it should not throw away any
10027          * saved lines at scope exit.  */
10028
10029         PL_breakable_sub_gen++;
10030         CvROOT(cv) = block;
10031         /* The cv no longer needs to hold a refcount on the slab, as CvROOT
10032            itself has a refcount. */
10033         CvSLABBED_off(cv);
10034         OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
10035 #ifdef PERL_DEBUG_READONLY_OPS
10036         slab = (OPSLAB *)CvSTART(cv);
10037 #endif
10038         S_process_optree(aTHX_ cv, block, start);
10039     }
10040
10041   attrs:
10042     if (attrs) {
10043         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
10044         apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
10045     }
10046
10047     if (block) {
10048         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
10049             SV * const tmpstr = sv_newmortal();
10050             GV * const db_postponed = gv_fetchpvs("DB::postponed",
10051                                                   GV_ADDMULTI, SVt_PVHV);
10052             HV *hv;
10053             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
10054                                           CopFILE(PL_curcop),
10055                                           (long)PL_subline,
10056                                           (long)CopLINE(PL_curcop));
10057             if (HvNAME_HEK(PL_curstash)) {
10058                 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
10059                 sv_catpvs(tmpstr, "::");
10060             }
10061             else
10062                 sv_setpvs(tmpstr, "__ANON__::");
10063
10064             sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
10065                             PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
10066             (void)hv_store_ent(GvHV(PL_DBsub), tmpstr, sv, 0);
10067             hv = GvHVn(db_postponed);
10068             if (HvTOTALKEYS(hv) > 0 && hv_exists_ent(hv, tmpstr, 0)) {
10069                 CV * const pcv = GvCV(db_postponed);
10070                 if (pcv) {
10071                     dSP;
10072                     PUSHMARK(SP);
10073                     XPUSHs(tmpstr);
10074                     PUTBACK;
10075                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
10076                 }
10077             }
10078         }
10079     }
10080
10081   clone:
10082     if (clonee) {
10083         assert(CvDEPTH(outcv));
10084         spot = (CV **)
10085             &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
10086         if (reusable)
10087             cv_clone_into(clonee, *spot);
10088         else *spot = cv_clone(clonee);
10089         SvREFCNT_dec_NN(clonee);
10090         cv = *spot;
10091     }
10092
10093     if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
10094         PADOFFSET depth = CvDEPTH(outcv);
10095         while (--depth) {
10096             SV *oldcv;
10097             svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
10098             oldcv = *svspot;
10099             *svspot = SvREFCNT_inc_simple_NN(cv);
10100             SvREFCNT_dec(oldcv);
10101         }
10102     }
10103
10104   done:
10105     if (PL_parser)
10106         PL_parser->copline = NOLINE;
10107     LEAVE_SCOPE(floor);
10108 #ifdef PERL_DEBUG_READONLY_OPS
10109     if (slab)
10110         Slab_to_ro(slab);
10111 #endif
10112     op_free(o);
10113     return cv;
10114 }
10115
10116 /*
10117 =for apidoc newATTRSUB_x
10118
10119 Construct a Perl subroutine, also performing some surrounding jobs.
10120
10121 This function is expected to be called in a Perl compilation context,
10122 and some aspects of the subroutine are taken from global variables
10123 associated with compilation.  In particular, C<PL_compcv> represents
10124 the subroutine that is currently being compiled.  It must be non-null
10125 when this function is called, and some aspects of the subroutine being
10126 constructed are taken from it.  The constructed subroutine may actually
10127 be a reuse of the C<PL_compcv> object, but will not necessarily be so.
10128
10129 If C<block> is null then the subroutine will have no body, and for the
10130 time being it will be an error to call it.  This represents a forward
10131 subroutine declaration such as S<C<sub foo ($$);>>.  If C<block> is
10132 non-null then it provides the Perl code of the subroutine body, which
10133 will be executed when the subroutine is called.  This body includes
10134 any argument unwrapping code resulting from a subroutine signature or
10135 similar.  The pad use of the code must correspond to the pad attached
10136 to C<PL_compcv>.  The code is not expected to include a C<leavesub> or
10137 C<leavesublv> op; this function will add such an op.  C<block> is consumed
10138 by this function and will become part of the constructed subroutine.
10139
10140 C<proto> specifies the subroutine's prototype, unless one is supplied
10141 as an attribute (see below).  If C<proto> is null, then the subroutine
10142 will not have a prototype.  If C<proto> is non-null, it must point to a
10143 C<const> op whose value is a string, and the subroutine will have that
10144 string as its prototype.  If a prototype is supplied as an attribute, the
10145 attribute takes precedence over C<proto>, but in that case C<proto> should
10146 preferably be null.  In any case, C<proto> is consumed by this function.
10147
10148 C<attrs> supplies attributes to be applied the subroutine.  A handful of
10149 attributes take effect by built-in means, being applied to C<PL_compcv>
10150 immediately when seen.  Other attributes are collected up and attached
10151 to the subroutine by this route.  C<attrs> may be null to supply no
10152 attributes, or point to a C<const> op for a single attribute, or point
10153 to a C<list> op whose children apart from the C<pushmark> are C<const>
10154 ops for one or more attributes.  Each C<const> op must be a string,
10155 giving the attribute name optionally followed by parenthesised arguments,
10156 in the manner in which attributes appear in Perl source.  The attributes
10157 will be applied to the sub by this function.  C<attrs> is consumed by
10158 this function.
10159
10160 If C<o_is_gv> is false and C<o> is null, then the subroutine will
10161 be anonymous.  If C<o_is_gv> is false and C<o> is non-null, then C<o>
10162 must point to a C<const> OP, which will be consumed by this function,
10163 and its string value supplies a name for the subroutine.  The name may
10164 be qualified or unqualified, and if it is unqualified then a default
10165 stash will be selected in some manner.  If C<o_is_gv> is true, then C<o>
10166 doesn't point to an C<OP> at all, but is instead a cast pointer to a C<GV>
10167 by which the subroutine will be named.
10168
10169 If there is already a subroutine of the specified name, then the new
10170 sub will either replace the existing one in the glob or be merged with
10171 the existing one.  A warning may be generated about redefinition.
10172
10173 If the subroutine has one of a few special names, such as C<BEGIN> or
10174 C<END>, then it will be claimed by the appropriate queue for automatic
10175 running of phase-related subroutines.  In this case the relevant glob will
10176 be left not containing any subroutine, even if it did contain one before.
10177 In the case of C<BEGIN>, the subroutine will be executed and the reference
10178 to it disposed of before this function returns.
10179
10180 The function returns a pointer to the constructed subroutine.  If the sub
10181 is anonymous then ownership of one counted reference to the subroutine
10182 is transferred to the caller.  If the sub is named then the caller does
10183 not get ownership of a reference.  In most such cases, where the sub
10184 has a non-phase name, the sub will be alive at the point it is returned
10185 by virtue of being contained in the glob that names it.  A phase-named
10186 subroutine will usually be alive by virtue of the reference owned by the
10187 phase's automatic run queue.  But a C<BEGIN> subroutine, having already
10188 been executed, will quite likely have been destroyed already by the
10189 time this function returns, making it erroneous for the caller to make
10190 any use of the returned pointer.  It is the caller's responsibility to
10191 ensure that it knows which of these situations applies.
10192
10193 =for apidoc newATTRSUB
10194 Construct a Perl subroutine, also performing some surrounding jobs.
10195
10196 This is the same as L<perlintern/C<newATTRSUB_x>> with its C<o_is_gv> parameter set to
10197 FALSE.  This means that if C<o> is null, the new sub will be anonymous; otherwise
10198 the name will be derived from C<o> in the way described (as with all other
10199 details) in L<perlintern/C<newATTRSUB_x>>.
10200
10201 =for apidoc newSUB
10202 Like C<L</newATTRSUB>>, but without attributes.
10203
10204 =cut
10205 */
10206
10207 /* _x = extended */
10208 CV *
10209 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
10210                             OP *block, bool o_is_gv)
10211 {
10212     GV *gv;
10213     const char *ps;
10214     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
10215     U32 ps_utf8 = 0;
10216     CV *cv = NULL;     /* the previous CV with this name, if any */
10217     SV *const_sv;
10218     const bool ec = PL_parser && PL_parser->error_count;
10219     /* If the subroutine has no body, no attributes, and no builtin attributes
10220        then it's just a sub declaration, and we may be able to get away with
10221        storing with a placeholder scalar in the symbol table, rather than a
10222        full CV.  If anything is present then it will take a full CV to
10223        store it.  */
10224     const I32 gv_fetch_flags
10225         = ec ? GV_NOADD_NOINIT :
10226         (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
10227         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
10228     STRLEN namlen = 0;
10229     const char * const name =
10230          o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
10231     bool has_name;
10232     bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
10233     bool evanescent = FALSE;
10234     bool isBEGIN = FALSE;
10235     OP *start = NULL;
10236 #ifdef PERL_DEBUG_READONLY_OPS
10237     OPSLAB *slab = NULL;
10238 #endif
10239
10240     if (o_is_gv) {
10241         gv = (GV*)o;
10242         o = NULL;
10243         has_name = TRUE;
10244     } else if (name) {
10245         /* Try to optimise and avoid creating a GV.  Instead, the CV’s name
10246            hek and CvSTASH pointer together can imply the GV.  If the name
10247            contains a package name, then GvSTASH(CvGV(cv)) may differ from
10248            CvSTASH, so forego the optimisation if we find any.
10249            Also, we may be called from load_module at run time, so
10250            PL_curstash (which sets CvSTASH) may not point to the stash the
10251            sub is stored in.  */
10252         /* XXX This optimization is currently disabled for packages other
10253                than main, since there was too much CPAN breakage.  */
10254         const I32 flags =
10255            ec ? GV_NOADD_NOINIT
10256               :   (IN_PERL_RUNTIME && PL_curstash != CopSTASH(PL_curcop))
10257                || PL_curstash != PL_defstash
10258                || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
10259                     ? gv_fetch_flags
10260                     : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
10261         gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
10262         has_name = TRUE;
10263     } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
10264         SV * const sv = sv_newmortal();
10265         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%" IVdf "]",
10266                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
10267                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
10268         gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
10269         has_name = TRUE;
10270     } else if (PL_curstash) {
10271         gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
10272         has_name = FALSE;
10273     } else {
10274         gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
10275         has_name = FALSE;
10276     }
10277
10278     if (!ec) {
10279         if (isGV(gv)) {
10280             move_proto_attr(&proto, &attrs, gv, 0);
10281         } else {
10282             assert(cSVOPo);
10283             move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv, 1);
10284         }
10285     }
10286
10287     if (o)
10288         SAVEFREEOP(o);
10289     if (proto)
10290         SAVEFREEOP(proto);
10291     if (attrs)
10292         SAVEFREEOP(attrs);
10293
10294     /* we need this in two places later on, so set it up here */
10295     if (name && block) {
10296         const char *s = (char *) my_memrchr(name, ':', namlen);
10297         s = s ? s+1 : name;
10298         isBEGIN = strEQ(s,"BEGIN");
10299     }
10300
10301     if (isBEGIN) {
10302         /* Make sure that we do not have any prototypes or
10303          * attributes associated with this BEGIN block, as the block
10304          * is already done and dusted, and we will assert or worse
10305          * if we try to attach the prototype to the now essentially
10306          * nonexistent sub. */
10307         if (proto)
10308             /* diag_listed_as: %s on BEGIN block ignored */
10309             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Prototype on BEGIN block ignored");
10310         if (attrs)
10311             /* diag_listed_as: %s on BEGIN block ignored */
10312             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Attribute on BEGIN block ignored");
10313         proto = NULL;
10314         attrs = NULL;
10315     }
10316
10317     if (proto) {
10318         assert(proto->op_type == OP_CONST);
10319         ps = SvPV_const(cSVOPx(proto)->op_sv, ps_len);
10320         ps_utf8 = SvUTF8(cSVOPx(proto)->op_sv);
10321     }
10322     else
10323         ps = NULL;
10324
10325     if (ec) {
10326         op_free(block);
10327
10328         if (name)
10329             SvREFCNT_dec(PL_compcv);
10330         else
10331             cv = PL_compcv;
10332
10333         PL_compcv = 0;
10334         if (isBEGIN) {
10335             if (PL_in_eval & EVAL_KEEPERR)
10336                 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
10337             else {
10338                 SV * const errsv = ERRSV;
10339                 /* force display of errors found but not reported */
10340                 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
10341                 Perl_croak_nocontext("%" SVf, SVfARG(errsv));
10342             }
10343         }
10344         goto done;
10345     }
10346
10347     if (!block && SvTYPE(gv) != SVt_PVGV) {
10348         /* If we are not defining a new sub and the existing one is not a
10349            full GV + CV... */
10350         if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
10351             /* We are applying attributes to an existing sub, so we need it
10352                upgraded if it is a constant.  */
10353             if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
10354                 gv_init_pvn(gv, PL_curstash, name, namlen,
10355                             SVf_UTF8 * name_is_utf8);
10356         }
10357         else {                  /* Maybe prototype now, and had at maximum
10358                                    a prototype or const/sub ref before.  */
10359             if (SvTYPE(gv) > SVt_NULL) {
10360                 cv_ckproto_len_flags((const CV *)gv,
10361                                     o ? (const GV *)cSVOPo->op_sv : NULL, ps,
10362                                     ps_len, ps_utf8);
10363             }
10364
10365             if (!SvROK(gv)) {
10366                 if (ps) {
10367                     sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
10368                     if (ps_utf8)
10369                         SvUTF8_on(MUTABLE_SV(gv));
10370                 }
10371                 else
10372                     sv_setiv(MUTABLE_SV(gv), -1);
10373             }
10374
10375             SvREFCNT_dec(PL_compcv);
10376             cv = PL_compcv = NULL;
10377             goto done;
10378         }
10379     }
10380
10381     cv = (!name || (isGV(gv) && GvCVGEN(gv)))
10382         ? NULL
10383         : isGV(gv)
10384             ? GvCV(gv)
10385             : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
10386                 ? (CV *)SvRV(gv)
10387                 : NULL;
10388
10389     if (block) {
10390         assert(PL_parser);
10391         /* This makes sub {}; work as expected.  */
10392         if (block->op_type == OP_STUB) {
10393             const line_t l = PL_parser->copline;
10394             op_free(block);
10395             block = newSTATEOP(0, NULL, 0);
10396             PL_parser->copline = l;
10397         }
10398         block = CvLVALUE(PL_compcv)
10399              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
10400                     && (!isGV(gv) || !GvASSUMECV(gv)))
10401                    ? newUNOP(OP_LEAVESUBLV, 0,
10402                              op_lvalue(voidnonfinal(block), OP_LEAVESUBLV))
10403                    : newUNOP(OP_LEAVESUB, 0, voidnonfinal(block));
10404         start = LINKLIST(block);
10405         block->op_next = 0;
10406         if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
10407             const_sv =
10408                 S_op_const_sv(aTHX_ start, PL_compcv,
10409                                         cBOOL(CvCLONE(PL_compcv)));
10410         else
10411             const_sv = NULL;
10412     }
10413     else
10414         const_sv = NULL;
10415
10416     if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
10417         cv_ckproto_len_flags((const CV *)gv,
10418                              o ? (const GV *)cSVOPo->op_sv : NULL, ps,
10419                              ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
10420         if (SvROK(gv)) {
10421             /* All the other code for sub redefinition warnings expects the
10422                clobbered sub to be a CV.  Instead of making all those code
10423                paths more complex, just inline the RV version here.  */
10424             const line_t oldline = CopLINE(PL_curcop);
10425             assert(IN_PERL_COMPILETIME);
10426             if (PL_parser && PL_parser->copline != NOLINE)
10427                 /* This ensures that warnings are reported at the first
10428                    line of a redefinition, not the last.  */
10429                 CopLINE_set(PL_curcop, PL_parser->copline);
10430             /* protect against fatal warnings leaking compcv */
10431             SAVEFREESV(PL_compcv);
10432
10433             if (ckWARN(WARN_REDEFINE)
10434              || (  ckWARN_d(WARN_REDEFINE)
10435                 && (  !const_sv || SvRV(gv) == const_sv
10436                    || sv_cmp(SvRV(gv), const_sv)  ))) {
10437                 assert(cSVOPo);
10438                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10439                           "Constant subroutine %" SVf " redefined",
10440                           SVfARG(cSVOPo->op_sv));
10441             }
10442
10443             SvREFCNT_inc_simple_void_NN(PL_compcv);
10444             CopLINE_set(PL_curcop, oldline);
10445             SvREFCNT_dec(SvRV(gv));
10446         }
10447     }
10448
10449     if (cv) {
10450         const bool exists = CvROOT(cv) || CvXSUB(cv);
10451
10452         /* if the subroutine doesn't exist and wasn't pre-declared
10453          * with a prototype, assume it will be AUTOLOADed,
10454          * skipping the prototype check
10455          */
10456         if (exists || SvPOK(cv))
10457             cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
10458         /* already defined (or promised)? */
10459         if (exists || (isGV(gv) && GvASSUMECV(gv))) {
10460             S_already_defined(aTHX_ cv, block, o, NULL, &const_sv);
10461             if (block)
10462                 cv = NULL;
10463             else {
10464                 if (attrs)
10465                     goto attrs;
10466                 /* just a "sub foo;" when &foo is already defined */
10467                 SAVEFREESV(PL_compcv);
10468                 goto done;
10469             }
10470         }
10471     }
10472
10473     if (const_sv) {
10474         SvREFCNT_inc_simple_void_NN(const_sv);
10475         SvFLAGS(const_sv) |= SVs_PADTMP;
10476         if (cv) {
10477             assert(!CvROOT(cv) && !CvCONST(cv));
10478             cv_forget_slab(cv);
10479             SvPVCLEAR(MUTABLE_SV(cv));  /* prototype is "" */
10480             CvXSUBANY(cv).any_ptr = const_sv;
10481             CvXSUB(cv) = const_sv_xsub;
10482             CvCONST_on(cv);
10483             CvISXSUB_on(cv);
10484             PoisonPADLIST(cv);
10485             CvFLAGS(cv) |= CvNOWARN_AMBIGUOUS(PL_compcv);
10486         }
10487         else {
10488             if (isGV(gv) || CvNOWARN_AMBIGUOUS(PL_compcv)) {
10489                 if (name && isGV(gv))
10490                     GvCV_set(gv, NULL);
10491                 cv = newCONSTSUB_flags(
10492                     NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
10493                     const_sv
10494                 );
10495                 assert(cv);
10496                 assert(SvREFCNT((SV*)cv) != 0);
10497                 CvFLAGS(cv) |= CvNOWARN_AMBIGUOUS(PL_compcv);
10498             }
10499             else {
10500                 if (!SvROK(gv)) {
10501                     SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
10502                     prepare_SV_for_RV((SV *)gv);
10503                     SvOK_off((SV *)gv);
10504                     SvROK_on(gv);
10505                 }
10506                 SvRV_set(gv, const_sv);
10507             }
10508         }
10509         op_free(block);
10510         SvREFCNT_dec(PL_compcv);
10511         PL_compcv = NULL;
10512         goto done;
10513     }
10514
10515     /* don't copy new BEGIN CV to old BEGIN CV - RT #129099 */
10516     if (name && cv && *name == 'B' && strEQ(name, "BEGIN"))
10517         cv = NULL;
10518
10519     if (cv) {                           /* must reuse cv if autoloaded */
10520         /* transfer PL_compcv to cv */
10521         if (block) {
10522             bool free_file = CvFILE(cv) && CvDYNFILE(cv);
10523             cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
10524             PADLIST *const temp_av = CvPADLIST(cv);
10525             CV *const temp_cv = CvOUTSIDE(cv);
10526             const cv_flags_t other_flags =
10527                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
10528             OP * const cvstart = CvSTART(cv);
10529
10530             if (isGV(gv)) {
10531                 CvGV_set(cv,gv);
10532                 assert(!CvCVGV_RC(cv));
10533                 assert(CvGV(cv) == gv);
10534             }
10535             else {
10536                 U32 hash;
10537                 PERL_HASH(hash, name, namlen);
10538                 CvNAME_HEK_set(cv,
10539                                share_hek(name,
10540                                          name_is_utf8
10541                                             ? -(SSize_t)namlen
10542                                             :  (SSize_t)namlen,
10543                                          hash));
10544             }
10545
10546             SvPOK_off(cv);
10547             CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
10548                                              | CvNAMED(cv);
10549             CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
10550             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
10551             CvPADLIST_set(cv,CvPADLIST(PL_compcv));
10552             CvOUTSIDE(PL_compcv) = temp_cv;
10553             CvPADLIST_set(PL_compcv, temp_av);
10554             CvSTART(cv) = CvSTART(PL_compcv);
10555             CvSTART(PL_compcv) = cvstart;
10556             CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
10557             CvFLAGS(PL_compcv) |= other_flags;
10558
10559             if (free_file) {
10560                 Safefree(CvFILE(cv));
10561             }
10562             CvFILE_set_from_cop(cv, PL_curcop);
10563             CvSTASH_set(cv, PL_curstash);
10564
10565             /* inner references to PL_compcv must be fixed up ... */
10566             pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
10567             if (PERLDB_INTER)/* Advice debugger on the new sub. */
10568                 ++PL_sub_generation;
10569         }
10570         else {
10571             /* Might have had built-in attributes applied -- propagate them. */
10572             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
10573         }
10574         /* ... before we throw it away */
10575         SvREFCNT_dec(PL_compcv);
10576         PL_compcv = cv;
10577     }
10578     else {
10579         cv = PL_compcv;
10580         if (name && isGV(gv)) {
10581             GvCV_set(gv, cv);
10582             GvCVGEN(gv) = 0;
10583             if (HvENAME_HEK(GvSTASH(gv)))
10584                 /* sub Foo::bar { (shift)+1 } */
10585                 gv_method_changed(gv);
10586         }
10587         else if (name) {
10588             if (!SvROK(gv)) {
10589                 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
10590                 prepare_SV_for_RV((SV *)gv);
10591                 SvOK_off((SV *)gv);
10592                 SvROK_on(gv);
10593             }
10594             SvRV_set(gv, (SV *)cv);
10595             if (HvENAME_HEK(PL_curstash))
10596                 mro_method_changed_in(PL_curstash);
10597         }
10598     }
10599     assert(cv);
10600     assert(SvREFCNT((SV*)cv) != 0);
10601
10602     if (!CvHASGV(cv)) {
10603         if (isGV(gv))
10604             CvGV_set(cv, gv);
10605         else {
10606             U32 hash;
10607             PERL_HASH(hash, name, namlen);
10608             CvNAME_HEK_set(cv, share_hek(name,
10609                                          name_is_utf8
10610                                             ? -(SSize_t)namlen
10611                                             :  (SSize_t)namlen,
10612                                          hash));
10613         }
10614         CvFILE_set_from_cop(cv, PL_curcop);
10615         CvSTASH_set(cv, PL_curstash);
10616     }
10617
10618     if (ps) {
10619         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
10620         if ( ps_utf8 )
10621             SvUTF8_on(MUTABLE_SV(cv));
10622     }
10623
10624     if (block) {
10625         /* If we assign an optree to a PVCV, then we've defined a
10626          * subroutine that the debugger could be able to set a breakpoint
10627          * in, so signal to pp_entereval that it should not throw away any
10628          * saved lines at scope exit.  */
10629
10630         PL_breakable_sub_gen++;
10631         CvROOT(cv) = block;
10632         /* The cv no longer needs to hold a refcount on the slab, as CvROOT
10633            itself has a refcount. */
10634         CvSLABBED_off(cv);
10635         OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
10636 #ifdef PERL_DEBUG_READONLY_OPS
10637         slab = (OPSLAB *)CvSTART(cv);
10638 #endif
10639         S_process_optree(aTHX_ cv, block, start);
10640     }
10641
10642   attrs:
10643     if (attrs) {
10644         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
10645         HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
10646                         ? GvSTASH(CvGV(cv))
10647                         : PL_curstash;
10648         if (!name)
10649             SAVEFREESV(cv);
10650         apply_attrs(stash, MUTABLE_SV(cv), attrs);
10651         if (!name)
10652             SvREFCNT_inc_simple_void_NN(cv);
10653     }
10654
10655     if (block && has_name) {
10656         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
10657             SV * const tmpstr = cv_name(cv,NULL,0);
10658             GV * const db_postponed = gv_fetchpvs("DB::postponed",
10659                                                   GV_ADDMULTI, SVt_PVHV);
10660             HV *hv;
10661             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
10662                                           CopFILE(PL_curcop),
10663                                           (long)PL_subline,
10664                                           (long)CopLINE(PL_curcop));
10665             (void)hv_store_ent(GvHV(PL_DBsub), tmpstr, sv, 0);
10666             hv = GvHVn(db_postponed);
10667             if (HvTOTALKEYS(hv) > 0 && hv_exists_ent(hv, tmpstr, 0)) {
10668                 CV * const pcv = GvCV(db_postponed);
10669                 if (pcv) {
10670                     dSP;
10671                     PUSHMARK(SP);
10672                     XPUSHs(tmpstr);
10673                     PUTBACK;
10674                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
10675                 }
10676             }
10677         }
10678
10679         if (name) {
10680             if (PL_parser && PL_parser->error_count)
10681                 clear_special_blocks(name, gv, cv);
10682             else
10683                 evanescent =
10684                     process_special_blocks(floor, name, gv, cv);
10685         }
10686     }
10687     assert(cv);
10688
10689   done:
10690     assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
10691     if (PL_parser)
10692         PL_parser->copline = NOLINE;
10693     LEAVE_SCOPE(floor);
10694
10695     assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
10696     if (!evanescent) {
10697 #ifdef PERL_DEBUG_READONLY_OPS
10698     if (slab)
10699         Slab_to_ro(slab);
10700 #endif
10701     if (cv && name && block && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
10702         pad_add_weakref(cv);
10703     }
10704     return cv;
10705 }
10706
10707 STATIC void
10708 S_clear_special_blocks(pTHX_ const char *const fullname,
10709                        GV *const gv, CV *const cv) {
10710     const char *colon;
10711     const char *name;
10712
10713     PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
10714
10715     colon = strrchr(fullname,':');
10716     name = colon ? colon + 1 : fullname;
10717
10718     if ((*name == 'B' && strEQ(name, "BEGIN"))
10719         || (*name == 'E' && strEQ(name, "END"))
10720         || (*name == 'U' && strEQ(name, "UNITCHECK"))
10721         || (*name == 'C' && strEQ(name, "CHECK"))
10722         || (*name == 'I' && strEQ(name, "INIT"))) {
10723         if (!isGV(gv)) {
10724             (void)CvGV(cv);
10725             assert(isGV(gv));
10726         }
10727         GvCV_set(gv, NULL);
10728         SvREFCNT_dec_NN(MUTABLE_SV(cv));
10729     }
10730 }
10731
10732 /* Returns true if the sub has been freed.  */
10733 STATIC bool
10734 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
10735                          GV *const gv,
10736                          CV *const cv)
10737 {
10738     const char *const colon = strrchr(fullname,':');
10739     const char *const name = colon ? colon + 1 : fullname;
10740     int is_module_install_hack = 0;
10741
10742     PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
10743
10744     if (*name == 'B') {
10745         module_install_hack:
10746         if (strEQ(name, "BEGIN") || is_module_install_hack) {
10747             const I32 oldscope = PL_scopestack_ix;
10748             SV *max_nest_sv = NULL;
10749             IV max_nest_iv;
10750             dSP;
10751             (void)CvGV(cv);
10752             is_module_install_hack = 0;
10753             if (floor) LEAVE_SCOPE(floor);
10754             ENTER;
10755
10756             /* make sure we don't recurse too deeply into BEGIN blocks
10757              * but let the user control it via the new control variable
10758              *
10759              *   ${^MAX_NESTED_EVAL_BEGIN_BLOCKS}
10760              *
10761              * Note this *looks* code like when max_nest_iv is 1 that it
10762              * would block the following code:
10763              *
10764              * BEGIN { $n |= 1; BEGIN { $n |= 2; BEGIN { $n |= 4 } } }
10765              *
10766              * but it does *not*, this code will happily execute when
10767              * the nest limit is 1. The reason is revealed in the
10768              * execution order. If we could watch $n in this code we
10769              * would see the follow order of modifications:
10770              *
10771              * $n |= 4;
10772              * $n |= 2;
10773              * $n |= 1;
10774              *
10775              * This is because nested BEGIN blocks execute in FILO
10776              * order, this is because BEGIN blocks are defined to
10777              * execute immediately they are closed. So the innermost
10778              * block is closed first, and it executes, which would the
10779              * eval_begin_nest_depth by 1, it would finish, which would
10780              * drop it back to its previous value. This would happen in
10781              * turn as each BEGIN was terminated.
10782              *
10783              * The *only* place these counts matter is when BEGIN in
10784              * inside of some kind of eval, either a require or a true
10785              * eval. Only in that case would there be any nesting and
10786              * would perl try to execute a BEGIN before another had
10787              * completed.
10788              *
10789              * Thus this logic puts an upper limit on module nesting.
10790              * Hence the reason we let the user control it, although its
10791              * hard to imagine a 1000 level deep module use dependency
10792              * even in a very large codebase. The real objective is to
10793              * prevent code like this:
10794              *
10795              * perl -e'sub f { eval "BEGIN { f() }" } f()'
10796              *
10797              * from segfaulting due to stack exhaustion.
10798              *
10799              */
10800             max_nest_sv = get_sv(PERL_VAR_MAX_NESTED_EVAL_BEGIN_BLOCKS, GV_ADD);
10801             if (!SvOK(max_nest_sv))
10802                 sv_setiv(max_nest_sv, PERL_MAX_NESTED_EVAL_BEGIN_BLOCKS_DEFAULT);
10803             max_nest_iv = SvIV(max_nest_sv);
10804             if (max_nest_iv < 0) {
10805                 max_nest_iv = PERL_MAX_NESTED_EVAL_BEGIN_BLOCKS_DEFAULT;
10806                 sv_setiv(max_nest_sv, max_nest_iv);
10807             }
10808
10809             if (PL_eval_begin_nest_depth >= max_nest_iv) {
10810                 Perl_croak(aTHX_ "Too many nested BEGIN blocks, maximum of %" IVdf " allowed",
10811                              max_nest_iv);
10812             }
10813             SAVEINT(PL_eval_begin_nest_depth);
10814             PL_eval_begin_nest_depth++;
10815
10816             SAVEVPTR(PL_curcop);
10817             if (PL_curcop == &PL_compiling) {
10818                 /* Avoid pushing the "global" &PL_compiling onto the
10819                  * context stack. For example, a stack trace inside
10820                  * nested use's would show all calls coming from whoever
10821                  * most recently updated PL_compiling.cop_file and
10822                  * cop_line.  So instead, temporarily set PL_curcop to a
10823                  * private copy of &PL_compiling. PL_curcop will soon be
10824                  * set to point back to &PL_compiling anyway but only
10825                  * after the temp value has been pushed onto the context
10826                  * stack as blk_oldcop.
10827                  * This is slightly hacky, but necessary. Note also
10828                  * that in the brief window before PL_curcop is set back
10829                  * to PL_compiling, IN_PERL_COMPILETIME/IN_PERL_RUNTIME
10830                  * will give the wrong answer.
10831                  */
10832                 PL_curcop = (COP*)newSTATEOP(PL_compiling.op_flags, NULL, NULL);
10833                 CopLINE_set(PL_curcop, CopLINE(&PL_compiling));
10834                 SAVEFREEOP(PL_curcop);
10835             }
10836
10837             PUSHSTACKi(PERLSI_REQUIRE);
10838             SAVECOPFILE(&PL_compiling);
10839             SAVECOPLINE(&PL_compiling);
10840
10841             DEBUG_x( dump_sub(gv) );
10842             Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
10843             GvCV_set(gv,0);             /* cv has been hijacked */
10844             call_list(oldscope, PL_beginav);
10845
10846             POPSTACK;
10847             LEAVE;
10848             return !PL_savebegin;
10849         }
10850         else
10851             return FALSE;
10852     } else {
10853         if (*name == 'E') {
10854             if (strEQ(name, "END")) {
10855                 DEBUG_x( dump_sub(gv) );
10856                 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
10857             } else
10858                 return FALSE;
10859         } else if (*name == 'U') {
10860             if (strEQ(name, "UNITCHECK")) {
10861                 /* It's never too late to run a unitcheck block */
10862                 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
10863             }
10864             else
10865                 return FALSE;
10866         } else if (*name == 'C') {
10867             if (strEQ(name, "CHECK")) {
10868                 if (PL_main_start)
10869                     /* diag_listed_as: Too late to run %s block */
10870                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
10871                                    "Too late to run CHECK block");
10872                 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
10873             }
10874             else
10875                 return FALSE;
10876         } else if (*name == 'I') {
10877             if (strEQ(name, "INIT")) {
10878 #ifdef MI_INIT_WORKAROUND_PACK
10879                 {
10880                     HV *hv= CvSTASH(cv);
10881                     STRLEN len = hv ? HvNAMELEN(hv) : 0;
10882                     char *pv= (len == sizeof(MI_INIT_WORKAROUND_PACK)-1)
10883                             ? HvNAME_get(hv) : NULL;
10884                     if ( pv && strEQ(pv,MI_INIT_WORKAROUND_PACK) )
10885                     {
10886                         /* old versions of Module::Install::DSL contain code
10887                          * that creates an INIT in eval, which expect to run
10888                          * after an exit(0) in BEGIN. This unfortunately
10889                          * breaks a lot of code in the CPAN river. So we magically
10890                          * convert INIT blocks from Module::Install::DSL to
10891                          * be BEGIN blocks. Which works out, since the INIT
10892                          * blocks it creates are eval'ed so are late.
10893                          */
10894                         Perl_warn(aTHX_ "Treating %s::INIT block as BEGIN block as workaround",
10895                                 MI_INIT_WORKAROUND_PACK);
10896                         is_module_install_hack = 1;
10897                         goto module_install_hack;
10898                     }
10899
10900                 }
10901 #endif
10902                 if (PL_main_start)
10903                     /* diag_listed_as: Too late to run %s block */
10904                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
10905                                    "Too late to run INIT block");
10906                 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
10907             }
10908             else
10909                 return FALSE;
10910         } else
10911             return FALSE;
10912         DEBUG_x( dump_sub(gv) );
10913         (void)CvGV(cv);
10914         GvCV_set(gv,0);         /* cv has been hijacked */
10915         return FALSE;
10916     }
10917 }
10918
10919 /*
10920 =for apidoc newCONSTSUB
10921
10922 Behaves like L</newCONSTSUB_flags>, except that C<name> is nul-terminated
10923 rather than of counted length, and no flags are set.  (This means that
10924 C<name> is always interpreted as Latin-1.)
10925
10926 =cut
10927 */
10928
10929 CV *
10930 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
10931 {
10932     return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
10933 }
10934
10935 /*
10936 =for apidoc newCONSTSUB_flags
10937
10938 Construct a constant subroutine, also performing some surrounding
10939 jobs.  A scalar constant-valued subroutine is eligible for inlining
10940 at compile-time, and in Perl code can be created by S<C<sub FOO () {
10941 123 }>>.  Other kinds of constant subroutine have other treatment.
10942
10943 The subroutine will have an empty prototype and will ignore any arguments
10944 when called.  Its constant behaviour is determined by C<sv>.  If C<sv>
10945 is null, the subroutine will yield an empty list.  If C<sv> points to a
10946 scalar, the subroutine will always yield that scalar.  If C<sv> points
10947 to an array, the subroutine will always yield a list of the elements of
10948 that array in list context, or the number of elements in the array in
10949 scalar context.  This function takes ownership of one counted reference
10950 to the scalar or array, and will arrange for the object to live as long
10951 as the subroutine does.  If C<sv> points to a scalar then the inlining
10952 assumes that the value of the scalar will never change, so the caller
10953 must ensure that the scalar is not subsequently written to.  If C<sv>
10954 points to an array then no such assumption is made, so it is ostensibly
10955 safe to mutate the array or its elements, but whether this is really
10956 supported has not been determined.
10957
10958 The subroutine will have C<CvFILE> set according to C<PL_curcop>.
10959 Other aspects of the subroutine will be left in their default state.
10960 The caller is free to mutate the subroutine beyond its initial state
10961 after this function has returned.
10962
10963 If C<name> is null then the subroutine will be anonymous, with its
10964 C<CvGV> referring to an C<__ANON__> glob.  If C<name> is non-null then the
10965 subroutine will be named accordingly, referenced by the appropriate glob.
10966 C<name> is a string of length C<len> bytes giving a sigilless symbol
10967 name, in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1
10968 otherwise.  The name may be either qualified or unqualified.  If the
10969 name is unqualified then it defaults to being in the stash specified by
10970 C<stash> if that is non-null, or to C<PL_curstash> if C<stash> is null.
10971 The symbol is always added to the stash if necessary, with C<GV_ADDMULTI>
10972 semantics.
10973
10974 C<flags> should not have bits set other than C<SVf_UTF8>.
10975
10976 If there is already a subroutine of the specified name, then the new sub
10977 will replace the existing one in the glob.  A warning may be generated
10978 about the redefinition.
10979
10980 If the subroutine has one of a few special names, such as C<BEGIN> or
10981 C<END>, then it will be claimed by the appropriate queue for automatic
10982 running of phase-related subroutines.  In this case the relevant glob will
10983 be left not containing any subroutine, even if it did contain one before.
10984 Execution of the subroutine will likely be a no-op, unless C<sv> was
10985 a tied array or the caller modified the subroutine in some interesting
10986 way before it was executed.  In the case of C<BEGIN>, the treatment is
10987 buggy: the sub will be executed when only half built, and may be deleted
10988 prematurely, possibly causing a crash.
10989
10990 The function returns a pointer to the constructed subroutine.  If the sub
10991 is anonymous then ownership of one counted reference to the subroutine
10992 is transferred to the caller.  If the sub is named then the caller does
10993 not get ownership of a reference.  In most such cases, where the sub
10994 has a non-phase name, the sub will be alive at the point it is returned
10995 by virtue of being contained in the glob that names it.  A phase-named
10996 subroutine will usually be alive by virtue of the reference owned by
10997 the phase's automatic run queue.  A C<BEGIN> subroutine may have been
10998 destroyed already by the time this function returns, but currently bugs
10999 occur in that case before the caller gets control.  It is the caller's
11000 responsibility to ensure that it knows which of these situations applies.
11001
11002 =cut
11003 */
11004
11005 CV *
11006 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
11007                              U32 flags, SV *sv)
11008 {
11009     CV* cv;
11010     const char *const file = CopFILE(PL_curcop);
11011
11012     ENTER;
11013
11014     if (IN_PERL_RUNTIME) {
11015         /* at runtime, it's not safe to manipulate PL_curcop: it may be
11016          * an op shared between threads. Use a non-shared COP for our
11017          * dirty work */
11018          SAVEVPTR(PL_curcop);
11019          SAVECOMPILEWARNINGS();
11020          PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
11021          PL_curcop = &PL_compiling;
11022     }
11023     SAVECOPLINE(PL_curcop);
11024     CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
11025
11026     SAVEHINTS();
11027     PL_hints &= ~HINT_BLOCK_SCOPE;
11028
11029     if (stash) {
11030         SAVEGENERICSV(PL_curstash);
11031         PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
11032     }
11033
11034     /* Protect sv against leakage caused by fatal warnings. */
11035     if (sv) SAVEFREESV(sv);
11036
11037     /* file becomes the CvFILE. For an XS, it's usually static storage,
11038        and so doesn't get free()d.  (It's expected to be from the C pre-
11039        processor __FILE__ directive). But we need a dynamically allocated one,
11040        and we need it to get freed.  */
11041     cv = newXS_len_flags(name, len,
11042                          sv && SvTYPE(sv) == SVt_PVAV
11043                              ? const_av_xsub
11044                              : const_sv_xsub,
11045                          file ? file : "", "",
11046                          &sv, XS_DYNAMIC_FILENAME | flags);
11047     assert(cv);
11048     assert(SvREFCNT((SV*)cv) != 0);
11049     CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
11050     CvCONST_on(cv);
11051
11052     LEAVE;
11053
11054     return cv;
11055 }
11056
11057 /*
11058 =for apidoc newXS
11059
11060 Used by C<xsubpp> to hook up XSUBs as Perl subs.  C<filename> needs to be
11061 static storage, as it is used directly as CvFILE(), without a copy being made.
11062
11063 =cut
11064 */
11065
11066 CV *
11067 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
11068 {
11069     PERL_ARGS_ASSERT_NEWXS;
11070     return newXS_len_flags(
11071         name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
11072     );
11073 }
11074
11075 CV *
11076 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
11077                  const char *const filename, const char *const proto,
11078                  U32 flags)
11079 {
11080     PERL_ARGS_ASSERT_NEWXS_FLAGS;
11081     return newXS_len_flags(
11082        name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
11083     );
11084 }
11085
11086 CV *
11087 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
11088 {
11089     PERL_ARGS_ASSERT_NEWXS_DEFFILE;
11090     return newXS_len_flags(
11091         name, strlen(name), subaddr, NULL, NULL, NULL, 0
11092     );
11093 }
11094
11095 /*
11096 =for apidoc newXS_len_flags
11097
11098 Construct an XS subroutine, also performing some surrounding jobs.
11099
11100 The subroutine will have the entry point C<subaddr>.  It will have
11101 the prototype specified by the nul-terminated string C<proto>, or
11102 no prototype if C<proto> is null.  The prototype string is copied;
11103 the caller can mutate the supplied string afterwards.  If C<filename>
11104 is non-null, it must be a nul-terminated filename, and the subroutine
11105 will have its C<CvFILE> set accordingly.  By default C<CvFILE> is set to
11106 point directly to the supplied string, which must be static.  If C<flags>
11107 has the C<XS_DYNAMIC_FILENAME> bit set, then a copy of the string will
11108 be taken instead.
11109
11110 Other aspects of the subroutine will be left in their default state.
11111 If anything else needs to be done to the subroutine for it to function
11112 correctly, it is the caller's responsibility to do that after this
11113 function has constructed it.  However, beware of the subroutine
11114 potentially being destroyed before this function returns, as described
11115 below.
11116
11117 If C<name> is null then the subroutine will be anonymous, with its
11118 C<CvGV> referring to an C<__ANON__> glob.  If C<name> is non-null then the
11119 subroutine will be named accordingly, referenced by the appropriate glob.
11120 C<name> is a string of length C<len> bytes giving a sigilless symbol name,
11121 in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1 otherwise.
11122 The name may be either qualified or unqualified, with the stash defaulting
11123 in the same manner as for C<gv_fetchpvn_flags>.  C<flags> may contain
11124 flag bits understood by C<gv_fetchpvn_flags> with the same meaning as
11125 they have there, such as C<GV_ADDWARN>.  The symbol is always added to
11126 the stash if necessary, with C<GV_ADDMULTI> semantics.
11127
11128 If there is already a subroutine of the specified name, then the new sub
11129 will replace the existing one in the glob.  A warning may be generated
11130 about the redefinition.  If the old subroutine was C<CvCONST> then the
11131 decision about whether to warn is influenced by an expectation about
11132 whether the new subroutine will become a constant of similar value.
11133 That expectation is determined by C<const_svp>.  (Note that the call to
11134 this function doesn't make the new subroutine C<CvCONST> in any case;
11135 that is left to the caller.)  If C<const_svp> is null then it indicates
11136 that the new subroutine will not become a constant.  If C<const_svp>
11137 is non-null then it indicates that the new subroutine will become a
11138 constant, and it points to an C<SV*> that provides the constant value
11139 that the subroutine will have.
11140
11141 If the subroutine has one of a few special names, such as C<BEGIN> or
11142 C<END>, then it will be claimed by the appropriate queue for automatic
11143 running of phase-related subroutines.  In this case the relevant glob will
11144 be left not containing any subroutine, even if it did contain one before.
11145 In the case of C<BEGIN>, the subroutine will be executed and the reference
11146 to it disposed of before this function returns, and also before its
11147 prototype is set.  If a C<BEGIN> subroutine would not be sufficiently
11148 constructed by this function to be ready for execution then the caller
11149 must prevent this happening by giving the subroutine a different name.
11150
11151 The function returns a pointer to the constructed subroutine.  If the sub
11152 is anonymous then ownership of one counted reference to the subroutine
11153 is transferred to the caller.  If the sub is named then the caller does
11154 not get ownership of a reference.  In most such cases, where the sub
11155 has a non-phase name, the sub will be alive at the point it is returned
11156 by virtue of being contained in the glob that names it.  A phase-named
11157 subroutine will usually be alive by virtue of the reference owned by the
11158 phase's automatic run queue.  But a C<BEGIN> subroutine, having already
11159 been executed, will quite likely have been destroyed already by the
11160 time this function returns, making it erroneous for the caller to make
11161 any use of the returned pointer.  It is the caller's responsibility to
11162 ensure that it knows which of these situations applies.
11163
11164 =cut
11165 */
11166
11167 CV *
11168 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
11169                            XSUBADDR_t subaddr, const char *const filename,
11170                            const char *const proto, SV **const_svp,
11171                            U32 flags)
11172 {
11173     CV *cv;
11174     bool interleave = FALSE;
11175     bool evanescent = FALSE;
11176
11177     PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
11178
11179     {
11180         GV * const gv = gv_fetchpvn(
11181                             name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
11182                             name ? len : PL_curstash ? sizeof("__ANON__") - 1:
11183                                 sizeof("__ANON__::__ANON__") - 1,
11184                             GV_ADDMULTI | flags, SVt_PVCV);
11185
11186         if ((cv = (name ? GvCV(gv) : NULL))) {
11187             if (GvCVGEN(gv)) {
11188                 /* just a cached method */
11189                 SvREFCNT_dec(cv);
11190                 cv = NULL;
11191             }
11192             else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
11193                 /* already defined (or promised) */
11194                 /* Redundant check that allows us to avoid creating an SV
11195                    most of the time: */
11196                 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
11197                     report_redefined_cv(newSVpvn_flags(
11198                                          name,len,(flags&SVf_UTF8)|SVs_TEMP
11199                                         ),
11200                                         cv, const_svp);
11201                 }
11202                 interleave = TRUE;
11203                 ENTER;
11204                 SAVEFREESV(cv);
11205                 cv = NULL;
11206             }
11207         }
11208
11209         if (cv)                         /* must reuse cv if autoloaded */
11210             cv_undef(cv);
11211         else {
11212             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
11213             if (name) {
11214                 GvCV_set(gv,cv);
11215                 GvCVGEN(gv) = 0;
11216                 if (HvENAME_HEK(GvSTASH(gv)))
11217                     gv_method_changed(gv); /* newXS */
11218             }
11219         }
11220         assert(cv);
11221         assert(SvREFCNT((SV*)cv) != 0);
11222
11223         CvGV_set(cv, gv);
11224         if(filename) {
11225             /* XSUBs can't be perl lang/perl5db.pl debugged
11226             if (PERLDB_LINE_OR_SAVESRC)
11227                 (void)gv_fetchfile(filename); */
11228             assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
11229             if (flags & XS_DYNAMIC_FILENAME) {
11230                 CvDYNFILE_on(cv);
11231                 CvFILE(cv) = savepv(filename);
11232             } else {
11233             /* NOTE: not copied, as it is expected to be an external constant string */
11234                 CvFILE(cv) = (char *)filename;
11235             }
11236         } else {
11237             assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
11238             CvFILE(cv) = (char*)PL_xsubfilename;
11239         }
11240         CvISXSUB_on(cv);
11241         CvXSUB(cv) = subaddr;
11242 #ifndef MULTIPLICITY
11243         CvHSCXT(cv) = &PL_stack_sp;
11244 #else
11245         PoisonPADLIST(cv);
11246 #endif
11247
11248         if (name)
11249             evanescent = process_special_blocks(0, name, gv, cv);
11250         else
11251             CvANON_on(cv);
11252     } /* <- not a conditional branch */
11253
11254     assert(cv);
11255     assert(evanescent || SvREFCNT((SV*)cv) != 0);
11256
11257     if (!evanescent) sv_setpv(MUTABLE_SV(cv), proto);
11258     if (interleave) LEAVE;
11259     assert(evanescent || SvREFCNT((SV*)cv) != 0);
11260     return cv;
11261 }
11262
11263 /* Add a stub CV to a typeglob.
11264  * This is the implementation of a forward declaration, 'sub foo';'
11265  */
11266
11267 CV *
11268 Perl_newSTUB(pTHX_ GV *gv, bool fake)
11269 {
11270     CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
11271     GV *cvgv;
11272     PERL_ARGS_ASSERT_NEWSTUB;
11273     assert(!GvCVu(gv));
11274     GvCV_set(gv, cv);
11275     GvCVGEN(gv) = 0;
11276     if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
11277         gv_method_changed(gv);
11278     if (SvFAKE(gv)) {
11279         cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
11280         SvFAKE_off(cvgv);
11281     }
11282     else cvgv = gv;
11283     CvGV_set(cv, cvgv);
11284     CvFILE_set_from_cop(cv, PL_curcop);
11285     CvSTASH_set(cv, PL_curstash);
11286     GvMULTI_on(gv);
11287     return cv;
11288 }
11289
11290 void
11291 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
11292 {
11293     CV *cv;
11294     GV *gv;
11295     OP *root;
11296     OP *start;
11297
11298     if (PL_parser && PL_parser->error_count) {
11299         op_free(block);
11300         goto finish;
11301     }
11302
11303     gv = o
11304         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
11305         : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
11306
11307     GvMULTI_on(gv);
11308     if ((cv = GvFORM(gv))) {
11309         if (ckWARN(WARN_REDEFINE)) {
11310             const line_t oldline = CopLINE(PL_curcop);
11311             if (PL_parser && PL_parser->copline != NOLINE)
11312                 CopLINE_set(PL_curcop, PL_parser->copline);
11313             if (o) {
11314                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
11315                             "Format %" SVf " redefined", SVfARG(cSVOPo->op_sv));
11316             } else {
11317                 /* diag_listed_as: Format %s redefined */
11318                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
11319                             "Format STDOUT redefined");
11320             }
11321             CopLINE_set(PL_curcop, oldline);
11322         }
11323         SvREFCNT_dec(cv);
11324     }
11325     cv = PL_compcv;
11326     GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
11327     CvGV_set(cv, gv);
11328     CvFILE_set_from_cop(cv, PL_curcop);
11329
11330
11331     root = newUNOP(OP_LEAVEWRITE, 0, voidnonfinal(block));
11332     CvROOT(cv) = root;
11333     start = LINKLIST(root);
11334     root->op_next = 0;
11335     S_process_optree(aTHX_ cv, root, start);
11336     cv_forget_slab(cv);
11337
11338   finish:
11339     op_free(o);
11340     if (PL_parser)
11341         PL_parser->copline = NOLINE;
11342     LEAVE_SCOPE(floor);
11343     PL_compiling.cop_seq = 0;
11344 }
11345
11346 OP *
11347 Perl_newANONLIST(pTHX_ OP *o)
11348 {
11349     return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
11350 }
11351
11352 OP *
11353 Perl_newANONHASH(pTHX_ OP *o)
11354 {
11355     return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
11356 }
11357
11358 OP *
11359 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
11360 {
11361     return newANONATTRSUB(floor, proto, NULL, block);
11362 }
11363
11364 OP *
11365 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
11366 {
11367     SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
11368     OP * anoncode =
11369         newSVOP(OP_ANONCODE, 0,
11370                 cv);
11371     if (CvANONCONST(cv))
11372         anoncode = newUNOP(OP_ANONCONST, 0,
11373                            op_convert_list(OP_ENTERSUB,
11374                                            OPf_STACKED|OPf_WANT_SCALAR,
11375                                            anoncode));
11376     return newUNOP(OP_REFGEN, 0, anoncode);
11377 }
11378
11379 OP *
11380 Perl_oopsAV(pTHX_ OP *o)
11381 {
11382
11383     PERL_ARGS_ASSERT_OOPSAV;
11384
11385     switch (o->op_type) {
11386     case OP_PADSV:
11387     case OP_PADHV:
11388         OpTYPE_set(o, OP_PADAV);
11389         return ref(o, OP_RV2AV);
11390
11391     case OP_RV2SV:
11392     case OP_RV2HV:
11393         OpTYPE_set(o, OP_RV2AV);
11394         ref(o, OP_RV2AV);
11395         break;
11396
11397     default:
11398         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
11399         break;
11400     }
11401     return o;
11402 }
11403
11404 OP *
11405 Perl_oopsHV(pTHX_ OP *o)
11406 {
11407
11408     PERL_ARGS_ASSERT_OOPSHV;
11409
11410     switch (o->op_type) {
11411     case OP_PADSV:
11412     case OP_PADAV:
11413         OpTYPE_set(o, OP_PADHV);
11414         return ref(o, OP_RV2HV);
11415
11416     case OP_RV2SV:
11417     case OP_RV2AV:
11418         OpTYPE_set(o, OP_RV2HV);
11419         /* rv2hv steals the bottom bit for its own uses */
11420         o->op_private &= ~OPpARG1_MASK;
11421         ref(o, OP_RV2HV);
11422         break;
11423
11424     default:
11425         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
11426         break;
11427     }
11428     return o;
11429 }
11430
11431 OP *
11432 Perl_newAVREF(pTHX_ OP *o)
11433 {
11434
11435     PERL_ARGS_ASSERT_NEWAVREF;
11436
11437     if (o->op_type == OP_PADANY) {
11438         OpTYPE_set(o, OP_PADAV);
11439         return o;
11440     }
11441     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
11442         Perl_croak(aTHX_ "Can't use an array as a reference");
11443     }
11444     return newUNOP(OP_RV2AV, 0, scalar(o));
11445 }
11446
11447 OP *
11448 Perl_newGVREF(pTHX_ I32 type, OP *o)
11449 {
11450     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
11451         return newUNOP(OP_NULL, 0, o);
11452
11453     if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED &&
11454         ((PL_opargs[type] >> OASHIFT) & 7) == OA_FILEREF &&
11455         o->op_type == OP_CONST && (o->op_private & OPpCONST_BARE)) {
11456         no_bareword_filehandle(SvPVX(cSVOPo_sv));
11457     }
11458
11459     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
11460 }
11461
11462 OP *
11463 Perl_newHVREF(pTHX_ OP *o)
11464 {
11465
11466     PERL_ARGS_ASSERT_NEWHVREF;
11467
11468     if (o->op_type == OP_PADANY) {
11469         OpTYPE_set(o, OP_PADHV);
11470         return o;
11471     }
11472     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
11473         Perl_croak(aTHX_ "Can't use a hash as a reference");
11474     }
11475     return newUNOP(OP_RV2HV, 0, scalar(o));
11476 }
11477
11478 OP *
11479 Perl_newCVREF(pTHX_ I32 flags, OP *o)
11480 {
11481     if (o->op_type == OP_PADANY) {
11482         OpTYPE_set(o, OP_PADCV);
11483     }
11484     return newUNOP(OP_RV2CV, flags, scalar(o));
11485 }
11486
11487 OP *
11488 Perl_newSVREF(pTHX_ OP *o)
11489 {
11490
11491     PERL_ARGS_ASSERT_NEWSVREF;
11492
11493     if (o->op_type == OP_PADANY) {
11494         OpTYPE_set(o, OP_PADSV);
11495         scalar(o);
11496         return o;
11497     }
11498     return newUNOP(OP_RV2SV, 0, scalar(o));
11499 }
11500
11501 /* Check routines. See the comments at the top of this file for details
11502  * on when these are called */
11503
11504 OP *
11505 Perl_ck_anoncode(pTHX_ OP *o)
11506 {
11507     PERL_ARGS_ASSERT_CK_ANONCODE;
11508
11509     cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
11510     cSVOPo->op_sv = NULL;
11511     return o;
11512 }
11513
11514 static void
11515 S_io_hints(pTHX_ OP *o)
11516 {
11517 #if O_BINARY != 0 || O_TEXT != 0
11518     HV * const table =
11519         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
11520     if (table) {
11521         SV **svp = hv_fetchs(table, "open_IN", FALSE);
11522         if (svp && *svp) {
11523             STRLEN len = 0;
11524             const char *d = SvPV_const(*svp, len);
11525             const I32 mode = mode_from_discipline(d, len);
11526             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
11527 #  if O_BINARY != 0
11528             if (mode & O_BINARY)
11529                 o->op_private |= OPpOPEN_IN_RAW;
11530 #  endif
11531 #  if O_TEXT != 0
11532             if (mode & O_TEXT)
11533                 o->op_private |= OPpOPEN_IN_CRLF;
11534 #  endif
11535         }
11536
11537         svp = hv_fetchs(table, "open_OUT", FALSE);
11538         if (svp && *svp) {
11539             STRLEN len = 0;
11540             const char *d = SvPV_const(*svp, len);
11541             const I32 mode = mode_from_discipline(d, len);
11542             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
11543 #  if O_BINARY != 0
11544             if (mode & O_BINARY)
11545                 o->op_private |= OPpOPEN_OUT_RAW;
11546 #  endif
11547 #  if O_TEXT != 0
11548             if (mode & O_TEXT)
11549                 o->op_private |= OPpOPEN_OUT_CRLF;
11550 #  endif
11551         }
11552     }
11553 #else
11554     PERL_UNUSED_CONTEXT;
11555     PERL_UNUSED_ARG(o);
11556 #endif
11557 }
11558
11559 OP *
11560 Perl_ck_backtick(pTHX_ OP *o)
11561 {
11562     GV *gv;
11563     OP *newop = NULL;
11564     OP *sibl;
11565     PERL_ARGS_ASSERT_CK_BACKTICK;
11566     o = ck_fun(o);
11567     /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
11568     if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
11569      && (gv = gv_override("readpipe",8)))
11570     {
11571         /* detach rest of siblings from o and its first child */
11572         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
11573         newop = S_new_entersubop(aTHX_ gv, sibl);
11574     }
11575     else if (!(o->op_flags & OPf_KIDS))
11576         newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
11577     if (newop) {
11578         op_free(o);
11579         return newop;
11580     }
11581     S_io_hints(aTHX_ o);
11582     return o;
11583 }
11584
11585 OP *
11586 Perl_ck_bitop(pTHX_ OP *o)
11587 {
11588     PERL_ARGS_ASSERT_CK_BITOP;
11589
11590     /* get rid of arg count and indicate if in the scope of 'use integer' */
11591     o->op_private = (PL_hints & HINT_INTEGER) ? OPpUSEINT : 0;
11592
11593     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
11594             && OP_IS_INFIX_BIT(o->op_type))
11595     {
11596         const OP * const left = cBINOPo->op_first;
11597         const OP * const right = OpSIBLING(left);
11598         if ((OP_IS_NUMCOMPARE(left->op_type) &&
11599                 (left->op_flags & OPf_PARENS) == 0) ||
11600             (OP_IS_NUMCOMPARE(right->op_type) &&
11601                 (right->op_flags & OPf_PARENS) == 0))
11602             Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
11603                           "Possible precedence problem on bitwise %s operator",
11604                            o->op_type ==  OP_BIT_OR
11605                          ||o->op_type == OP_NBIT_OR  ? "|"
11606                         :  o->op_type ==  OP_BIT_AND
11607                          ||o->op_type == OP_NBIT_AND ? "&"
11608                         :  o->op_type ==  OP_BIT_XOR
11609                          ||o->op_type == OP_NBIT_XOR ? "^"
11610                         :  o->op_type == OP_SBIT_OR  ? "|."
11611                         :  o->op_type == OP_SBIT_AND ? "&." : "^."
11612                            );
11613     }
11614     return o;
11615 }
11616
11617 PERL_STATIC_INLINE bool
11618 is_dollar_bracket(pTHX_ const OP * const o)
11619 {
11620     const OP *kid;
11621     PERL_UNUSED_CONTEXT;
11622     return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
11623         && (kid = cUNOPx(o)->op_first)
11624         && kid->op_type == OP_GV
11625         && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
11626 }
11627
11628 /* for lt, gt, le, ge, eq, ne and their i_ variants */
11629
11630 OP *
11631 Perl_ck_cmp(pTHX_ OP *o)
11632 {
11633     bool is_eq;
11634     bool neg;
11635     bool reverse;
11636     bool iv0;
11637     OP *indexop, *constop, *start;
11638     SV *sv;
11639     IV iv;
11640
11641     PERL_ARGS_ASSERT_CK_CMP;
11642
11643     is_eq = (   o->op_type == OP_EQ
11644              || o->op_type == OP_NE
11645              || o->op_type == OP_I_EQ
11646              || o->op_type == OP_I_NE);
11647
11648     if (!is_eq && ckWARN(WARN_SYNTAX)) {
11649         const OP *kid = cUNOPo->op_first;
11650         if (kid &&
11651             (
11652                 (   is_dollar_bracket(aTHX_ kid)
11653                  && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
11654                 )
11655              || (   kid->op_type == OP_CONST
11656                  && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
11657                 )
11658            )
11659         )
11660             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11661                         "$[ used in %s (did you mean $] ?)", OP_DESC(o));
11662     }
11663
11664     /* convert (index(...) == -1) and variations into
11665      *   (r)index/BOOL(,NEG)
11666      */
11667
11668     reverse = FALSE;
11669
11670     indexop = cUNOPo->op_first;
11671     constop = OpSIBLING(indexop);
11672     start = NULL;
11673     if (indexop->op_type == OP_CONST) {
11674         constop = indexop;
11675         indexop = OpSIBLING(constop);
11676         start = constop;
11677         reverse = TRUE;
11678     }
11679
11680     if (indexop->op_type != OP_INDEX && indexop->op_type != OP_RINDEX)
11681         return o;
11682
11683     /* ($lex = index(....)) == -1 */
11684     if (indexop->op_private & OPpTARGET_MY)
11685         return o;
11686
11687     if (constop->op_type != OP_CONST)
11688         return o;
11689
11690     sv = cSVOPx_sv(constop);
11691     if (!(sv && SvIOK_notUV(sv)))
11692         return o;
11693
11694     iv = SvIVX(sv);
11695     if (iv != -1 && iv != 0)
11696         return o;
11697     iv0 = (iv == 0);
11698
11699     if (o->op_type == OP_LT || o->op_type == OP_I_LT) {
11700         if (!(iv0 ^ reverse))
11701             return o;
11702         neg = iv0;
11703     }
11704     else if (o->op_type == OP_LE || o->op_type == OP_I_LE) {
11705         if (iv0 ^ reverse)
11706             return o;
11707         neg = !iv0;
11708     }
11709     else if (o->op_type == OP_GE || o->op_type == OP_I_GE) {
11710         if (!(iv0 ^ reverse))
11711             return o;
11712         neg = !iv0;
11713     }
11714     else if (o->op_type == OP_GT || o->op_type == OP_I_GT) {
11715         if (iv0 ^ reverse)
11716             return o;
11717         neg = iv0;
11718     }
11719     else if (o->op_type == OP_EQ || o->op_type == OP_I_EQ) {
11720         if (iv0)
11721             return o;
11722         neg = TRUE;
11723     }
11724     else {
11725         assert(o->op_type == OP_NE || o->op_type == OP_I_NE);
11726         if (iv0)
11727             return o;
11728         neg = FALSE;
11729     }
11730
11731     indexop->op_flags &= ~OPf_PARENS;
11732     indexop->op_flags |= (o->op_flags & OPf_PARENS);
11733     indexop->op_private |= OPpTRUEBOOL;
11734     if (neg)
11735         indexop->op_private |= OPpINDEX_BOOLNEG;
11736     /* cut out the index op and free the eq,const ops */
11737     (void)op_sibling_splice(o, start, 1, NULL);
11738     op_free(o);
11739
11740     return indexop;
11741 }
11742
11743
11744 OP *
11745 Perl_ck_concat(pTHX_ OP *o)
11746 {
11747     const OP * const kid = cUNOPo->op_first;
11748
11749     PERL_ARGS_ASSERT_CK_CONCAT;
11750     PERL_UNUSED_CONTEXT;
11751
11752     /* reuse the padtmp returned by the concat child */
11753     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
11754             !(kUNOP->op_first->op_flags & OPf_MOD))
11755     {
11756         o->op_flags |= OPf_STACKED;
11757         o->op_private |= OPpCONCAT_NESTED;
11758     }
11759     return o;
11760 }
11761
11762 OP *
11763 Perl_ck_spair(pTHX_ OP *o)
11764 {
11765
11766     PERL_ARGS_ASSERT_CK_SPAIR;
11767
11768     if (o->op_flags & OPf_KIDS) {
11769         OP* newop;
11770         OP* kid;
11771         OP* kidkid;
11772         const OPCODE type = o->op_type;
11773         o = modkids(ck_fun(o), type);
11774         kid    = cUNOPo->op_first;
11775         kidkid = kUNOP->op_first;
11776         newop = OpSIBLING(kidkid);
11777         if (newop) {
11778             const OPCODE type = newop->op_type;
11779             if (OpHAS_SIBLING(newop))
11780                 return o;
11781             if (o->op_type == OP_REFGEN
11782              && (  type == OP_RV2CV
11783                 || (  !(newop->op_flags & OPf_PARENS)
11784                    && (  type == OP_RV2AV || type == OP_PADAV
11785                       || type == OP_RV2HV || type == OP_PADHV))))
11786                 NOOP; /* OK (allow srefgen for \@a and \%h) */
11787             else if (OP_GIMME(newop,0) != G_SCALAR)
11788                 return o;
11789         }
11790         /* excise first sibling */
11791         op_sibling_splice(kid, NULL, 1, NULL);
11792         op_free(kidkid);
11793     }
11794     /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
11795      * and OP_CHOMP into OP_SCHOMP */
11796     o->op_ppaddr = PL_ppaddr[++o->op_type];
11797     return ck_fun(o);
11798 }
11799
11800 OP *
11801 Perl_ck_delete(pTHX_ OP *o)
11802 {
11803     PERL_ARGS_ASSERT_CK_DELETE;
11804
11805     o = ck_fun(o);
11806     o->op_private = 0;
11807     if (o->op_flags & OPf_KIDS) {
11808         OP * const kid = cUNOPo->op_first;
11809         switch (kid->op_type) {
11810         case OP_ASLICE:
11811             o->op_flags |= OPf_SPECIAL;
11812             /* FALLTHROUGH */
11813         case OP_HSLICE:
11814             o->op_private |= OPpSLICE;
11815             break;
11816         case OP_AELEM:
11817             o->op_flags |= OPf_SPECIAL;
11818             /* FALLTHROUGH */
11819         case OP_HELEM:
11820             break;
11821         case OP_KVASLICE:
11822             o->op_flags |= OPf_SPECIAL;
11823             /* FALLTHROUGH */
11824         case OP_KVHSLICE:
11825             o->op_private |= OPpKVSLICE;
11826             break;
11827         default:
11828             Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
11829                              "element or slice");
11830         }
11831         if (kid->op_private & OPpLVAL_INTRO)
11832             o->op_private |= OPpLVAL_INTRO;
11833         op_null(kid);
11834     }
11835     return o;
11836 }
11837
11838 OP *
11839 Perl_ck_eof(pTHX_ OP *o)
11840 {
11841     PERL_ARGS_ASSERT_CK_EOF;
11842
11843     if (o->op_flags & OPf_KIDS) {
11844         OP *kid;
11845         if (cLISTOPo->op_first->op_type == OP_STUB) {
11846             OP * const newop
11847                 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
11848             op_free(o);
11849             o = newop;
11850         }
11851         o = ck_fun(o);
11852         kid = cLISTOPo->op_first;
11853         if (kid->op_type == OP_RV2GV)
11854             kid->op_private |= OPpALLOW_FAKE;
11855     }
11856     return o;
11857 }
11858
11859
11860 OP *
11861 Perl_ck_eval(pTHX_ OP *o)
11862 {
11863
11864     PERL_ARGS_ASSERT_CK_EVAL;
11865
11866     PL_hints |= HINT_BLOCK_SCOPE;
11867     if (o->op_flags & OPf_KIDS) {
11868         SVOP * const kid = cSVOPx(cUNOPo->op_first);
11869         assert(kid);
11870
11871         if (o->op_type == OP_ENTERTRY) {
11872             LOGOP *enter;
11873
11874             /* cut whole sibling chain free from o */
11875             op_sibling_splice(o, NULL, -1, NULL);
11876             op_free(o);
11877
11878             enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL);
11879
11880             /* establish postfix order */
11881             enter->op_next = (OP*)enter;
11882
11883             o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
11884             OpTYPE_set(o, OP_LEAVETRY);
11885             enter->op_other = o;
11886             return o;
11887         }
11888         else {
11889             scalar((OP*)kid);
11890             S_set_haseval(aTHX);
11891         }
11892     }
11893     else {
11894         const U8 priv = o->op_private;
11895         op_free(o);
11896         /* the newUNOP will recursively call ck_eval(), which will handle
11897          * all the stuff at the end of this function, like adding
11898          * OP_HINTSEVAL
11899          */
11900         return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
11901     }
11902     o->op_targ = (PADOFFSET)PL_hints;
11903     if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
11904     if ((PL_hints & HINT_LOCALIZE_HH) != 0
11905      && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
11906         /* Store a copy of %^H that pp_entereval can pick up. */
11907         HV *hh = hv_copy_hints_hv(GvHV(PL_hintgv));
11908         OP *hhop;
11909         STOREFEATUREBITSHH(hh);
11910         hhop = newSVOP(OP_HINTSEVAL, 0, MUTABLE_SV(hh));
11911         /* append hhop to only child  */
11912         op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
11913
11914         o->op_private |= OPpEVAL_HAS_HH;
11915     }
11916     if (!(o->op_private & OPpEVAL_BYTES)
11917          && FEATURE_UNIEVAL_IS_ENABLED)
11918             o->op_private |= OPpEVAL_UNICODE;
11919     return o;
11920 }
11921
11922 OP *
11923 Perl_ck_trycatch(pTHX_ OP *o)
11924 {
11925     LOGOP *enter;
11926     OP *to_free = NULL;
11927     OP *trykid, *catchkid;
11928     OP *catchroot, *catchstart;
11929
11930     PERL_ARGS_ASSERT_CK_TRYCATCH;
11931
11932     trykid = cUNOPo->op_first;
11933     if(trykid->op_type == OP_NULL || trykid->op_type == OP_PUSHMARK) {
11934         to_free = trykid;
11935         trykid = OpSIBLING(trykid);
11936     }
11937     catchkid = OpSIBLING(trykid);
11938
11939     assert(trykid->op_type == OP_POPTRY);
11940     assert(catchkid->op_type == OP_CATCH);
11941
11942     /* cut whole sibling chain free from o */
11943     op_sibling_splice(o, NULL, -1, NULL);
11944     if(to_free)
11945         op_free(to_free);
11946     op_free(o);
11947
11948     enter = alloc_LOGOP(OP_ENTERTRYCATCH, NULL, NULL);
11949
11950     /* establish postfix order */
11951     enter->op_next = (OP*)enter;
11952
11953     o = op_prepend_elem(OP_LINESEQ, (OP*)enter, trykid);
11954     op_append_elem(OP_LINESEQ, (OP*)o, catchkid);
11955
11956     OpTYPE_set(o, OP_LEAVETRYCATCH);
11957
11958     /* The returned optree is actually threaded up slightly nonobviously in
11959      * terms of its ->op_next pointers.
11960      *
11961      * This way, if the tryblock dies, its retop points at the OP_CATCH, but
11962      * if it does not then its leavetry skips over that and continues
11963      * execution past it.
11964      */
11965
11966     /* First, link up the actual body of the catch block */
11967     catchroot = OpSIBLING(cUNOPx(catchkid)->op_first);
11968     catchstart = LINKLIST(catchroot);
11969     cLOGOPx(catchkid)->op_other = catchstart;
11970
11971     o->op_next = LINKLIST(o);
11972
11973     /* die within try block should jump to the catch */
11974     enter->op_other = catchkid;
11975
11976     /* after try block that doesn't die, just skip straight to leavetrycatch */
11977     trykid->op_next = o;
11978
11979     /* after catch block, skip back up to the leavetrycatch */
11980     catchroot->op_next = o;
11981
11982     return o;
11983 }
11984
11985 OP *
11986 Perl_ck_exec(pTHX_ OP *o)
11987 {
11988     PERL_ARGS_ASSERT_CK_EXEC;
11989
11990     if (o->op_flags & OPf_STACKED) {
11991         OP *kid;
11992         o = ck_fun(o);
11993         kid = OpSIBLING(cUNOPo->op_first);
11994         if (kid->op_type == OP_RV2GV)
11995             op_null(kid);
11996     }
11997     else
11998         o = listkids(o);
11999     return o;
12000 }
12001
12002 OP *
12003 Perl_ck_exists(pTHX_ OP *o)
12004 {
12005     PERL_ARGS_ASSERT_CK_EXISTS;
12006
12007     o = ck_fun(o);
12008     if (o->op_flags & OPf_KIDS) {
12009         OP * const kid = cUNOPo->op_first;
12010         if (kid->op_type == OP_ENTERSUB) {
12011             (void) ref(kid, o->op_type);
12012             if (kid->op_type != OP_RV2CV
12013                         && !(PL_parser && PL_parser->error_count))
12014                 Perl_croak(aTHX_
12015                           "exists argument is not a subroutine name");
12016             o->op_private |= OPpEXISTS_SUB;
12017         }
12018         else if (kid->op_type == OP_AELEM)
12019             o->op_flags |= OPf_SPECIAL;
12020         else if (kid->op_type != OP_HELEM)
12021             Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
12022                              "element or a subroutine");
12023         op_null(kid);
12024     }
12025     return o;
12026 }
12027
12028 OP *
12029 Perl_ck_rvconst(pTHX_ OP *o)
12030 {
12031     SVOP * const kid = cSVOPx(cUNOPo->op_first);
12032
12033     PERL_ARGS_ASSERT_CK_RVCONST;
12034
12035     if (o->op_type == OP_RV2HV)
12036         /* rv2hv steals the bottom bit for its own uses */
12037         o->op_private &= ~OPpARG1_MASK;
12038
12039     o->op_private |= (PL_hints & HINT_STRICT_REFS);
12040
12041     if (kid->op_type == OP_CONST) {
12042         int iscv;
12043         GV *gv;
12044         SV * const kidsv = kid->op_sv;
12045
12046         /* Is it a constant from cv_const_sv()? */
12047         if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
12048             return o;
12049         }
12050         if (SvTYPE(kidsv) == SVt_PVAV) return o;
12051         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
12052             const char *badthing;
12053             switch (o->op_type) {
12054             case OP_RV2SV:
12055                 badthing = "a SCALAR";
12056                 break;
12057             case OP_RV2AV:
12058                 badthing = "an ARRAY";
12059                 break;
12060             case OP_RV2HV:
12061                 badthing = "a HASH";
12062                 break;
12063             default:
12064                 badthing = NULL;
12065                 break;
12066             }
12067             if (badthing)
12068                 Perl_croak(aTHX_
12069                            "Can't use bareword (\"%" SVf "\") as %s ref while \"strict refs\" in use",
12070                            SVfARG(kidsv), badthing);
12071         }
12072         /*
12073          * This is a little tricky.  We only want to add the symbol if we
12074          * didn't add it in the lexer.  Otherwise we get duplicate strict
12075          * warnings.  But if we didn't add it in the lexer, we must at
12076          * least pretend like we wanted to add it even if it existed before,
12077          * or we get possible typo warnings.  OPpCONST_ENTERED says
12078          * whether the lexer already added THIS instance of this symbol.
12079          */
12080         iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
12081         gv = gv_fetchsv(kidsv,
12082                 o->op_type == OP_RV2CV
12083                         && o->op_private & OPpMAY_RETURN_CONSTANT
12084                     ? GV_NOEXPAND
12085                     : iscv | !(kid->op_private & OPpCONST_ENTERED),
12086                 iscv
12087                     ? SVt_PVCV
12088                     : o->op_type == OP_RV2SV
12089                         ? SVt_PV
12090                         : o->op_type == OP_RV2AV
12091                             ? SVt_PVAV
12092                             : o->op_type == OP_RV2HV
12093                                 ? SVt_PVHV
12094                                 : SVt_PVGV);
12095         if (gv) {
12096             if (!isGV(gv)) {
12097                 assert(iscv);
12098                 assert(SvROK(gv));
12099                 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
12100                   && SvTYPE(SvRV(gv)) != SVt_PVCV)
12101                     gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
12102             }
12103             OpTYPE_set(kid, OP_GV);
12104             SvREFCNT_dec(kid->op_sv);
12105 #ifdef USE_ITHREADS
12106             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
12107             STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
12108             kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
12109             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
12110             PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
12111 #else
12112             kid->op_sv = SvREFCNT_inc_simple_NN(gv);
12113 #endif
12114             kid->op_private = 0;
12115             /* FAKE globs in the symbol table cause weird bugs (#77810) */
12116             SvFAKE_off(gv);
12117         }
12118     }
12119     return o;
12120 }
12121
12122 OP *
12123 Perl_ck_ftst(pTHX_ OP *o)
12124 {
12125     const I32 type = o->op_type;
12126
12127     PERL_ARGS_ASSERT_CK_FTST;
12128
12129     if (o->op_flags & OPf_REF) {
12130         NOOP;
12131     }
12132     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
12133         SVOP * const kid = cSVOPx(cUNOPo->op_first);
12134         const OPCODE kidtype = kid->op_type;
12135
12136         if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
12137          && !kid->op_folded) {
12138             if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED) {
12139                 no_bareword_filehandle(SvPVX(kSVOP_sv));
12140             }
12141             OP * const newop = newGVOP(type, OPf_REF,
12142                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
12143             op_free(o);
12144             return newop;
12145         }
12146
12147         if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
12148             SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
12149             if (name) {
12150                 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
12151                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
12152                             array_passed_to_stat, name);
12153             }
12154             else {
12155                 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
12156                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
12157             }
12158        }
12159         scalar((OP *) kid);
12160         if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
12161             o->op_private |= OPpFT_ACCESS;
12162         if (OP_IS_FILETEST(type)
12163             && OP_IS_FILETEST(kidtype)
12164         ) {
12165             o->op_private |= OPpFT_STACKED;
12166             kid->op_private |= OPpFT_STACKING;
12167             if (kidtype == OP_FTTTY && (
12168                    !(kid->op_private & OPpFT_STACKED)
12169                 || kid->op_private & OPpFT_AFTER_t
12170                ))
12171                 o->op_private |= OPpFT_AFTER_t;
12172         }
12173     }
12174     else {
12175         op_free(o);
12176         if (type == OP_FTTTY)
12177             o = newGVOP(type, OPf_REF, PL_stdingv);
12178         else
12179             o = newUNOP(type, 0, newDEFSVOP());
12180     }
12181     return o;
12182 }
12183
12184 OP *
12185 Perl_ck_fun(pTHX_ OP *o)
12186 {
12187     const int type = o->op_type;
12188     I32 oa = PL_opargs[type] >> OASHIFT;
12189
12190     PERL_ARGS_ASSERT_CK_FUN;
12191
12192     if (o->op_flags & OPf_STACKED) {
12193         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
12194             oa &= ~OA_OPTIONAL;
12195         else
12196             return no_fh_allowed(o);
12197     }
12198
12199     if (o->op_flags & OPf_KIDS) {
12200         OP *prev_kid = NULL;
12201         OP *kid = cLISTOPo->op_first;
12202         I32 numargs = 0;
12203         bool seen_optional = FALSE;
12204
12205         if (kid->op_type == OP_PUSHMARK ||
12206             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
12207         {
12208             prev_kid = kid;
12209             kid = OpSIBLING(kid);
12210         }
12211         if (kid && kid->op_type == OP_COREARGS) {
12212             bool optional = FALSE;
12213             while (oa) {
12214                 numargs++;
12215                 if (oa & OA_OPTIONAL) optional = TRUE;
12216                 oa = oa >> 4;
12217             }
12218             if (optional) o->op_private |= numargs;
12219             return o;
12220         }
12221
12222         while (oa) {
12223             if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
12224                 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
12225                     kid = newDEFSVOP();
12226                     /* append kid to chain */
12227                     op_sibling_splice(o, prev_kid, 0, kid);
12228                 }
12229                 seen_optional = TRUE;
12230             }
12231             if (!kid) break;
12232
12233             numargs++;
12234             switch (oa & 7) {
12235             case OA_SCALAR:
12236                 /* list seen where single (scalar) arg expected? */
12237                 if (numargs == 1 && !(oa >> 4)
12238                     && kid->op_type == OP_LIST && type != OP_SCALAR)
12239                 {
12240                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
12241                 }
12242                 if (type != OP_DELETE) scalar(kid);
12243                 break;
12244             case OA_LIST:
12245                 if (oa < 16) {
12246                     kid = 0;
12247                     continue;
12248                 }
12249                 else
12250                     list(kid);
12251                 break;
12252             case OA_AVREF:
12253                 if ((type == OP_PUSH || type == OP_UNSHIFT)
12254                     && !OpHAS_SIBLING(kid))
12255                     Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
12256                                    "Useless use of %s with no values",
12257                                    PL_op_desc[type]);
12258
12259                 if (kid->op_type == OP_CONST
12260                       && (  !SvROK(cSVOPx_sv(kid))
12261                          || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV  )
12262                         )
12263                     bad_type_pv(numargs, "array", o, kid);
12264                 else if (kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV
12265                          || kid->op_type == OP_RV2GV) {
12266                     bad_type_pv(1, "array", o, kid);
12267                 }
12268                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
12269                     yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
12270                                          PL_op_desc[type]), 0);
12271                 }
12272                 else {
12273                     op_lvalue(kid, type);
12274                 }
12275                 break;
12276             case OA_HVREF:
12277                 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
12278                     bad_type_pv(numargs, "hash", o, kid);
12279                 op_lvalue(kid, type);
12280                 break;
12281             case OA_CVREF:
12282                 {
12283                     /* replace kid with newop in chain */
12284                     OP * const newop =
12285                         S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
12286                     newop->op_next = newop;
12287                     kid = newop;
12288                 }
12289                 break;
12290             case OA_FILEREF:
12291                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
12292                     if (kid->op_type == OP_CONST &&
12293                         (kid->op_private & OPpCONST_BARE))
12294                     {
12295                         OP * const newop = newGVOP(OP_GV, 0,
12296                             gv_fetchsv(kSVOP->op_sv, GV_ADD, SVt_PVIO));
12297                         /* a first argument is handled by toke.c, ideally we'd
12298                          just check here but several ops don't use ck_fun() */
12299                         if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED) {
12300                             no_bareword_filehandle(SvPVX(kSVOP_sv));
12301                         }
12302                         /* replace kid with newop in chain */
12303                         op_sibling_splice(o, prev_kid, 1, newop);
12304                         op_free(kid);
12305                         kid = newop;
12306                     }
12307                     else if (kid->op_type == OP_READLINE) {
12308                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
12309                         bad_type_pv(numargs, "HANDLE", o, kid);
12310                     }
12311                     else {
12312                         I32 flags = OPf_SPECIAL;
12313                         I32 priv = 0;
12314                         PADOFFSET targ = 0;
12315
12316                         /* is this op a FH constructor? */
12317                         if (is_handle_constructor(o,numargs)) {
12318                             const char *name = NULL;
12319                             STRLEN len = 0;
12320                             U32 name_utf8 = 0;
12321                             bool want_dollar = TRUE;
12322
12323                             flags = 0;
12324                             /* Set a flag to tell rv2gv to vivify
12325                              * need to "prove" flag does not mean something
12326                              * else already - NI-S 1999/05/07
12327                              */
12328                             priv = OPpDEREF;
12329                             if (kid->op_type == OP_PADSV) {
12330                                 PADNAME * const pn
12331                                     = PAD_COMPNAME_SV(kid->op_targ);
12332                                 name = PadnamePV (pn);
12333                                 len  = PadnameLEN(pn);
12334                                 name_utf8 = PadnameUTF8(pn);
12335                             }
12336                             else if (kid->op_type == OP_RV2SV
12337                                      && kUNOP->op_first->op_type == OP_GV)
12338                             {
12339                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
12340                                 name = GvNAME(gv);
12341                                 len = GvNAMELEN(gv);
12342                                 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
12343                             }
12344                             else if (kid->op_type == OP_AELEM
12345                                      || kid->op_type == OP_HELEM)
12346                             {
12347                                  OP *firstop;
12348                                  OP *op = kBINOP->op_first;
12349                                  name = NULL;
12350                                  if (op) {
12351                                       SV *tmpstr = NULL;
12352                                       const char * const a =
12353                                            kid->op_type == OP_AELEM ?
12354                                            "[]" : "{}";
12355                                       if (((op->op_type == OP_RV2AV) ||
12356                                            (op->op_type == OP_RV2HV)) &&
12357                                           (firstop = cUNOPx(op)->op_first) &&
12358                                           (firstop->op_type == OP_GV)) {
12359                                            /* packagevar $a[] or $h{} */
12360                                            GV * const gv = cGVOPx_gv(firstop);
12361                                            if (gv)
12362                                                 tmpstr =
12363                                                      Perl_newSVpvf(aTHX_
12364                                                                    "%s%c...%c",
12365                                                                    GvNAME(gv),
12366                                                                    a[0], a[1]);
12367                                       }
12368                                       else if (op->op_type == OP_PADAV
12369                                                || op->op_type == OP_PADHV) {
12370                                            /* lexicalvar $a[] or $h{} */
12371                                            const char * const padname =
12372                                                 PAD_COMPNAME_PV(op->op_targ);
12373                                            if (padname)
12374                                                 tmpstr =
12375                                                      Perl_newSVpvf(aTHX_
12376                                                                    "%s%c...%c",
12377                                                                    padname + 1,
12378                                                                    a[0], a[1]);
12379                                       }
12380                                       if (tmpstr) {
12381                                            name = SvPV_const(tmpstr, len);
12382                                            name_utf8 = SvUTF8(tmpstr);
12383                                            sv_2mortal(tmpstr);
12384                                       }
12385                                  }
12386                                  if (!name) {
12387                                       name = "__ANONIO__";
12388                                       len = 10;
12389                                       want_dollar = FALSE;
12390                                  }
12391                                  op_lvalue(kid, type);
12392                             }
12393                             if (name) {
12394                                 SV *namesv;
12395                                 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
12396                                 namesv = PAD_SVl(targ);
12397                                 if (want_dollar && *name != '$')
12398                                     sv_setpvs(namesv, "$");
12399                                 else
12400                                     SvPVCLEAR(namesv);
12401                                 sv_catpvn(namesv, name, len);
12402                                 if ( name_utf8 ) SvUTF8_on(namesv);
12403                             }
12404                         }
12405                         scalar(kid);
12406                         kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
12407                                     OP_RV2GV, flags);
12408                         kid->op_targ = targ;
12409                         kid->op_private |= priv;
12410                     }
12411                 }
12412                 scalar(kid);
12413                 break;
12414             case OA_SCALARREF:
12415                 if ((type == OP_UNDEF || type == OP_POS)
12416                     && numargs == 1 && !(oa >> 4)
12417                     && kid->op_type == OP_LIST)
12418                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
12419                 op_lvalue(scalar(kid), type);
12420                 break;
12421             }
12422             oa >>= 4;
12423             prev_kid = kid;
12424             kid = OpSIBLING(kid);
12425         }
12426         /* FIXME - should the numargs or-ing move after the too many
12427          * arguments check? */
12428         o->op_private |= numargs;
12429         if (kid)
12430             return too_many_arguments_pv(o,OP_DESC(o), 0);
12431         listkids(o);
12432     }
12433     else if (PL_opargs[type] & OA_DEFGV) {
12434         /* Ordering of these two is important to keep f_map.t passing.  */
12435         op_free(o);
12436         return newUNOP(type, 0, newDEFSVOP());
12437     }
12438
12439     if (oa) {
12440         while (oa & OA_OPTIONAL)
12441             oa >>= 4;
12442         if (oa && oa != OA_LIST)
12443             return too_few_arguments_pv(o,OP_DESC(o), 0);
12444     }
12445     return o;
12446 }
12447
12448 OP *
12449 Perl_ck_glob(pTHX_ OP *o)
12450 {
12451     GV *gv;
12452
12453     PERL_ARGS_ASSERT_CK_GLOB;
12454
12455     o = ck_fun(o);
12456     if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
12457         op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
12458
12459     if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
12460     {
12461         /* convert
12462          *     glob
12463          *       \ null - const(wildcard)
12464          * into
12465          *     null
12466          *       \ enter
12467          *            \ list
12468          *                 \ mark - glob - rv2cv
12469          *                             |        \ gv(CORE::GLOBAL::glob)
12470          *                             |
12471          *                              \ null - const(wildcard)
12472          */
12473         o->op_flags |= OPf_SPECIAL;
12474         o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
12475         o = S_new_entersubop(aTHX_ gv, o);
12476         o = newUNOP(OP_NULL, 0, o);
12477         o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
12478         return o;
12479     }
12480     else o->op_flags &= ~OPf_SPECIAL;
12481 #if !defined(PERL_EXTERNAL_GLOB)
12482     if (!PL_globhook) {
12483         ENTER;
12484         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
12485                                newSVpvs("File::Glob"), NULL, NULL, NULL);
12486         LEAVE;
12487     }
12488 #endif /* !PERL_EXTERNAL_GLOB */
12489     gv = (GV *)newSV_type(SVt_NULL);
12490     gv_init(gv, 0, "", 0, 0);
12491     gv_IOadd(gv);
12492     op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
12493     SvREFCNT_dec_NN(gv); /* newGVOP increased it */
12494     scalarkids(o);
12495     return o;
12496 }
12497
12498 OP *
12499 Perl_ck_grep(pTHX_ OP *o)
12500 {
12501     LOGOP *gwop;
12502     OP *kid;
12503     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
12504
12505     PERL_ARGS_ASSERT_CK_GREP;
12506
12507     /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
12508
12509     if (o->op_flags & OPf_STACKED) {
12510         kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
12511         if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
12512             return no_fh_allowed(o);
12513         o->op_flags &= ~OPf_STACKED;
12514     }
12515     kid = OpSIBLING(cLISTOPo->op_first);
12516     if (type == OP_MAPWHILE)
12517         list(kid);
12518     else
12519         scalar(kid);
12520     o = ck_fun(o);
12521     if (PL_parser && PL_parser->error_count)
12522         return o;
12523     kid = OpSIBLING(cLISTOPo->op_first);
12524     if (kid->op_type != OP_NULL)
12525         Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
12526     kid = kUNOP->op_first;
12527
12528     gwop = alloc_LOGOP(type, o, LINKLIST(kid));
12529     kid->op_next = (OP*)gwop;
12530     o->op_private = gwop->op_private = 0;
12531     gwop->op_targ = pad_alloc(type, SVs_PADTMP);
12532
12533     kid = OpSIBLING(cLISTOPo->op_first);
12534     for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
12535         op_lvalue(kid, OP_GREPSTART);
12536
12537     return (OP*)gwop;
12538 }
12539
12540 OP *
12541 Perl_ck_index(pTHX_ OP *o)
12542 {
12543     PERL_ARGS_ASSERT_CK_INDEX;
12544
12545     if (o->op_flags & OPf_KIDS) {
12546         OP *kid = OpSIBLING(cLISTOPo->op_first);        /* get past pushmark */
12547         if (kid)
12548             kid = OpSIBLING(kid);                       /* get past "big" */
12549         if (kid && kid->op_type == OP_CONST) {
12550             const bool save_taint = TAINT_get;
12551             SV *sv = kSVOP->op_sv;
12552             if (   (!SvPOK(sv) || SvNIOKp(sv) || isREGEXP(sv))
12553                 && SvOK(sv) && !SvROK(sv))
12554             {
12555                 sv = newSV_type(SVt_NULL);
12556                 sv_copypv(sv, kSVOP->op_sv);
12557                 SvREFCNT_dec_NN(kSVOP->op_sv);
12558                 kSVOP->op_sv = sv;
12559             }
12560             if (SvOK(sv)) fbm_compile(sv, 0);
12561             TAINT_set(save_taint);
12562 #ifdef NO_TAINT_SUPPORT
12563             PERL_UNUSED_VAR(save_taint);
12564 #endif
12565         }
12566     }
12567     return ck_fun(o);
12568 }
12569
12570 OP *
12571 Perl_ck_lfun(pTHX_ OP *o)
12572 {
12573     const OPCODE type = o->op_type;
12574
12575     PERL_ARGS_ASSERT_CK_LFUN;
12576
12577     return modkids(ck_fun(o), type);
12578 }
12579
12580 OP *
12581 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
12582 {
12583     PERL_ARGS_ASSERT_CK_DEFINED;
12584
12585     if ((o->op_flags & OPf_KIDS)) {
12586         switch (cUNOPo->op_first->op_type) {
12587         case OP_RV2AV:
12588         case OP_PADAV:
12589             Perl_croak(aTHX_ "Can't use 'defined(@array)'"
12590                              " (Maybe you should just omit the defined()?)");
12591             NOT_REACHED; /* NOTREACHED */
12592             break;
12593         case OP_RV2HV:
12594         case OP_PADHV:
12595             Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
12596                              " (Maybe you should just omit the defined()?)");
12597             NOT_REACHED; /* NOTREACHED */
12598             break;
12599         default:
12600             /* no warning */
12601             break;
12602         }
12603     }
12604     return ck_rfun(o);
12605 }
12606
12607 OP *
12608 Perl_ck_readline(pTHX_ OP *o)
12609 {
12610     PERL_ARGS_ASSERT_CK_READLINE;
12611
12612     if (o->op_flags & OPf_KIDS) {
12613          OP *kid = cLISTOPo->op_first;
12614          if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED
12615              && kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
12616              no_bareword_filehandle(SvPVX(kSVOP_sv));
12617          }
12618          if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
12619          scalar(kid);
12620     }
12621     else {
12622         OP * const newop
12623             = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
12624         op_free(o);
12625         return newop;
12626     }
12627     return o;
12628 }
12629
12630 OP *
12631 Perl_ck_rfun(pTHX_ OP *o)
12632 {
12633     const OPCODE type = o->op_type;
12634
12635     PERL_ARGS_ASSERT_CK_RFUN;
12636
12637     return refkids(ck_fun(o), type);
12638 }
12639
12640 OP *
12641 Perl_ck_listiob(pTHX_ OP *o)
12642 {
12643     OP *kid;
12644
12645     PERL_ARGS_ASSERT_CK_LISTIOB;
12646
12647     kid = cLISTOPo->op_first;
12648     if (!kid) {
12649         o = force_list(o, TRUE);
12650         kid = cLISTOPo->op_first;
12651     }
12652     if (kid->op_type == OP_PUSHMARK)
12653         kid = OpSIBLING(kid);
12654     if (kid && o->op_flags & OPf_STACKED)
12655         kid = OpSIBLING(kid);
12656     else if (kid && !OpHAS_SIBLING(kid)) {              /* print HANDLE; */
12657         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
12658          && !kid->op_folded) {
12659             if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED) {
12660                 no_bareword_filehandle(SvPVX(kSVOP_sv));
12661             }
12662             o->op_flags |= OPf_STACKED; /* make it a filehandle */
12663             scalar(kid);
12664             /* replace old const op with new OP_RV2GV parent */
12665             kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
12666                                         OP_RV2GV, OPf_REF);
12667             kid = OpSIBLING(kid);
12668         }
12669     }
12670
12671     if (!kid)
12672         op_append_elem(o->op_type, o, newDEFSVOP());
12673
12674     if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
12675     return listkids(o);
12676 }
12677
12678 OP *
12679 Perl_ck_smartmatch(pTHX_ OP *o)
12680 {
12681     PERL_ARGS_ASSERT_CK_SMARTMATCH;
12682     if (0 == (o->op_flags & OPf_SPECIAL)) {
12683         OP *first  = cBINOPo->op_first;
12684         OP *second = OpSIBLING(first);
12685
12686         /* Implicitly take a reference to an array or hash */
12687
12688         /* remove the original two siblings, then add back the
12689          * (possibly different) first and second sibs.
12690          */
12691         op_sibling_splice(o, NULL, 1, NULL);
12692         op_sibling_splice(o, NULL, 1, NULL);
12693         first  = ref_array_or_hash(first);
12694         second = ref_array_or_hash(second);
12695         op_sibling_splice(o, NULL, 0, second);
12696         op_sibling_splice(o, NULL, 0, first);
12697
12698         /* Implicitly take a reference to a regular expression */
12699         if (first->op_type == OP_MATCH && !(first->op_flags & OPf_STACKED)) {
12700             OpTYPE_set(first, OP_QR);
12701         }
12702         if (second->op_type == OP_MATCH && !(second->op_flags & OPf_STACKED)) {
12703             OpTYPE_set(second, OP_QR);
12704         }
12705     }
12706
12707     return o;
12708 }
12709
12710
12711 static OP *
12712 S_maybe_targlex(pTHX_ OP *o)
12713 {
12714     OP * const kid = cLISTOPo->op_first;
12715     /* has a disposable target? */
12716     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
12717         && !(kid->op_flags & OPf_STACKED)
12718         /* Cannot steal the second time! */
12719         && !(kid->op_private & OPpTARGET_MY)
12720         )
12721     {
12722         OP * const kkid = OpSIBLING(kid);
12723
12724         /* Can just relocate the target. */
12725         if (kkid && kkid->op_type == OP_PADSV
12726             && (!(kkid->op_private & OPpLVAL_INTRO)
12727                || kkid->op_private & OPpPAD_STATE))
12728         {
12729             kid->op_targ = kkid->op_targ;
12730             kkid->op_targ = 0;
12731             /* Now we do not need PADSV and SASSIGN.
12732              * Detach kid and free the rest. */
12733             op_sibling_splice(o, NULL, 1, NULL);
12734             op_free(o);
12735             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
12736             return kid;
12737         }
12738     }
12739     return o;
12740 }
12741
12742 OP *
12743 Perl_ck_sassign(pTHX_ OP *o)
12744 {
12745     OP * const kid = cBINOPo->op_first;
12746
12747     PERL_ARGS_ASSERT_CK_SASSIGN;
12748
12749     if (OpHAS_SIBLING(kid)) {
12750         OP *kkid = OpSIBLING(kid);
12751         /* For state variable assignment with attributes, kkid is a list op
12752            whose op_last is a padsv. */
12753         if ((kkid->op_type == OP_PADSV ||
12754              (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
12755               (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
12756              )
12757             )
12758                 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
12759                     == (OPpLVAL_INTRO|OPpPAD_STATE)) {
12760             return S_newONCEOP(aTHX_ o, kkid);
12761         }
12762     }
12763     return S_maybe_targlex(aTHX_ o);
12764 }
12765
12766
12767 OP *
12768 Perl_ck_match(pTHX_ OP *o)
12769 {
12770     PERL_UNUSED_CONTEXT;
12771     PERL_ARGS_ASSERT_CK_MATCH;
12772
12773     return o;
12774 }
12775
12776 OP *
12777 Perl_ck_method(pTHX_ OP *o)
12778 {
12779     SV *sv, *methsv, *rclass;
12780     const char* method;
12781     char* compatptr;
12782     int utf8;
12783     STRLEN len, nsplit = 0, i;
12784     OP* new_op;
12785     OP * const kid = cUNOPo->op_first;
12786
12787     PERL_ARGS_ASSERT_CK_METHOD;
12788     if (kid->op_type != OP_CONST) return o;
12789
12790     sv = kSVOP->op_sv;
12791
12792     /* replace ' with :: */
12793     while ((compatptr = (char *) memchr(SvPVX(sv), '\'',
12794                                         SvEND(sv) - SvPVX(sv) )))
12795     {
12796         *compatptr = ':';
12797         sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
12798     }
12799
12800     method = SvPVX_const(sv);
12801     len = SvCUR(sv);
12802     utf8 = SvUTF8(sv) ? -1 : 1;
12803
12804     for (i = len - 1; i > 0; --i) if (method[i] == ':') {
12805         nsplit = i+1;
12806         break;
12807     }
12808
12809     methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
12810
12811     if (!nsplit) { /* $proto->method() */
12812         op_free(o);
12813         return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
12814     }
12815
12816     if (memEQs(method, nsplit, "SUPER::")) { /* $proto->SUPER::method() */
12817         op_free(o);
12818         return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
12819     }
12820
12821     /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
12822     if (nsplit >= 9 && strBEGINs(method+nsplit-9, "::SUPER::")) {
12823         rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
12824         new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
12825     } else {
12826         rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
12827         new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
12828     }
12829 #ifdef USE_ITHREADS
12830     op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
12831 #else
12832     cMETHOPx(new_op)->op_rclass_sv = rclass;
12833 #endif
12834     op_free(o);
12835     return new_op;
12836 }
12837
12838 OP *
12839 Perl_ck_null(pTHX_ OP *o)
12840 {
12841     PERL_ARGS_ASSERT_CK_NULL;
12842     PERL_UNUSED_CONTEXT;
12843     return o;
12844 }
12845
12846 OP *
12847 Perl_ck_open(pTHX_ OP *o)
12848 {
12849     PERL_ARGS_ASSERT_CK_OPEN;
12850
12851     S_io_hints(aTHX_ o);
12852     {
12853          /* In case of three-arg dup open remove strictness
12854           * from the last arg if it is a bareword. */
12855          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
12856          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
12857          OP *oa;
12858          const char *mode;
12859
12860          if ((last->op_type == OP_CONST) &&             /* The bareword. */
12861              (last->op_private & OPpCONST_BARE) &&
12862              (last->op_private & OPpCONST_STRICT) &&
12863              (oa = OpSIBLING(first)) &&         /* The fh. */
12864              (oa = OpSIBLING(oa)) &&                    /* The mode. */
12865              (oa->op_type == OP_CONST) &&
12866              SvPOK(cSVOPx(oa)->op_sv) &&
12867              (mode = SvPVX_const(cSVOPx(oa)->op_sv)) &&
12868              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
12869              (last == OpSIBLING(oa)))                   /* The bareword. */
12870               last->op_private &= ~OPpCONST_STRICT;
12871     }
12872     return ck_fun(o);
12873 }
12874
12875 OP *
12876 Perl_ck_prototype(pTHX_ OP *o)
12877 {
12878     PERL_ARGS_ASSERT_CK_PROTOTYPE;
12879     if (!(o->op_flags & OPf_KIDS)) {
12880         op_free(o);
12881         return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
12882     }
12883     return o;
12884 }
12885
12886 OP *
12887 Perl_ck_refassign(pTHX_ OP *o)
12888 {
12889     OP * const right = cLISTOPo->op_first;
12890     OP * const left = OpSIBLING(right);
12891     OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
12892     bool stacked = 0;
12893
12894     PERL_ARGS_ASSERT_CK_REFASSIGN;
12895     assert (left);
12896     assert (left->op_type == OP_SREFGEN);
12897
12898     o->op_private = 0;
12899     /* we use OPpPAD_STATE in refassign to mean either of those things,
12900      * and the code assumes the two flags occupy the same bit position
12901      * in the various ops below */
12902     assert(OPpPAD_STATE == OPpOUR_INTRO);
12903
12904     switch (varop->op_type) {
12905     case OP_PADAV:
12906         o->op_private |= OPpLVREF_AV;
12907         goto settarg;
12908     case OP_PADHV:
12909         o->op_private |= OPpLVREF_HV;
12910         /* FALLTHROUGH */
12911     case OP_PADSV:
12912       settarg:
12913         o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
12914         o->op_targ = varop->op_targ;
12915         varop->op_targ = 0;
12916         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
12917         break;
12918
12919     case OP_RV2AV:
12920         o->op_private |= OPpLVREF_AV;
12921         goto checkgv;
12922         NOT_REACHED; /* NOTREACHED */
12923     case OP_RV2HV:
12924         o->op_private |= OPpLVREF_HV;
12925         /* FALLTHROUGH */
12926     case OP_RV2SV:
12927       checkgv:
12928         o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
12929         if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
12930       detach_and_stack:
12931         /* Point varop to its GV kid, detached.  */
12932         varop = op_sibling_splice(varop, NULL, -1, NULL);
12933         stacked = TRUE;
12934         break;
12935     case OP_RV2CV: {
12936         OP * const kidparent =
12937             OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
12938         OP * const kid = cUNOPx(kidparent)->op_first;
12939         o->op_private |= OPpLVREF_CV;
12940         if (kid->op_type == OP_GV) {
12941             SV *sv = (SV*)cGVOPx_gv(kid);
12942             varop = kidparent;
12943             if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
12944                 /* a CVREF here confuses pp_refassign, so make sure
12945                    it gets a GV */
12946                 CV *const cv = (CV*)SvRV(sv);
12947                 SV *name_sv = newSVhek_mortal(CvNAME_HEK(cv));
12948                 (void)gv_init_sv((GV*)sv, CvSTASH(cv), name_sv, 0);
12949                 assert(SvTYPE(sv) == SVt_PVGV);
12950             }
12951             goto detach_and_stack;
12952         }
12953         if (kid->op_type != OP_PADCV)   goto bad;
12954         o->op_targ = kid->op_targ;
12955         kid->op_targ = 0;
12956         break;
12957     }
12958     case OP_AELEM:
12959     case OP_HELEM:
12960         o->op_private |= (varop->op_private & OPpLVAL_INTRO);
12961         o->op_private |= OPpLVREF_ELEM;
12962         op_null(varop);
12963         stacked = TRUE;
12964         /* Detach varop.  */
12965         op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
12966         break;
12967     default:
12968       bad:
12969         /* diag_listed_as: Can't modify reference to %s in %s assignment */
12970         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
12971                                 "assignment",
12972                                  OP_DESC(varop)));
12973         return o;
12974     }
12975     if (!FEATURE_REFALIASING_IS_ENABLED)
12976         Perl_croak(aTHX_
12977                   "Experimental aliasing via reference not enabled");
12978     Perl_ck_warner_d(aTHX_
12979                      packWARN(WARN_EXPERIMENTAL__REFALIASING),
12980                     "Aliasing via reference is experimental");
12981     if (stacked) {
12982         o->op_flags |= OPf_STACKED;
12983         op_sibling_splice(o, right, 1, varop);
12984     }
12985     else {
12986         o->op_flags &=~ OPf_STACKED;
12987         op_sibling_splice(o, right, 1, NULL);
12988     }
12989     op_free(left);
12990     return o;
12991 }
12992
12993 OP *
12994 Perl_ck_repeat(pTHX_ OP *o)
12995 {
12996     PERL_ARGS_ASSERT_CK_REPEAT;
12997
12998     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
12999         OP* kids;
13000         o->op_private |= OPpREPEAT_DOLIST;
13001         kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
13002         kids = force_list(kids, TRUE); /* promote it to a list */
13003         op_sibling_splice(o, NULL, 0, kids); /* and add back */
13004     }
13005     else
13006         scalar(o);
13007     return o;
13008 }
13009
13010 OP *
13011 Perl_ck_require(pTHX_ OP *o)
13012 {
13013     GV* gv;
13014
13015     PERL_ARGS_ASSERT_CK_REQUIRE;
13016
13017     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
13018         SVOP * const kid = cSVOPx(cUNOPo->op_first);
13019         U32 hash;
13020         char *s;
13021         STRLEN len;
13022         if (kid->op_type == OP_CONST) {
13023           SV * const sv = kid->op_sv;
13024           U32 const was_readonly = SvREADONLY(sv);
13025           if (kid->op_private & OPpCONST_BARE) {
13026             const char *end;
13027             HEK *hek;
13028
13029             if (was_readonly) {
13030                 SvREADONLY_off(sv);
13031             }
13032
13033             if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
13034
13035             s = SvPVX(sv);
13036             len = SvCUR(sv);
13037             end = s + len;
13038             /* treat ::foo::bar as foo::bar */
13039             if (len >= 2 && s[0] == ':' && s[1] == ':')
13040                 DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
13041             if (s == end)
13042                 DIE(aTHX_ "Bareword in require maps to empty filename");
13043
13044             for (; s < end; s++) {
13045                 if (*s == ':' && s[1] == ':') {
13046                     *s = '/';
13047                     Move(s+2, s+1, end - s - 1, char);
13048                     --end;
13049                 }
13050             }
13051             SvEND_set(sv, end);
13052             sv_catpvs(sv, ".pm");
13053             PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
13054             hek = share_hek(SvPVX(sv),
13055                             (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
13056                             hash);
13057             sv_sethek(sv, hek);
13058             unshare_hek(hek);
13059             SvFLAGS(sv) |= was_readonly;
13060           }
13061           else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
13062                 && !SvVOK(sv)) {
13063             s = SvPV(sv, len);
13064             if (SvREFCNT(sv) > 1) {
13065                 kid->op_sv = newSVpvn_share(
13066                     s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
13067                 SvREFCNT_dec_NN(sv);
13068             }
13069             else {
13070                 HEK *hek;
13071                 if (was_readonly) SvREADONLY_off(sv);
13072                 PERL_HASH(hash, s, len);
13073                 hek = share_hek(s,
13074                                 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
13075                                 hash);
13076                 sv_sethek(sv, hek);
13077                 unshare_hek(hek);
13078                 SvFLAGS(sv) |= was_readonly;
13079             }
13080           }
13081         }
13082     }
13083
13084     if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
13085         /* handle override, if any */
13086      && (gv = gv_override("require", 7))) {
13087         OP *kid, *newop;
13088         if (o->op_flags & OPf_KIDS) {
13089             kid = cUNOPo->op_first;
13090             op_sibling_splice(o, NULL, -1, NULL);
13091         }
13092         else {
13093             kid = newDEFSVOP();
13094         }
13095         op_free(o);
13096         newop = S_new_entersubop(aTHX_ gv, kid);
13097         return newop;
13098     }
13099
13100     return ck_fun(o);
13101 }
13102
13103 OP *
13104 Perl_ck_return(pTHX_ OP *o)
13105 {
13106     OP *kid;
13107
13108     PERL_ARGS_ASSERT_CK_RETURN;
13109
13110     kid = OpSIBLING(cLISTOPo->op_first);
13111     if (PL_compcv && CvLVALUE(PL_compcv)) {
13112         for (; kid; kid = OpSIBLING(kid))
13113             op_lvalue(kid, OP_LEAVESUBLV);
13114     }
13115
13116     return o;
13117 }
13118
13119 OP *
13120 Perl_ck_select(pTHX_ OP *o)
13121 {
13122     OP* kid;
13123
13124     PERL_ARGS_ASSERT_CK_SELECT;
13125
13126     if (o->op_flags & OPf_KIDS) {
13127         kid = OpSIBLING(cLISTOPo->op_first);     /* get past pushmark */
13128         if (kid && OpHAS_SIBLING(kid)) {
13129             OpTYPE_set(o, OP_SSELECT);
13130             o = ck_fun(o);
13131             return fold_constants(op_integerize(op_std_init(o)));
13132         }
13133     }
13134     o = ck_fun(o);
13135     kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
13136     if (kid && kid->op_type == OP_RV2GV)
13137         kid->op_private &= ~HINT_STRICT_REFS;
13138     return o;
13139 }
13140
13141 OP *
13142 Perl_ck_shift(pTHX_ OP *o)
13143 {
13144     const I32 type = o->op_type;
13145
13146     PERL_ARGS_ASSERT_CK_SHIFT;
13147
13148     if (!(o->op_flags & OPf_KIDS)) {
13149         OP *argop;
13150
13151         if (!CvUNIQUE(PL_compcv)) {
13152             o->op_flags |= OPf_SPECIAL;
13153             return o;
13154         }
13155
13156         argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
13157         op_free(o);
13158         return newUNOP(type, 0, scalar(argop));
13159     }
13160     return scalar(ck_fun(o));
13161 }
13162
13163 OP *
13164 Perl_ck_sort(pTHX_ OP *o)
13165 {
13166     OP *firstkid;
13167     OP *kid;
13168     U8 stacked;
13169
13170     PERL_ARGS_ASSERT_CK_SORT;
13171
13172     if (o->op_flags & OPf_STACKED)
13173         simplify_sort(o);
13174     firstkid = OpSIBLING(cLISTOPo->op_first);           /* get past pushmark */
13175
13176     if (!firstkid)
13177         return too_few_arguments_pv(o,OP_DESC(o), 0);
13178
13179     if ((stacked = o->op_flags & OPf_STACKED)) {        /* may have been cleared */
13180         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
13181
13182         /* if the first arg is a code block, process it and mark sort as
13183          * OPf_SPECIAL */
13184         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
13185             LINKLIST(kid);
13186             if (kid->op_type == OP_LEAVE)
13187                     op_null(kid);                       /* wipe out leave */
13188             /* Prevent execution from escaping out of the sort block. */
13189             kid->op_next = 0;
13190
13191             /* provide scalar context for comparison function/block */
13192             kid = scalar(firstkid);
13193             kid->op_next = kid;
13194             o->op_flags |= OPf_SPECIAL;
13195         }
13196         else if (kid->op_type == OP_CONST
13197               && kid->op_private & OPpCONST_BARE) {
13198             char tmpbuf[256];
13199             STRLEN len;
13200             PADOFFSET off;
13201             const char * const name = SvPV(kSVOP_sv, len);
13202             *tmpbuf = '&';
13203             assert (len < 256);
13204             Copy(name, tmpbuf+1, len, char);
13205             off = pad_findmy_pvn(tmpbuf, len+1, 0);
13206             if (off != NOT_IN_PAD) {
13207                 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
13208                     SV * const fq =
13209                         newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
13210                     sv_catpvs(fq, "::");
13211                     sv_catsv(fq, kSVOP_sv);
13212                     SvREFCNT_dec_NN(kSVOP_sv);
13213                     kSVOP->op_sv = fq;
13214                 }
13215                 else {
13216                     OP * const padop = newOP(OP_PADCV, 0);
13217                     padop->op_targ = off;
13218                     /* replace the const op with the pad op */
13219                     op_sibling_splice(firstkid, NULL, 1, padop);
13220                     op_free(kid);
13221                 }
13222             }
13223         }
13224
13225         firstkid = OpSIBLING(firstkid);
13226     }
13227
13228     for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
13229         /* provide list context for arguments */
13230         list(kid);
13231         if (stacked)
13232             op_lvalue(kid, OP_GREPSTART);
13233     }
13234
13235     return o;
13236 }
13237
13238 /* for sort { X } ..., where X is one of
13239  *   $a <=> $b, $b <=> $a, $a cmp $b, $b cmp $a
13240  * elide the second child of the sort (the one containing X),
13241  * and set these flags as appropriate
13242         OPpSORT_NUMERIC;
13243         OPpSORT_INTEGER;
13244         OPpSORT_DESCEND;
13245  * Also, check and warn on lexical $a, $b.
13246  */
13247
13248 STATIC void
13249 S_simplify_sort(pTHX_ OP *o)
13250 {
13251     OP *kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
13252     OP *k;
13253     int descending;
13254     GV *gv;
13255     const char *gvname;
13256     bool have_scopeop;
13257
13258     PERL_ARGS_ASSERT_SIMPLIFY_SORT;
13259
13260     kid = kUNOP->op_first;                              /* get past null */
13261     if (!(have_scopeop = kid->op_type == OP_SCOPE)
13262      && kid->op_type != OP_LEAVE)
13263         return;
13264     kid = kLISTOP->op_last;                             /* get past scope */
13265     switch(kid->op_type) {
13266         case OP_NCMP:
13267         case OP_I_NCMP:
13268         case OP_SCMP:
13269             if (!have_scopeop) goto padkids;
13270             break;
13271         default:
13272             return;
13273     }
13274     k = kid;                                            /* remember this node*/
13275     if (kBINOP->op_first->op_type != OP_RV2SV
13276      || kBINOP->op_last ->op_type != OP_RV2SV)
13277     {
13278         /*
13279            Warn about my($a) or my($b) in a sort block, *if* $a or $b is
13280            then used in a comparison.  This catches most, but not
13281            all cases.  For instance, it catches
13282                sort { my($a); $a <=> $b }
13283            but not
13284                sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
13285            (although why you'd do that is anyone's guess).
13286         */
13287
13288        padkids:
13289         if (!ckWARN(WARN_SYNTAX)) return;
13290         kid = kBINOP->op_first;
13291         do {
13292             if (kid->op_type == OP_PADSV) {
13293                 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
13294                 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
13295                  && (  PadnamePV(name)[1] == 'a'
13296                     || PadnamePV(name)[1] == 'b'  ))
13297                     /* diag_listed_as: "my %s" used in sort comparison */
13298                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13299                                      "\"%s %s\" used in sort comparison",
13300                                       PadnameIsSTATE(name)
13301                                         ? "state"
13302                                         : "my",
13303                                       PadnamePV(name));
13304             }
13305         } while ((kid = OpSIBLING(kid)));
13306         return;
13307     }
13308     kid = kBINOP->op_first;                             /* get past cmp */
13309     if (kUNOP->op_first->op_type != OP_GV)
13310         return;
13311     kid = kUNOP->op_first;                              /* get past rv2sv */
13312     gv = kGVOP_gv;
13313     if (GvSTASH(gv) != PL_curstash)
13314         return;
13315     gvname = GvNAME(gv);
13316     if (*gvname == 'a' && gvname[1] == '\0')
13317         descending = 0;
13318     else if (*gvname == 'b' && gvname[1] == '\0')
13319         descending = 1;
13320     else
13321         return;
13322
13323     kid = k;                                            /* back to cmp */
13324     /* already checked above that it is rv2sv */
13325     kid = kBINOP->op_last;                              /* down to 2nd arg */
13326     if (kUNOP->op_first->op_type != OP_GV)
13327         return;
13328     kid = kUNOP->op_first;                              /* get past rv2sv */
13329     gv = kGVOP_gv;
13330     if (GvSTASH(gv) != PL_curstash)
13331         return;
13332     gvname = GvNAME(gv);
13333     if ( descending
13334          ? !(*gvname == 'a' && gvname[1] == '\0')
13335          : !(*gvname == 'b' && gvname[1] == '\0'))
13336         return;
13337     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
13338     if (descending)
13339         o->op_private |= OPpSORT_DESCEND;
13340     if (k->op_type == OP_NCMP)
13341         o->op_private |= OPpSORT_NUMERIC;
13342     if (k->op_type == OP_I_NCMP)
13343         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
13344     kid = OpSIBLING(cLISTOPo->op_first);
13345     /* cut out and delete old block (second sibling) */
13346     op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
13347     op_free(kid);
13348 }
13349
13350 OP *
13351 Perl_ck_split(pTHX_ OP *o)
13352 {
13353     OP *kid;
13354     OP *sibs;
13355
13356     PERL_ARGS_ASSERT_CK_SPLIT;
13357
13358     assert(o->op_type == OP_LIST);
13359
13360     if (o->op_flags & OPf_STACKED)
13361         return no_fh_allowed(o);
13362
13363     kid = cLISTOPo->op_first;
13364     /* delete leading NULL node, then add a CONST if no other nodes */
13365     assert(kid->op_type == OP_NULL);
13366     op_sibling_splice(o, NULL, 1,
13367         OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
13368     op_free(kid);
13369     kid = cLISTOPo->op_first;
13370
13371     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
13372         /* remove match expression, and replace with new optree with
13373          * a match op at its head */
13374         op_sibling_splice(o, NULL, 1, NULL);
13375         /* pmruntime will handle split " " behavior with flag==2 */
13376         kid = pmruntime(newPMOP(OP_MATCH, 0), kid, NULL, 2, 0);
13377         op_sibling_splice(o, NULL, 0, kid);
13378     }
13379
13380     assert(kid->op_type == OP_MATCH || kid->op_type == OP_SPLIT);
13381
13382     if (kPMOP->op_pmflags & PMf_GLOBAL) {
13383       Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
13384                      "Use of /g modifier is meaningless in split");
13385     }
13386
13387     /* eliminate the split op, and move the match op (plus any children)
13388      * into its place, then convert the match op into a split op. i.e.
13389      *
13390      *  SPLIT                    MATCH                 SPLIT(ex-MATCH)
13391      *    |                        |                     |
13392      *  MATCH - A - B - C   =>     R - A - B - C   =>    R - A - B - C
13393      *    |                        |                     |
13394      *    R                        X - Y                 X - Y
13395      *    |
13396      *    X - Y
13397      *
13398      * (R, if it exists, will be a regcomp op)
13399      */
13400
13401     op_sibling_splice(o, NULL, 1, NULL); /* detach match op from o */
13402     sibs = op_sibling_splice(o, NULL, -1, NULL); /* detach any other sibs */
13403     op_sibling_splice(kid, cLISTOPx(kid)->op_last, 0, sibs); /* and reattach */
13404     OpTYPE_set(kid, OP_SPLIT);
13405     kid->op_flags   = (o->op_flags | (kid->op_flags & OPf_KIDS));
13406     kid->op_private = o->op_private;
13407     op_free(o);
13408     o = kid;
13409     kid = sibs; /* kid is now the string arg of the split */
13410
13411     if (!kid) {
13412         kid = newDEFSVOP();
13413         op_append_elem(OP_SPLIT, o, kid);
13414     }
13415     scalar(kid);
13416
13417     kid = OpSIBLING(kid);
13418     if (!kid) {
13419         kid = newSVOP(OP_CONST, 0, newSViv(0));
13420         op_append_elem(OP_SPLIT, o, kid);
13421         o->op_private |= OPpSPLIT_IMPLIM;
13422     }
13423     scalar(kid);
13424
13425     if (OpHAS_SIBLING(kid))
13426         return too_many_arguments_pv(o,OP_DESC(o), 0);
13427
13428     return o;
13429 }
13430
13431 OP *
13432 Perl_ck_stringify(pTHX_ OP *o)
13433 {
13434     OP * const kid = OpSIBLING(cUNOPo->op_first);
13435     PERL_ARGS_ASSERT_CK_STRINGIFY;
13436     if ((   kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
13437          || kid->op_type == OP_LC   || kid->op_type == OP_LCFIRST
13438          || kid->op_type == OP_UC   || kid->op_type == OP_UCFIRST)
13439         && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
13440     {
13441         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
13442         op_free(o);
13443         return kid;
13444     }
13445     return ck_fun(o);
13446 }
13447
13448 OP *
13449 Perl_ck_join(pTHX_ OP *o)
13450 {
13451     OP * const kid = OpSIBLING(cLISTOPo->op_first);
13452
13453     PERL_ARGS_ASSERT_CK_JOIN;
13454
13455     if (kid && kid->op_type == OP_MATCH) {
13456         if (ckWARN(WARN_SYNTAX)) {
13457             const REGEXP *re = PM_GETRE(kPMOP);
13458             const SV *msg = re
13459                     ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
13460                                             SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
13461                     : newSVpvs_flags( "STRING", SVs_TEMP );
13462             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13463                         "/%" SVf "/ should probably be written as \"%" SVf "\"",
13464                         SVfARG(msg), SVfARG(msg));
13465         }
13466     }
13467     if (kid
13468      && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
13469         || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
13470         || (  kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
13471            && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
13472     {
13473         const OP * const bairn = OpSIBLING(kid); /* the list */
13474         if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
13475          && OP_GIMME(bairn,0) == G_SCALAR)
13476         {
13477             OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
13478                                      op_sibling_splice(o, kid, 1, NULL));
13479             op_free(o);
13480             return ret;
13481         }
13482     }
13483
13484     return ck_fun(o);
13485 }
13486
13487 /*
13488 =for apidoc rv2cv_op_cv
13489
13490 Examines an op, which is expected to identify a subroutine at runtime,
13491 and attempts to determine at compile time which subroutine it identifies.
13492 This is normally used during Perl compilation to determine whether
13493 a prototype can be applied to a function call.  C<cvop> is the op
13494 being considered, normally an C<rv2cv> op.  A pointer to the identified
13495 subroutine is returned, if it could be determined statically, and a null
13496 pointer is returned if it was not possible to determine statically.
13497
13498 Currently, the subroutine can be identified statically if the RV that the
13499 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
13500 A C<gv> op is suitable if the GV's CV slot is populated.  A C<const> op is
13501 suitable if the constant value must be an RV pointing to a CV.  Details of
13502 this process may change in future versions of Perl.  If the C<rv2cv> op
13503 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
13504 the subroutine statically: this flag is used to suppress compile-time
13505 magic on a subroutine call, forcing it to use default runtime behaviour.
13506
13507 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
13508 of a GV reference is modified.  If a GV was examined and its CV slot was
13509 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
13510 If the op is not optimised away, and the CV slot is later populated with
13511 a subroutine having a prototype, that flag eventually triggers the warning
13512 "called too early to check prototype".
13513
13514 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
13515 of returning a pointer to the subroutine it returns a pointer to the
13516 GV giving the most appropriate name for the subroutine in this context.
13517 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
13518 (C<CvANON>) subroutine that is referenced through a GV it will be the
13519 referencing GV.  The resulting C<GV*> is cast to C<CV*> to be returned.
13520 A null pointer is returned as usual if there is no statically-determinable
13521 subroutine.
13522
13523 =for apidoc Amnh||OPpEARLY_CV
13524 =for apidoc Amnh||OPpENTERSUB_AMPER
13525 =for apidoc Amnh||RV2CVOPCV_MARK_EARLY
13526 =for apidoc Amnh||RV2CVOPCV_RETURN_NAME_GV
13527
13528 =cut
13529 */
13530
13531 /* shared by toke.c:yylex */
13532 CV *
13533 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
13534 {
13535     PADNAME *name = PAD_COMPNAME(off);
13536     CV *compcv = PL_compcv;
13537     while (PadnameOUTER(name)) {
13538         assert(PARENT_PAD_INDEX(name));
13539         compcv = CvOUTSIDE(compcv);
13540         name = PadlistNAMESARRAY(CvPADLIST(compcv))
13541                 [off = PARENT_PAD_INDEX(name)];
13542     }
13543     assert(!PadnameIsOUR(name));
13544     if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
13545         return PadnamePROTOCV(name);
13546     }
13547     return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
13548 }
13549
13550 CV *
13551 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
13552 {
13553     OP *rvop;
13554     CV *cv;
13555     GV *gv;
13556     PERL_ARGS_ASSERT_RV2CV_OP_CV;
13557     if (flags & ~RV2CVOPCV_FLAG_MASK)
13558         Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
13559     if (cvop->op_type != OP_RV2CV)
13560         return NULL;
13561     if (cvop->op_private & OPpENTERSUB_AMPER)
13562         return NULL;
13563     if (!(cvop->op_flags & OPf_KIDS))
13564         return NULL;
13565     rvop = cUNOPx(cvop)->op_first;
13566     switch (rvop->op_type) {
13567         case OP_GV: {
13568             gv = cGVOPx_gv(rvop);
13569             if (!isGV(gv)) {
13570                 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
13571                     cv = MUTABLE_CV(SvRV(gv));
13572                     gv = NULL;
13573                     break;
13574                 }
13575                 if (flags & RV2CVOPCV_RETURN_STUB)
13576                     return (CV *)gv;
13577                 else return NULL;
13578             }
13579             cv = GvCVu(gv);
13580             if (!cv) {
13581                 if (flags & RV2CVOPCV_MARK_EARLY)
13582                     rvop->op_private |= OPpEARLY_CV;
13583                 return NULL;
13584             }
13585         } break;
13586         case OP_CONST: {
13587             SV *rv = cSVOPx_sv(rvop);
13588             if (!SvROK(rv))
13589                 return NULL;
13590             cv = (CV*)SvRV(rv);
13591             gv = NULL;
13592         } break;
13593         case OP_PADCV: {
13594             cv = find_lexical_cv(rvop->op_targ);
13595             gv = NULL;
13596         } break;
13597         default: {
13598             return NULL;
13599         } NOT_REACHED; /* NOTREACHED */
13600     }
13601     if (SvTYPE((SV*)cv) != SVt_PVCV)
13602         return NULL;
13603     if (flags & RV2CVOPCV_RETURN_NAME_GV) {
13604         if ((!CvANON(cv) && !CvLEXICAL(cv)) || !gv)
13605             gv = CvGV(cv);
13606         return (CV*)gv;
13607     }
13608     else if (flags & RV2CVOPCV_MAYBE_NAME_GV) {
13609         if (CvLEXICAL(cv) || CvNAMED(cv))
13610             return NULL;
13611         if (!CvANON(cv) || !gv)
13612             gv = CvGV(cv);
13613         return (CV*)gv;
13614
13615     } else {
13616         return cv;
13617     }
13618 }
13619
13620 /*
13621 =for apidoc ck_entersub_args_list
13622
13623 Performs the default fixup of the arguments part of an C<entersub>
13624 op tree.  This consists of applying list context to each of the
13625 argument ops.  This is the standard treatment used on a call marked
13626 with C<&>, or a method call, or a call through a subroutine reference,
13627 or any other call where the callee can't be identified at compile time,
13628 or a call where the callee has no prototype.
13629
13630 =cut
13631 */
13632
13633 OP *
13634 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
13635 {
13636     OP *aop;
13637
13638     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
13639
13640     aop = cUNOPx(entersubop)->op_first;
13641     if (!OpHAS_SIBLING(aop))
13642         aop = cUNOPx(aop)->op_first;
13643     for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
13644         /* skip the extra attributes->import() call implicitly added in
13645          * something like foo(my $x : bar)
13646          */
13647         if (   aop->op_type == OP_ENTERSUB
13648             && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
13649         )
13650             continue;
13651         list(aop);
13652         op_lvalue(aop, OP_ENTERSUB);
13653     }
13654     return entersubop;
13655 }
13656
13657 /*
13658 =for apidoc ck_entersub_args_proto
13659
13660 Performs the fixup of the arguments part of an C<entersub> op tree
13661 based on a subroutine prototype.  This makes various modifications to
13662 the argument ops, from applying context up to inserting C<refgen> ops,
13663 and checking the number and syntactic types of arguments, as directed by
13664 the prototype.  This is the standard treatment used on a subroutine call,
13665 not marked with C<&>, where the callee can be identified at compile time
13666 and has a prototype.
13667
13668 C<protosv> supplies the subroutine prototype to be applied to the call.
13669 It may be a normal defined scalar, of which the string value will be used.
13670 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
13671 that has been cast to C<SV*>) which has a prototype.  The prototype
13672 supplied, in whichever form, does not need to match the actual callee
13673 referenced by the op tree.
13674
13675 If the argument ops disagree with the prototype, for example by having
13676 an unacceptable number of arguments, a valid op tree is returned anyway.
13677 The error is reflected in the parser state, normally resulting in a single
13678 exception at the top level of parsing which covers all the compilation
13679 errors that occurred.  In the error message, the callee is referred to
13680 by the name defined by the C<namegv> parameter.
13681
13682 =cut
13683 */
13684
13685 OP *
13686 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
13687 {
13688     STRLEN proto_len;
13689     const char *proto, *proto_end;
13690     OP *aop, *prev, *cvop, *parent;
13691     int optional = 0;
13692     I32 arg = 0;
13693     I32 contextclass = 0;
13694     const char *e = NULL;
13695     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
13696     if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
13697         Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
13698                    "flags=%lx", (unsigned long) SvFLAGS(protosv));
13699     if (SvTYPE(protosv) == SVt_PVCV)
13700          proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
13701     else proto = SvPV(protosv, proto_len);
13702     proto = S_strip_spaces(aTHX_ proto, &proto_len);
13703     proto_end = proto + proto_len;
13704     parent = entersubop;
13705     aop = cUNOPx(entersubop)->op_first;
13706     if (!OpHAS_SIBLING(aop)) {
13707         parent = aop;
13708         aop = cUNOPx(aop)->op_first;
13709     }
13710     prev = aop;
13711     aop = OpSIBLING(aop);
13712     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13713     while (aop != cvop) {
13714         OP* o3 = aop;
13715
13716         if (proto >= proto_end)
13717         {
13718             SV * const namesv = cv_name((CV *)namegv, NULL, 0);
13719             yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13720                                         SVfARG(namesv)), SvUTF8(namesv));
13721             return entersubop;
13722         }
13723
13724         switch (*proto) {
13725             case ';':
13726                 optional = 1;
13727                 proto++;
13728                 continue;
13729             case '_':
13730                 /* _ must be at the end */
13731                 if (proto[1] && !memCHRs(";@%", proto[1]))
13732                     goto oops;
13733                 /* FALLTHROUGH */
13734             case '$':
13735                 proto++;
13736                 arg++;
13737                 scalar(aop);
13738                 break;
13739             case '%':
13740             case '@':
13741                 list(aop);
13742                 arg++;
13743                 break;
13744             case '&':
13745                 proto++;
13746                 arg++;
13747                 if (    o3->op_type != OP_UNDEF
13748                     && (o3->op_type != OP_SREFGEN
13749                         || (  cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
13750                                 != OP_ANONCODE
13751                             && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
13752                                 != OP_RV2CV)))
13753                     bad_type_gv(arg, namegv, o3,
13754                             arg == 1 ? "block or sub {}" : "sub {}");
13755                 break;
13756             case '*':
13757                 /* '*' allows any scalar type, including bareword */
13758                 proto++;
13759                 arg++;
13760                 if (o3->op_type == OP_RV2GV)
13761                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
13762                 else if (o3->op_type == OP_CONST)
13763                     o3->op_private &= ~OPpCONST_STRICT;
13764                 scalar(aop);
13765                 break;
13766             case '+':
13767                 proto++;
13768                 arg++;
13769                 if (o3->op_type == OP_RV2AV ||
13770                     o3->op_type == OP_PADAV ||
13771                     o3->op_type == OP_RV2HV ||
13772                     o3->op_type == OP_PADHV
13773                 ) {
13774                     goto wrapref;
13775                 }
13776                 scalar(aop);
13777                 break;
13778             case '[': case ']':
13779                 goto oops;
13780
13781             case '\\':
13782                 proto++;
13783                 arg++;
13784             again:
13785                 switch (*proto++) {
13786                     case '[':
13787                         if (contextclass++ == 0) {
13788                             e = (char *) memchr(proto, ']', proto_end - proto);
13789                             if (!e || e == proto)
13790                                 goto oops;
13791                         }
13792                         else
13793                             goto oops;
13794                         goto again;
13795
13796                     case ']':
13797                         if (contextclass) {
13798                             const char *p = proto;
13799                             const char *const end = proto;
13800                             contextclass = 0;
13801                             while (*--p != '[')
13802                                 /* \[$] accepts any scalar lvalue */
13803                                 if (*p == '$'
13804                                  && Perl_op_lvalue_flags(aTHX_
13805                                      scalar(o3),
13806                                      OP_READ, /* not entersub */
13807                                      OP_LVALUE_NO_CROAK
13808                                     )) goto wrapref;
13809                             bad_type_gv(arg, namegv, o3,
13810                                     Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
13811                         } else
13812                             goto oops;
13813                         break;
13814                     case '*':
13815                         if (o3->op_type == OP_RV2GV)
13816                             goto wrapref;
13817                         if (!contextclass)
13818                             bad_type_gv(arg, namegv, o3, "symbol");
13819                         break;
13820                     case '&':
13821                         if (o3->op_type == OP_ENTERSUB
13822                          && !(o3->op_flags & OPf_STACKED))
13823                             goto wrapref;
13824                         if (!contextclass)
13825                             bad_type_gv(arg, namegv, o3, "subroutine");
13826                         break;
13827                     case '$':
13828                         if (o3->op_type == OP_RV2SV ||
13829                                 o3->op_type == OP_PADSV ||
13830                                 o3->op_type == OP_HELEM ||
13831                                 o3->op_type == OP_AELEM)
13832                             goto wrapref;
13833                         if (!contextclass) {
13834                             /* \$ accepts any scalar lvalue */
13835                             if (Perl_op_lvalue_flags(aTHX_
13836                                     scalar(o3),
13837                                     OP_READ,  /* not entersub */
13838                                     OP_LVALUE_NO_CROAK
13839                                )) goto wrapref;
13840                             bad_type_gv(arg, namegv, o3, "scalar");
13841                         }
13842                         break;
13843                     case '@':
13844                         if (o3->op_type == OP_RV2AV ||
13845                                 o3->op_type == OP_PADAV)
13846                         {
13847                             o3->op_flags &=~ OPf_PARENS;
13848                             goto wrapref;
13849                         }
13850                         if (!contextclass)
13851                             bad_type_gv(arg, namegv, o3, "array");
13852                         break;
13853                     case '%':
13854                         if (o3->op_type == OP_RV2HV ||
13855                                 o3->op_type == OP_PADHV)
13856                         {
13857                             o3->op_flags &=~ OPf_PARENS;
13858                             goto wrapref;
13859                         }
13860                         if (!contextclass)
13861                             bad_type_gv(arg, namegv, o3, "hash");
13862                         break;
13863                     wrapref:
13864                             aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
13865                                                 OP_REFGEN, 0);
13866                         if (contextclass && e) {
13867                             proto = e + 1;
13868                             contextclass = 0;
13869                         }
13870                         break;
13871                     default: goto oops;
13872                 }
13873                 if (contextclass)
13874                     goto again;
13875                 break;
13876             case ' ':
13877                 proto++;
13878                 continue;
13879             default:
13880             oops: {
13881                 Perl_croak(aTHX_ "Malformed prototype for %" SVf ": %" SVf,
13882                                   SVfARG(cv_name((CV *)namegv, NULL, 0)),
13883                                   SVfARG(protosv));
13884             }
13885         }
13886
13887         op_lvalue(aop, OP_ENTERSUB);
13888         prev = aop;
13889         aop = OpSIBLING(aop);
13890     }
13891     if (aop == cvop && *proto == '_') {
13892         /* generate an access to $_ */
13893         op_sibling_splice(parent, prev, 0, newDEFSVOP());
13894     }
13895     if (!optional && proto_end > proto &&
13896         (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
13897     {
13898         SV * const namesv = cv_name((CV *)namegv, NULL, 0);
13899         yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %" SVf,
13900                                     SVfARG(namesv)), SvUTF8(namesv));
13901     }
13902     return entersubop;
13903 }
13904
13905 /*
13906 =for apidoc ck_entersub_args_proto_or_list
13907
13908 Performs the fixup of the arguments part of an C<entersub> op tree either
13909 based on a subroutine prototype or using default list-context processing.
13910 This is the standard treatment used on a subroutine call, not marked
13911 with C<&>, where the callee can be identified at compile time.
13912
13913 C<protosv> supplies the subroutine prototype to be applied to the call,
13914 or indicates that there is no prototype.  It may be a normal scalar,
13915 in which case if it is defined then the string value will be used
13916 as a prototype, and if it is undefined then there is no prototype.
13917 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
13918 that has been cast to C<SV*>), of which the prototype will be used if it
13919 has one.  The prototype (or lack thereof) supplied, in whichever form,
13920 does not need to match the actual callee referenced by the op tree.
13921
13922 If the argument ops disagree with the prototype, for example by having
13923 an unacceptable number of arguments, a valid op tree is returned anyway.
13924 The error is reflected in the parser state, normally resulting in a single
13925 exception at the top level of parsing which covers all the compilation
13926 errors that occurred.  In the error message, the callee is referred to
13927 by the name defined by the C<namegv> parameter.
13928
13929 =cut
13930 */
13931
13932 OP *
13933 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
13934         GV *namegv, SV *protosv)
13935 {
13936     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
13937     if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
13938         return ck_entersub_args_proto(entersubop, namegv, protosv);
13939     else
13940         return ck_entersub_args_list(entersubop);
13941 }
13942
13943 OP *
13944 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
13945 {
13946     IV cvflags = SvIVX(protosv);
13947     int opnum = cvflags & 0xffff;
13948     OP *aop = cUNOPx(entersubop)->op_first;
13949
13950     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
13951
13952     if (!opnum) {
13953         OP *cvop;
13954         if (!OpHAS_SIBLING(aop))
13955             aop = cUNOPx(aop)->op_first;
13956         aop = OpSIBLING(aop);
13957         for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13958         if (aop != cvop) {
13959             SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
13960             yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13961                 SVfARG(namesv)), SvUTF8(namesv));
13962         }
13963
13964         op_free(entersubop);
13965         switch(cvflags >> 16) {
13966         case 'F': return newSVOP(OP_CONST, 0,
13967                                         newSVpv(CopFILE(PL_curcop),0));
13968         case 'L': return newSVOP(
13969                            OP_CONST, 0,
13970                            Perl_newSVpvf(aTHX_
13971                              "%" IVdf, (IV)CopLINE(PL_curcop)
13972                            )
13973                          );
13974         case 'P': return newSVOP(OP_CONST, 0,
13975                                    (PL_curstash
13976                                      ? newSVhek(HvNAME_HEK(PL_curstash))
13977                                      : &PL_sv_undef
13978                                    )
13979                                 );
13980         }
13981         NOT_REACHED; /* NOTREACHED */
13982     }
13983     else {
13984         OP *prev, *cvop, *first, *parent;
13985         U32 flags = 0;
13986
13987         parent = entersubop;
13988         if (!OpHAS_SIBLING(aop)) {
13989             parent = aop;
13990             aop = cUNOPx(aop)->op_first;
13991         }
13992
13993         first = prev = aop;
13994         aop = OpSIBLING(aop);
13995         /* find last sibling */
13996         for (cvop = aop;
13997              OpHAS_SIBLING(cvop);
13998              prev = cvop, cvop = OpSIBLING(cvop))
13999             ;
14000         if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
14001             /* Usually, OPf_SPECIAL on an op with no args means that it had
14002              * parens, but these have their own meaning for that flag: */
14003             && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
14004             && opnum != OP_DELETE && opnum != OP_EXISTS)
14005                 flags |= OPf_SPECIAL;
14006         /* excise cvop from end of sibling chain */
14007         op_sibling_splice(parent, prev, 1, NULL);
14008         op_free(cvop);
14009         if (aop == cvop) aop = NULL;
14010
14011         /* detach remaining siblings from the first sibling, then
14012          * dispose of original optree */
14013
14014         if (aop)
14015             op_sibling_splice(parent, first, -1, NULL);
14016         op_free(entersubop);
14017
14018         if (cvflags == (OP_ENTEREVAL | (1<<16)))
14019             flags |= OPpEVAL_BYTES <<8;
14020
14021         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
14022         case OA_UNOP:
14023         case OA_BASEOP_OR_UNOP:
14024         case OA_FILESTATOP:
14025             if (!aop)
14026                 return newOP(opnum,flags);       /* zero args */
14027             if (aop == prev)
14028                 return newUNOP(opnum,flags,aop); /* one arg */
14029             /* too many args */
14030             /* FALLTHROUGH */
14031         case OA_BASEOP:
14032             if (aop) {
14033                 SV *namesv;
14034                 OP *nextop;
14035
14036                 namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
14037                 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
14038                     SVfARG(namesv)), SvUTF8(namesv));
14039                 while (aop) {
14040                     nextop = OpSIBLING(aop);
14041                     op_free(aop);
14042                     aop = nextop;
14043                 }
14044
14045             }
14046             return opnum == OP_RUNCV
14047                 ? newSVOP(OP_RUNCV, 0, &PL_sv_undef)
14048                 : newOP(opnum,0);
14049         default:
14050             return op_convert_list(opnum,0,aop);
14051         }
14052     }
14053     NOT_REACHED; /* NOTREACHED */
14054     return entersubop;
14055 }
14056
14057 /*
14058 =for apidoc cv_get_call_checker_flags
14059
14060 Retrieves the function that will be used to fix up a call to C<cv>.
14061 Specifically, the function is applied to an C<entersub> op tree for a
14062 subroutine call, not marked with C<&>, where the callee can be identified
14063 at compile time as C<cv>.
14064
14065 The C-level function pointer is returned in C<*ckfun_p>, an SV argument
14066 for it is returned in C<*ckobj_p>, and control flags are returned in
14067 C<*ckflags_p>.  The function is intended to be called in this manner:
14068
14069  entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
14070
14071 In this call, C<entersubop> is a pointer to the C<entersub> op,
14072 which may be replaced by the check function, and C<namegv> supplies
14073 the name that should be used by the check function to refer
14074 to the callee of the C<entersub> op if it needs to emit any diagnostics.
14075 It is permitted to apply the check function in non-standard situations,
14076 such as to a call to a different subroutine or to a method call.
14077
14078 C<namegv> may not actually be a GV.  If the C<CALL_CHECKER_REQUIRE_GV>
14079 bit is clear in C<*ckflags_p>, it is permitted to pass a CV or other SV
14080 instead, anything that can be used as the first argument to L</cv_name>.
14081 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<*ckflags_p> then the
14082 check function requires C<namegv> to be a genuine GV.
14083
14084 By default, the check function is
14085 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
14086 the SV parameter is C<cv> itself, and the C<CALL_CHECKER_REQUIRE_GV>
14087 flag is clear.  This implements standard prototype processing.  It can
14088 be changed, for a particular subroutine, by L</cv_set_call_checker_flags>.
14089
14090 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<gflags> then it
14091 indicates that the caller only knows about the genuine GV version of
14092 C<namegv>, and accordingly the corresponding bit will always be set in
14093 C<*ckflags_p>, regardless of the check function's recorded requirements.
14094 If the C<CALL_CHECKER_REQUIRE_GV> bit is clear in C<gflags> then it
14095 indicates the caller knows about the possibility of passing something
14096 other than a GV as C<namegv>, and accordingly the corresponding bit may
14097 be either set or clear in C<*ckflags_p>, indicating the check function's
14098 recorded requirements.
14099
14100 C<gflags> is a bitset passed into C<cv_get_call_checker_flags>, in which
14101 only the C<CALL_CHECKER_REQUIRE_GV> bit currently has a defined meaning
14102 (for which see above).  All other bits should be clear.
14103
14104 =for apidoc Amnh||CALL_CHECKER_REQUIRE_GV
14105
14106 =for apidoc cv_get_call_checker
14107
14108 The original form of L</cv_get_call_checker_flags>, which does not return
14109 checker flags.  When using a checker function returned by this function,
14110 it is only safe to call it with a genuine GV as its C<namegv> argument.
14111
14112 =cut
14113 */
14114
14115 void
14116 Perl_cv_get_call_checker_flags(pTHX_ CV *cv, U32 gflags,
14117         Perl_call_checker *ckfun_p, SV **ckobj_p, U32 *ckflags_p)
14118 {
14119     MAGIC *callmg;
14120     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER_FLAGS;
14121     PERL_UNUSED_CONTEXT;
14122     callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
14123     if (callmg) {
14124         *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
14125         *ckobj_p = callmg->mg_obj;
14126         *ckflags_p = (callmg->mg_flags | gflags) & MGf_REQUIRE_GV;
14127     } else {
14128         *ckfun_p = Perl_ck_entersub_args_proto_or_list;
14129         *ckobj_p = (SV*)cv;
14130         *ckflags_p = gflags & MGf_REQUIRE_GV;
14131     }
14132 }
14133
14134 void
14135 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
14136 {
14137     U32 ckflags;
14138     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
14139     PERL_UNUSED_CONTEXT;
14140     cv_get_call_checker_flags(cv, CALL_CHECKER_REQUIRE_GV, ckfun_p, ckobj_p,
14141         &ckflags);
14142 }
14143
14144 /*
14145 =for apidoc cv_set_call_checker_flags
14146
14147 Sets the function that will be used to fix up a call to C<cv>.
14148 Specifically, the function is applied to an C<entersub> op tree for a
14149 subroutine call, not marked with C<&>, where the callee can be identified
14150 at compile time as C<cv>.
14151
14152 The C-level function pointer is supplied in C<ckfun>, an SV argument for
14153 it is supplied in C<ckobj>, and control flags are supplied in C<ckflags>.
14154 The function should be defined like this:
14155
14156     STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
14157
14158 It is intended to be called in this manner:
14159
14160     entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
14161
14162 In this call, C<entersubop> is a pointer to the C<entersub> op,
14163 which may be replaced by the check function, and C<namegv> supplies
14164 the name that should be used by the check function to refer
14165 to the callee of the C<entersub> op if it needs to emit any diagnostics.
14166 It is permitted to apply the check function in non-standard situations,
14167 such as to a call to a different subroutine or to a method call.
14168
14169 C<namegv> may not actually be a GV.  For efficiency, perl may pass a
14170 CV or other SV instead.  Whatever is passed can be used as the first
14171 argument to L</cv_name>.  You can force perl to pass a GV by including
14172 C<CALL_CHECKER_REQUIRE_GV> in the C<ckflags>.
14173
14174 C<ckflags> is a bitset, in which only the C<CALL_CHECKER_REQUIRE_GV>
14175 bit currently has a defined meaning (for which see above).  All other
14176 bits should be clear.
14177
14178 The current setting for a particular CV can be retrieved by
14179 L</cv_get_call_checker_flags>.
14180
14181 =for apidoc cv_set_call_checker
14182
14183 The original form of L</cv_set_call_checker_flags>, which passes it the
14184 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.  The effect
14185 of that flag setting is that the check function is guaranteed to get a
14186 genuine GV as its C<namegv> argument.
14187
14188 =cut
14189 */
14190
14191 void
14192 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
14193 {
14194     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
14195     cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
14196 }
14197
14198 void
14199 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
14200                                      SV *ckobj, U32 ckflags)
14201 {
14202     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
14203     if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
14204         if (SvMAGICAL((SV*)cv))
14205             mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
14206     } else {
14207         MAGIC *callmg;
14208         sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
14209         callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
14210         assert(callmg);
14211         if (callmg->mg_flags & MGf_REFCOUNTED) {
14212             SvREFCNT_dec(callmg->mg_obj);
14213             callmg->mg_flags &= ~MGf_REFCOUNTED;
14214         }
14215         callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
14216         callmg->mg_obj = ckobj;
14217         if (ckobj != (SV*)cv) {
14218             SvREFCNT_inc_simple_void_NN(ckobj);
14219             callmg->mg_flags |= MGf_REFCOUNTED;
14220         }
14221         callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
14222                          | (U8)(ckflags & MGf_REQUIRE_GV) | MGf_COPY;
14223     }
14224 }
14225
14226 static void
14227 S_entersub_alloc_targ(pTHX_ OP * const o)
14228 {
14229     o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
14230     o->op_private |= OPpENTERSUB_HASTARG;
14231 }
14232
14233 OP *
14234 Perl_ck_subr(pTHX_ OP *o)
14235 {
14236     OP *aop, *cvop;
14237     CV *cv;
14238     GV *namegv;
14239     SV **const_class = NULL;
14240
14241     PERL_ARGS_ASSERT_CK_SUBR;
14242
14243     aop = cUNOPx(o)->op_first;
14244     if (!OpHAS_SIBLING(aop))
14245         aop = cUNOPx(aop)->op_first;
14246     aop = OpSIBLING(aop);
14247     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
14248     cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
14249     namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
14250
14251     o->op_private &= ~1;
14252     o->op_private |= (PL_hints & HINT_STRICT_REFS);
14253     if (PERLDB_SUB && PL_curstash != PL_debstash)
14254         o->op_private |= OPpENTERSUB_DB;
14255     switch (cvop->op_type) {
14256         case OP_RV2CV:
14257             o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
14258             op_null(cvop);
14259             break;
14260         case OP_METHOD:
14261         case OP_METHOD_NAMED:
14262         case OP_METHOD_SUPER:
14263         case OP_METHOD_REDIR:
14264         case OP_METHOD_REDIR_SUPER:
14265             o->op_flags |= OPf_REF;
14266             if (aop->op_type == OP_CONST) {
14267                 aop->op_private &= ~OPpCONST_STRICT;
14268                 const_class = &cSVOPx(aop)->op_sv;
14269             }
14270             else if (aop->op_type == OP_LIST) {
14271                 OP * const sib = OpSIBLING(cUNOPx(aop)->op_first);
14272                 if (sib && sib->op_type == OP_CONST) {
14273                     sib->op_private &= ~OPpCONST_STRICT;
14274                     const_class = &cSVOPx(sib)->op_sv;
14275                 }
14276             }
14277             /* make class name a shared cow string to speedup method calls */
14278             /* constant string might be replaced with object, f.e. bigint */
14279             if (const_class && SvPOK(*const_class)) {
14280                 STRLEN len;
14281                 const char* str = SvPV(*const_class, len);
14282                 if (len) {
14283                     SV* const shared = newSVpvn_share(
14284                         str, SvUTF8(*const_class)
14285                                     ? -(SSize_t)len : (SSize_t)len,
14286                         0
14287                     );
14288                     if (SvREADONLY(*const_class))
14289                         SvREADONLY_on(shared);
14290                     SvREFCNT_dec(*const_class);
14291                     *const_class = shared;
14292                 }
14293             }
14294             break;
14295     }
14296
14297     if (!cv) {
14298         S_entersub_alloc_targ(aTHX_ o);
14299         return ck_entersub_args_list(o);
14300     } else {
14301         Perl_call_checker ckfun;
14302         SV *ckobj;
14303         U32 ckflags;
14304         cv_get_call_checker_flags(cv, 0, &ckfun, &ckobj, &ckflags);
14305         if (CvISXSUB(cv) || !CvROOT(cv))
14306             S_entersub_alloc_targ(aTHX_ o);
14307         if (!namegv) {
14308             /* The original call checker API guarantees that a GV will
14309                be provided with the right name.  So, if the old API was
14310                used (or the REQUIRE_GV flag was passed), we have to reify
14311                the CV’s GV, unless this is an anonymous sub.  This is not
14312                ideal for lexical subs, as its stringification will include
14313                the package.  But it is the best we can do.  */
14314             if (ckflags & CALL_CHECKER_REQUIRE_GV) {
14315                 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
14316                     namegv = CvGV(cv);
14317             }
14318             else namegv = MUTABLE_GV(cv);
14319             /* After a syntax error in a lexical sub, the cv that
14320                rv2cv_op_cv returns may be a nameless stub. */
14321             if (!namegv) return ck_entersub_args_list(o);
14322
14323         }
14324         return ckfun(aTHX_ o, namegv, ckobj);
14325     }
14326 }
14327
14328 OP *
14329 Perl_ck_svconst(pTHX_ OP *o)
14330 {
14331     SV * const sv = cSVOPo->op_sv;
14332     PERL_ARGS_ASSERT_CK_SVCONST;
14333     PERL_UNUSED_CONTEXT;
14334 #ifdef PERL_COPY_ON_WRITE
14335     /* Since the read-only flag may be used to protect a string buffer, we
14336        cannot do copy-on-write with existing read-only scalars that are not
14337        already copy-on-write scalars.  To allow $_ = "hello" to do COW with
14338        that constant, mark the constant as COWable here, if it is not
14339        already read-only. */
14340     if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
14341         SvIsCOW_on(sv);
14342         CowREFCNT(sv) = 0;
14343 # ifdef PERL_DEBUG_READONLY_COW
14344         sv_buf_to_ro(sv);
14345 # endif
14346     }
14347 #endif
14348     SvREADONLY_on(sv);
14349     return o;
14350 }
14351
14352 OP *
14353 Perl_ck_trunc(pTHX_ OP *o)
14354 {
14355     PERL_ARGS_ASSERT_CK_TRUNC;
14356
14357     if (o->op_flags & OPf_KIDS) {
14358         SVOP *kid = cSVOPx(cUNOPo->op_first);
14359
14360         if (kid->op_type == OP_NULL)
14361             kid = cSVOPx(OpSIBLING(kid));
14362         if (kid && kid->op_type == OP_CONST &&
14363             (kid->op_private & OPpCONST_BARE) &&
14364             !kid->op_folded)
14365         {
14366             o->op_flags |= OPf_SPECIAL;
14367             kid->op_private &= ~OPpCONST_STRICT;
14368             if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED) {
14369                 no_bareword_filehandle(SvPVX(cSVOPx_sv(kid)));
14370             }
14371         }
14372     }
14373     return ck_fun(o);
14374 }
14375
14376 OP *
14377 Perl_ck_substr(pTHX_ OP *o)
14378 {
14379     PERL_ARGS_ASSERT_CK_SUBSTR;
14380
14381     o = ck_fun(o);
14382     if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
14383         OP *kid = cLISTOPo->op_first;
14384
14385         if (kid->op_type == OP_NULL)
14386             kid = OpSIBLING(kid);
14387         if (kid)
14388             /* Historically, substr(delete $foo{bar},...) has been allowed
14389                with 4-arg substr.  Keep it working by applying entersub
14390                lvalue context.  */
14391             op_lvalue(kid, OP_ENTERSUB);
14392
14393     }
14394     return o;
14395 }
14396
14397 OP *
14398 Perl_ck_tell(pTHX_ OP *o)
14399 {
14400     PERL_ARGS_ASSERT_CK_TELL;
14401     o = ck_fun(o);
14402     if (o->op_flags & OPf_KIDS) {
14403      OP *kid = cLISTOPo->op_first;
14404      if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
14405      if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
14406     }
14407     return o;
14408 }
14409
14410 PERL_STATIC_INLINE OP *
14411 S_last_non_null_kid(OP *o) {
14412     OP *last = NULL;
14413     if (cUNOPo->op_flags & OPf_KIDS) {
14414         OP *k = cLISTOPo->op_first;
14415         while (k) {
14416             if (k->op_type != OP_NULL) {
14417                 last = k;
14418             }
14419             k = OpSIBLING(k);
14420         }
14421     }
14422
14423     return last;
14424 }
14425
14426 OP *
14427 Perl_ck_each(pTHX_ OP *o)
14428 {
14429     OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
14430     const unsigned orig_type  = o->op_type;
14431
14432     PERL_ARGS_ASSERT_CK_EACH;
14433
14434     if (kid) {
14435         switch (kid->op_type) {
14436             case OP_PADHV:
14437                 break;
14438
14439             case OP_RV2HV:
14440                 /* Catch out an anonhash here, since the behaviour might be
14441                  * confusing.
14442                  *
14443                  * The typical tree is:
14444                  *
14445                  *     rv2hv
14446                  *         scope
14447                  *             null
14448                  *             anonhash
14449                  *
14450                  * If the contents of the block is more complex you might get:
14451                  *
14452                  *     rv2hv
14453                  *         leave
14454                  *             enter
14455                  *             ...
14456                  *             anonhash
14457                  *
14458                  * Similarly for the anonlist version below.
14459                  */
14460                 if (orig_type == OP_EACH &&
14461                     ckWARN(WARN_SYNTAX) &&
14462                     (cUNOPx(kid)->op_flags & OPf_KIDS) &&
14463                     ( cUNOPx(kid)->op_first->op_type == OP_SCOPE ||
14464                       cUNOPx(kid)->op_first->op_type == OP_LEAVE) &&
14465                     (cUNOPx(kid)->op_first->op_flags & OPf_KIDS)) {
14466                     /* look for last non-null kid, since we might have:
14467                        each %{ some code ; +{ anon hash } }
14468                     */
14469                     OP *k = S_last_non_null_kid(cUNOPx(kid)->op_first);
14470                     if (k && k->op_type == OP_ANONHASH) {
14471                         /* diag_listed_as: each on anonymous %s will always start from the beginning */
14472                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "each on anonymous hash will always start from the beginning");
14473                     }
14474                 }
14475                 break;
14476             case OP_RV2AV:
14477                 if (orig_type == OP_EACH &&
14478                     ckWARN(WARN_SYNTAX) &&
14479                     (cUNOPx(kid)->op_flags & OPf_KIDS) &&
14480                     (cUNOPx(kid)->op_first->op_type == OP_SCOPE ||
14481                      cUNOPx(kid)->op_first->op_type == OP_LEAVE) &&
14482                     (cUNOPx(kid)->op_first->op_flags & OPf_KIDS)) {
14483                     OP *k = S_last_non_null_kid(cUNOPx(kid)->op_first);
14484                     if (k && k->op_type == OP_ANONLIST) {
14485                         /* diag_listed_as: each on anonymous %s will always start from the beginning */
14486                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "each on anonymous array will always start from the beginning");
14487                     }
14488                 }
14489                 /* FALLTHROUGH */
14490             case OP_PADAV:
14491                 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
14492                             : orig_type == OP_KEYS ? OP_AKEYS
14493                             :                        OP_AVALUES);
14494                 break;
14495             case OP_CONST:
14496                 if (kid->op_private == OPpCONST_BARE
14497                  || !SvROK(cSVOPx_sv(kid))
14498                  || (  SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
14499                     && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV  )
14500                    )
14501                     goto bad;
14502                 /* FALLTHROUGH */
14503             default:
14504                 qerror(Perl_mess(aTHX_
14505                     "Experimental %s on scalar is now forbidden",
14506                      PL_op_desc[orig_type]));
14507                bad:
14508                 bad_type_pv(1, "hash or array", o, kid);
14509                 return o;
14510         }
14511     }
14512     return ck_fun(o);
14513 }
14514
14515 OP *
14516 Perl_ck_length(pTHX_ OP *o)
14517 {
14518     PERL_ARGS_ASSERT_CK_LENGTH;
14519
14520     o = ck_fun(o);
14521
14522     if (ckWARN(WARN_SYNTAX)) {
14523         const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
14524
14525         if (kid) {
14526             SV *name = NULL;
14527             const bool hash = kid->op_type == OP_PADHV
14528                            || kid->op_type == OP_RV2HV;
14529             switch (kid->op_type) {
14530                 case OP_PADHV:
14531                 case OP_PADAV:
14532                 case OP_RV2HV:
14533                 case OP_RV2AV:
14534                     name = op_varname(kid);
14535                     break;
14536                 default:
14537                     return o;
14538             }
14539             if (name)
14540                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14541                     "length() used on %" SVf " (did you mean \"scalar(%s%" SVf
14542                     ")\"?)",
14543                     SVfARG(name), hash ? "keys " : "", SVfARG(name)
14544                 );
14545             else if (hash)
14546      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
14547                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14548                     "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
14549             else
14550      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
14551                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14552                     "length() used on @array (did you mean \"scalar(@array)\"?)");
14553         }
14554     }
14555
14556     return o;
14557 }
14558
14559
14560 OP *
14561 Perl_ck_isa(pTHX_ OP *o)
14562 {
14563     OP *classop = cBINOPo->op_last;
14564
14565     PERL_ARGS_ASSERT_CK_ISA;
14566
14567     /* Convert barename into PV */
14568     if(classop->op_type == OP_CONST && classop->op_private & OPpCONST_BARE) {
14569         /* TODO: Optionally convert package to raw HV here */
14570         classop->op_private &= ~(OPpCONST_BARE|OPpCONST_STRICT);
14571     }
14572
14573     return o;
14574 }
14575
14576
14577 /* Check for in place reverse and sort assignments like "@a = reverse @a"
14578    and modify the optree to make them work inplace */
14579
14580 STATIC void
14581 S_inplace_aassign(pTHX_ OP *o) {
14582
14583     OP *modop, *modop_pushmark;
14584     OP *oright;
14585     OP *oleft, *oleft_pushmark;
14586
14587     PERL_ARGS_ASSERT_INPLACE_AASSIGN;
14588
14589     assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
14590
14591     assert(cUNOPo->op_first->op_type == OP_NULL);
14592     modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
14593     assert(modop_pushmark->op_type == OP_PUSHMARK);
14594     modop = OpSIBLING(modop_pushmark);
14595
14596     if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
14597         return;
14598
14599     /* no other operation except sort/reverse */
14600     if (OpHAS_SIBLING(modop))
14601         return;
14602
14603     assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
14604     if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
14605
14606     if (modop->op_flags & OPf_STACKED) {
14607         /* skip sort subroutine/block */
14608         assert(oright->op_type == OP_NULL);
14609         oright = OpSIBLING(oright);
14610     }
14611
14612     assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
14613     oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
14614     assert(oleft_pushmark->op_type == OP_PUSHMARK);
14615     oleft = OpSIBLING(oleft_pushmark);
14616
14617     /* Check the lhs is an array */
14618     if (!oleft ||
14619         (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
14620         || OpHAS_SIBLING(oleft)
14621         || (oleft->op_private & OPpLVAL_INTRO)
14622     )
14623         return;
14624
14625     /* Only one thing on the rhs */
14626     if (OpHAS_SIBLING(oright))
14627         return;
14628
14629     /* check the array is the same on both sides */
14630     if (oleft->op_type == OP_RV2AV) {
14631         if (oright->op_type != OP_RV2AV
14632             || !cUNOPx(oright)->op_first
14633             || cUNOPx(oright)->op_first->op_type != OP_GV
14634             || cUNOPx(oleft )->op_first->op_type != OP_GV
14635             || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
14636                cGVOPx_gv(cUNOPx(oright)->op_first)
14637         )
14638             return;
14639     }
14640     else if (oright->op_type != OP_PADAV
14641         || oright->op_targ != oleft->op_targ
14642     )
14643         return;
14644
14645     /* This actually is an inplace assignment */
14646
14647     modop->op_private |= OPpSORT_INPLACE;
14648
14649     /* transfer MODishness etc from LHS arg to RHS arg */
14650     oright->op_flags = oleft->op_flags;
14651
14652     /* remove the aassign op and the lhs */
14653     op_null(o);
14654     op_null(oleft_pushmark);
14655     if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
14656         op_null(cUNOPx(oleft)->op_first);
14657     op_null(oleft);
14658 }
14659
14660
14661 /*
14662 =for apidoc_section $custom
14663
14664 =for apidoc Perl_custom_op_xop
14665 Return the XOP structure for a given custom op.  This macro should be
14666 considered internal to C<OP_NAME> and the other access macros: use them instead.
14667 This macro does call a function.  Prior
14668 to 5.19.6, this was implemented as a
14669 function.
14670
14671 =cut
14672 */
14673
14674
14675 /* use PERL_MAGIC_ext to call a function to free the xop structure when
14676  * freeing PL_custom_ops */
14677
14678 static int
14679 custom_op_register_free(pTHX_ SV *sv, MAGIC *mg)
14680 {
14681     XOP *xop;
14682
14683     PERL_UNUSED_ARG(mg);
14684     xop = INT2PTR(XOP *, SvIV(sv));
14685     Safefree(xop->xop_name);
14686     Safefree(xop->xop_desc);
14687     Safefree(xop);
14688     return 0;
14689 }
14690
14691
14692 static const MGVTBL custom_op_register_vtbl = {
14693     0,                          /* get */
14694     0,                          /* set */
14695     0,                          /* len */
14696     0,                          /* clear */
14697     custom_op_register_free,     /* free */
14698     0,                          /* copy */
14699     0,                          /* dup */
14700 #ifdef MGf_LOCAL
14701     0,                          /* local */
14702 #endif
14703 };
14704
14705
14706 XOPRETANY
14707 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
14708 {
14709     SV *keysv;
14710     HE *he = NULL;
14711     XOP *xop;
14712
14713     static const XOP xop_null = { 0, 0, 0, 0, 0 };
14714
14715     PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
14716     assert(o->op_type == OP_CUSTOM);
14717
14718     /* This is wrong. It assumes a function pointer can be cast to IV,
14719      * which isn't guaranteed, but this is what the old custom OP code
14720      * did. In principle it should be safer to Copy the bytes of the
14721      * pointer into a PV: since the new interface is hidden behind
14722      * functions, this can be changed later if necessary.  */
14723     /* Change custom_op_xop if this ever happens */
14724     keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
14725
14726     if (PL_custom_ops)
14727         he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
14728
14729     /* See if the op isn't registered, but its name *is* registered.
14730      * That implies someone is using the pre-5.14 API,where only name and
14731      * description could be registered. If so, fake up a real
14732      * registration.
14733      * We only check for an existing name, and assume no one will have
14734      * just registered a desc */
14735     if (!he && PL_custom_op_names &&
14736         (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
14737     ) {
14738         const char *pv;
14739         STRLEN l;
14740
14741         /* XXX does all this need to be shared mem? */
14742         Newxz(xop, 1, XOP);
14743         pv = SvPV(HeVAL(he), l);
14744         XopENTRY_set(xop, xop_name, savepvn(pv, l));
14745         if (PL_custom_op_descs &&
14746             (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
14747         ) {
14748             pv = SvPV(HeVAL(he), l);
14749             XopENTRY_set(xop, xop_desc, savepvn(pv, l));
14750         }
14751         Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
14752         he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
14753         /* add magic to the SV so that the xop struct (pointed to by
14754          * SvIV(sv)) is freed. Normally a static xop is registered, but
14755          * for this backcompat hack, we've alloced one */
14756         (void)sv_magicext(HeVAL(he), NULL, PERL_MAGIC_ext,
14757                 &custom_op_register_vtbl, NULL, 0);
14758
14759     }
14760     else {
14761         if (!he)
14762             xop = (XOP *)&xop_null;
14763         else
14764             xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
14765     }
14766
14767     {
14768         XOPRETANY any;
14769         if(field == XOPe_xop_ptr) {
14770             any.xop_ptr = xop;
14771         } else {
14772             const U32 flags = XopFLAGS(xop);
14773             if(flags & field) {
14774                 switch(field) {
14775                 case XOPe_xop_name:
14776                     any.xop_name = xop->xop_name;
14777                     break;
14778                 case XOPe_xop_desc:
14779                     any.xop_desc = xop->xop_desc;
14780                     break;
14781                 case XOPe_xop_class:
14782                     any.xop_class = xop->xop_class;
14783                     break;
14784                 case XOPe_xop_peep:
14785                     any.xop_peep = xop->xop_peep;
14786                     break;
14787                 default:
14788                   field_panic:
14789                     Perl_croak(aTHX_
14790                         "panic: custom_op_get_field(): invalid field %d\n",
14791                         (int)field);
14792                     break;
14793                 }
14794             } else {
14795                 switch(field) {
14796                 case XOPe_xop_name:
14797                     any.xop_name = XOPd_xop_name;
14798                     break;
14799                 case XOPe_xop_desc:
14800                     any.xop_desc = XOPd_xop_desc;
14801                     break;
14802                 case XOPe_xop_class:
14803                     any.xop_class = XOPd_xop_class;
14804                     break;
14805                 case XOPe_xop_peep:
14806                     any.xop_peep = XOPd_xop_peep;
14807                     break;
14808                 default:
14809                     goto field_panic;
14810                     break;
14811                 }
14812             }
14813         }
14814         return any;
14815     }
14816 }
14817
14818 /*
14819 =for apidoc custom_op_register
14820 Register a custom op.  See L<perlguts/"Custom Operators">.
14821
14822 =cut
14823 */
14824
14825 void
14826 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
14827 {
14828     SV *keysv;
14829
14830     PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
14831
14832     /* see the comment in custom_op_xop */
14833     keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
14834
14835     if (!PL_custom_ops)
14836         PL_custom_ops = newHV();
14837
14838     if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
14839         Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
14840 }
14841
14842 /*
14843
14844 =for apidoc core_prototype
14845
14846 This function assigns the prototype of the named core function to C<sv>, or
14847 to a new mortal SV if C<sv> is C<NULL>.  It returns the modified C<sv>, or
14848 C<NULL> if the core function has no prototype.  C<code> is a code as returned
14849 by C<keyword()>.  It must not be equal to 0.
14850
14851 =cut
14852 */
14853
14854 SV *
14855 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
14856                           int * const opnum)
14857 {
14858     int i = 0, n = 0, seen_question = 0, defgv = 0;
14859     I32 oa;
14860 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
14861     char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
14862     bool nullret = FALSE;
14863
14864     PERL_ARGS_ASSERT_CORE_PROTOTYPE;
14865
14866     assert (code);
14867
14868     if (!sv) sv = sv_newmortal();
14869
14870 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
14871
14872     switch (code < 0 ? -code : code) {
14873     case KEY_and   : case KEY_chop: case KEY_chomp:
14874     case KEY_cmp   : case KEY_defined: case KEY_delete: case KEY_exec  :
14875     case KEY_exists: case KEY_eq     : case KEY_ge    : case KEY_goto  :
14876     case KEY_grep  : case KEY_gt     : case KEY_last  : case KEY_le    :
14877     case KEY_lt    : case KEY_map    : case KEY_ne    : case KEY_next  :
14878     case KEY_or    : case KEY_print  : case KEY_printf: case KEY_qr    :
14879     case KEY_redo  : case KEY_require: case KEY_return: case KEY_say   :
14880     case KEY_select: case KEY_sort   : case KEY_split : case KEY_system:
14881     case KEY_x     : case KEY_xor    :
14882         if (!opnum) return NULL; nullret = TRUE; goto findopnum;
14883     case KEY_glob:    retsetpvs("_;", OP_GLOB);
14884     case KEY_keys:    retsetpvs("\\[%@]", OP_KEYS);
14885     case KEY_values:  retsetpvs("\\[%@]", OP_VALUES);
14886     case KEY_each:    retsetpvs("\\[%@]", OP_EACH);
14887     case KEY_pos:     retsetpvs(";\\[$*]", OP_POS);
14888     case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
14889         retsetpvs("", 0);
14890     case KEY_evalbytes:
14891         name = "entereval"; break;
14892     case KEY_readpipe:
14893         name = "backtick";
14894     }
14895
14896 #undef retsetpvs
14897
14898   findopnum:
14899     while (i < MAXO) {  /* The slow way. */
14900         if (strEQ(name, PL_op_name[i])
14901             || strEQ(name, PL_op_desc[i]))
14902         {
14903             if (nullret) { assert(opnum); *opnum = i; return NULL; }
14904             goto found;
14905         }
14906         i++;
14907     }
14908     return NULL;
14909   found:
14910     defgv = PL_opargs[i] & OA_DEFGV;
14911     oa = PL_opargs[i] >> OASHIFT;
14912     while (oa) {
14913         if (oa & OA_OPTIONAL && !seen_question && (
14914               !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
14915         )) {
14916             seen_question = 1;
14917             str[n++] = ';';
14918         }
14919         if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
14920             && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
14921             /* But globs are already references (kinda) */
14922             && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
14923         ) {
14924             str[n++] = '\\';
14925         }
14926         if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
14927          && !scalar_mod_type(NULL, i)) {
14928             str[n++] = '[';
14929             str[n++] = '$';
14930             str[n++] = '@';
14931             str[n++] = '%';
14932             if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
14933             str[n++] = '*';
14934             str[n++] = ']';
14935         }
14936         else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
14937         if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
14938             str[n-1] = '_'; defgv = 0;
14939         }
14940         oa = oa >> 4;
14941     }
14942     if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
14943     str[n++] = '\0';
14944     sv_setpvn(sv, str, n - 1);
14945     if (opnum) *opnum = i;
14946     return sv;
14947 }
14948
14949 OP *
14950 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
14951                       const int opnum)
14952 {
14953     OP * const argop = (opnum == OP_SELECT && code) ? NULL :
14954                                         newSVOP(OP_COREARGS,0,coreargssv);
14955     OP *o;
14956
14957     PERL_ARGS_ASSERT_CORESUB_OP;
14958
14959     switch(opnum) {
14960     case 0:
14961         return op_append_elem(OP_LINESEQ,
14962                        argop,
14963                        newSLICEOP(0,
14964                                   newSVOP(OP_CONST, 0, newSViv(-code % 3)),
14965                                   newOP(OP_CALLER,0)
14966                        )
14967                );
14968     case OP_EACH:
14969     case OP_KEYS:
14970     case OP_VALUES:
14971         o = newUNOP(OP_AVHVSWITCH,0,argop);
14972         o->op_private = opnum-OP_EACH;
14973         return o;
14974     case OP_SELECT: /* which represents OP_SSELECT as well */
14975         if (code)
14976             return newCONDOP(
14977                          0,
14978                          newBINOP(OP_GT, 0,
14979                                   newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
14980                                   newSVOP(OP_CONST, 0, newSVuv(1))
14981                                  ),
14982                          coresub_op(newSVuv((UV)OP_SSELECT), 0,
14983                                     OP_SSELECT),
14984                          coresub_op(coreargssv, 0, OP_SELECT)
14985                    );
14986         /* FALLTHROUGH */
14987     default:
14988         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
14989         case OA_BASEOP:
14990             return op_append_elem(
14991                         OP_LINESEQ, argop,
14992                         newOP(opnum,
14993                               opnum == OP_WANTARRAY || opnum == OP_RUNCV
14994                                 ? OPpOFFBYONE << 8 : 0)
14995                    );
14996         case OA_BASEOP_OR_UNOP:
14997             if (opnum == OP_ENTEREVAL) {
14998                 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
14999                 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
15000             }
15001             else o = newUNOP(opnum,0,argop);
15002             if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
15003             else {
15004           onearg:
15005               if (is_handle_constructor(o, 1))
15006                 argop->op_private |= OPpCOREARGS_DEREF1;
15007               if (scalar_mod_type(NULL, opnum))
15008                 argop->op_private |= OPpCOREARGS_SCALARMOD;
15009             }
15010             return o;
15011         default:
15012             o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
15013             if (is_handle_constructor(o, 2))
15014                 argop->op_private |= OPpCOREARGS_DEREF2;
15015             if (opnum == OP_SUBSTR) {
15016                 o->op_private |= OPpMAYBE_LVSUB;
15017                 return o;
15018             }
15019             else goto onearg;
15020         }
15021     }
15022 }
15023
15024 void
15025 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
15026                                SV * const *new_const_svp)
15027 {
15028     const char *hvname;
15029     bool is_const = cBOOL(CvCONST(old_cv));
15030     SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
15031
15032     PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
15033
15034     if (is_const && new_const_svp && old_const_sv == *new_const_svp)
15035         return;
15036         /* They are 2 constant subroutines generated from
15037            the same constant. This probably means that
15038            they are really the "same" proxy subroutine
15039            instantiated in 2 places. Most likely this is
15040            when a constant is exported twice.  Don't warn.
15041         */
15042     if (
15043         (ckWARN(WARN_REDEFINE)
15044          && !(
15045                 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
15046              && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
15047              && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
15048                  strEQ(hvname, "autouse"))
15049              )
15050         )
15051      || (is_const
15052          && ckWARN_d(WARN_REDEFINE)
15053          && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
15054         )
15055     )
15056         Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
15057                           is_const
15058                             ? "Constant subroutine %" SVf " redefined"
15059                             : "Subroutine %" SVf " redefined",
15060                           SVfARG(name));
15061 }
15062
15063 /*
15064 =for apidoc_section $hook
15065
15066 These functions provide convenient and thread-safe means of manipulating
15067 hook variables.
15068
15069 =cut
15070 */
15071
15072 /*
15073 =for apidoc wrap_op_checker
15074
15075 Puts a C function into the chain of check functions for a specified op
15076 type.  This is the preferred way to manipulate the L</PL_check> array.
15077 C<opcode> specifies which type of op is to be affected.  C<new_checker>
15078 is a pointer to the C function that is to be added to that opcode's
15079 check chain, and C<old_checker_p> points to the storage location where a
15080 pointer to the next function in the chain will be stored.  The value of
15081 C<new_checker> is written into the L</PL_check> array, while the value
15082 previously stored there is written to C<*old_checker_p>.
15083
15084 L</PL_check> is global to an entire process, and a module wishing to
15085 hook op checking may find itself invoked more than once per process,
15086 typically in different threads.  To handle that situation, this function
15087 is idempotent.  The location C<*old_checker_p> must initially (once
15088 per process) contain a null pointer.  A C variable of static duration
15089 (declared at file scope, typically also marked C<static> to give
15090 it internal linkage) will be implicitly initialised appropriately,
15091 if it does not have an explicit initialiser.  This function will only
15092 actually modify the check chain if it finds C<*old_checker_p> to be null.
15093 This function is also thread safe on the small scale.  It uses appropriate
15094 locking to avoid race conditions in accessing L</PL_check>.
15095
15096 When this function is called, the function referenced by C<new_checker>
15097 must be ready to be called, except for C<*old_checker_p> being unfilled.
15098 In a threading situation, C<new_checker> may be called immediately,
15099 even before this function has returned.  C<*old_checker_p> will always
15100 be appropriately set before C<new_checker> is called.  If C<new_checker>
15101 decides not to do anything special with an op that it is given (which
15102 is the usual case for most uses of op check hooking), it must chain the
15103 check function referenced by C<*old_checker_p>.
15104
15105 Taken all together, XS code to hook an op checker should typically look
15106 something like this:
15107
15108     static Perl_check_t nxck_frob;
15109     static OP *myck_frob(pTHX_ OP *op) {
15110         ...
15111         op = nxck_frob(aTHX_ op);
15112         ...
15113         return op;
15114     }
15115     BOOT:
15116         wrap_op_checker(OP_FROB, myck_frob, &nxck_frob);
15117
15118 If you want to influence compilation of calls to a specific subroutine,
15119 then use L</cv_set_call_checker_flags> rather than hooking checking of
15120 all C<entersub> ops.
15121
15122 =cut
15123 */
15124
15125 void
15126 Perl_wrap_op_checker(pTHX_ Optype opcode,
15127     Perl_check_t new_checker, Perl_check_t *old_checker_p)
15128 {
15129
15130     PERL_UNUSED_CONTEXT;
15131     PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
15132     if (*old_checker_p) return;
15133     OP_CHECK_MUTEX_LOCK;
15134     if (!*old_checker_p) {
15135         *old_checker_p = PL_check[opcode];
15136         PL_check[opcode] = new_checker;
15137     }
15138     OP_CHECK_MUTEX_UNLOCK;
15139 }
15140
15141 #include "XSUB.h"
15142
15143 /* Efficient sub that returns a constant scalar value. */
15144 static void
15145 const_sv_xsub(pTHX_ CV* cv)
15146 {
15147     dXSARGS;
15148     SV *const sv = MUTABLE_SV(XSANY.any_ptr);
15149     PERL_UNUSED_ARG(items);
15150     if (!sv) {
15151         XSRETURN(0);
15152     }
15153     EXTEND(sp, 1);
15154     ST(0) = sv;
15155     XSRETURN(1);
15156 }
15157
15158 static void
15159 const_av_xsub(pTHX_ CV* cv)
15160 {
15161     dXSARGS;
15162     AV * const av = MUTABLE_AV(XSANY.any_ptr);
15163     SP -= items;
15164     assert(av);
15165 #ifndef DEBUGGING
15166     if (!av) {
15167         XSRETURN(0);
15168     }
15169 #endif
15170     if (SvRMAGICAL(av))
15171         Perl_croak(aTHX_ "Magical list constants are not supported");
15172     if (GIMME_V != G_LIST) {
15173         EXTEND(SP, 1);
15174         ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
15175         XSRETURN(1);
15176     }
15177     EXTEND(SP, AvFILLp(av)+1);
15178     Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
15179     XSRETURN(AvFILLp(av)+1);
15180 }
15181
15182 /* Copy an existing cop->cop_warnings field.
15183  * If it's one of the standard addresses, just re-use the address.
15184  * This is the e implementation for the DUP_WARNINGS() macro
15185  */
15186
15187 STRLEN*
15188 Perl_dup_warnings(pTHX_ STRLEN* warnings)
15189 {
15190     Size_t size;
15191     STRLEN *new_warnings;
15192
15193     if (warnings == NULL || specialWARN(warnings))
15194         return warnings;
15195
15196     size = sizeof(*warnings) + *warnings;
15197
15198     new_warnings = (STRLEN*)PerlMemShared_malloc(size);
15199     Copy(warnings, new_warnings, size, char);
15200     return new_warnings;
15201 }
15202
15203 /*
15204  * ex: set ts=8 sts=4 sw=4 et:
15205  */