op.c

   1 #line 2 "op.c"
   2 /*    op.c
   3  *
   4  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
   5  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
   6  *
   7  *    You may distribute under the terms of either the GNU General Public
   8  *    License or the Artistic License, as specified in the README file.
   9  *
  10  */
  11
  12 /*
  13  * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck.  She was
  14  *  our Mr. Bilbo's first cousin on the mother's side (her mother being the
  15  *  youngest of the Old Took's daughters); and Mr. Drogo was his second
  16  *  cousin.  So Mr. Frodo is his first *and* second cousin, once removed
  17  *  either way, as the saying is, if you follow me.'       --the Gaffer
  18  *
  19  *     [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
  20  */
  21
  22 /* This file contains the functions that create, manipulate and optimize
  23  * the OP structures that hold a compiled perl program.
  24  *
  25  * Note that during the build of miniperl, a temporary copy of this file
  26  * is made, called opmini.c.
  27  *
  28  * A Perl program is compiled into a tree of OP nodes. Each op contains:
  29  *  * structural OP pointers to its children and siblings (op_sibling,
  30  *    op_first etc) that define the tree structure;
  31  *  * execution order OP pointers (op_next, plus sometimes op_other,
  32  *    op_lastop  etc) that define the execution sequence plus variants;
  33  *  * a pointer to the C "pp" function that would execute the op;
  34  *  * any data specific to that op.
  35  * For example, an OP_CONST op points to the pp_const() function and to an
  36  * SV containing the constant value. When pp_const() is executed, its job
  37  * is to push that SV onto the stack.
  38  *
  39  * OPs are mainly created by the newFOO() functions, which are mainly
  40  * called from the parser (in perly.y) as the code is parsed. For example
  41  * the Perl code $a + $b * $c would cause the equivalent of the following
  42  * to be called (oversimplifying a bit):
  43  *
  44  *  newBINOP(OP_ADD, flags,
  45  *      newSVREF($a),
  46  *      newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
  47  *  )
  48  *
  49  * As the parser reduces low-level rules, it creates little op subtrees;
  50  * as higher-level rules are resolved, these subtrees get joined together
  51  * as branches on a bigger subtree, until eventually a top-level rule like
  52  * a subroutine definition is reduced, at which point there is one large
  53  * parse tree left.
  54  *
  55  * The execution order pointers (op_next) are generated as the subtrees
  56  * are joined together. Consider this sub-expression: A*B + C/D: at the
  57  * point when it's just been parsed, the op tree looks like:
  58  *
  59  *   [+]
  60  *    |
  61  *   [*]------[/]
  62  *    |        |
  63  *    A---B    C---D
  64  *
  65  * with the intended execution order being:
  66  *
  67  *   [PREV] => A => B => [*] => C => D => [/] =>  [+] => [NEXT]
  68  *
  69  * At this point all the nodes' op_next pointers will have been set,
  70  * except that:
  71  *    * we don't know what the [NEXT] node will be yet;
  72  *    * we don't know what the [PREV] node will be yet, but when it gets
  73  *      created and needs its op_next set, it needs to be set to point to
  74  *      A, which is non-obvious.
  75  * To handle both those cases, we temporarily set the top node's
  76  * op_next to point to the first node to be executed in this subtree (A in
  77  * this case). This means that initially a subtree's op_next chain,
  78  * starting from the top node, will visit each node in execution sequence
  79  * then point back at the top node.
  80  * When we embed this subtree in a larger tree, its top op_next is used
  81  * to get the start node, then is set to point to its new neighbour.
  82  * For example the two separate [*],A,B and [/],C,D subtrees would
  83  * initially have had:
  84  *   [*] => A;  A => B;  B => [*]
  85  * and
  86  *   [/] => C;  C => D;  D => [/]
  87  * When these two subtrees were joined together to make the [+] subtree,
  88  * [+]'s op_next was set to [*]'s op_next, i.e. A; then [*]'s op_next was
  89  * set to point to [/]'s op_next, i.e. C.
  90  *
  91  * This op_next linking is done by the LINKLIST() macro and its underlying
  92  * op_linklist() function. Given a top-level op, if its op_next is
  93  * non-null, it's already been linked, so leave it. Otherwise link it with
  94  * its children as described above, possibly recursively if any of the
  95  * children have a null op_next.
  96  *
  97  * In summary: given a subtree, its top-level node's op_next will either
  98  * be:
  99  *   NULL: the subtree hasn't been LINKLIST()ed yet;
 100  *   fake: points to the start op for this subtree;
 101  *   real: once the subtree has been embedded into a larger tree
 102  */
 103
 104 /*
 105
 106 Here's an older description from Larry.
 107
 108 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
 109
 110     A bottom-up pass
 111     A top-down pass
 112     An execution-order pass
 113
 114 The bottom-up pass is represented by all the "newOP" routines and
 115 the ck_ routines.  The bottom-upness is actually driven by yacc.
 116 So at the point that a ck_ routine fires, we have no idea what the
 117 context is, either upward in the syntax tree, or either forward or
 118 backward in the execution order.  (The bottom-up parser builds that
 119 part of the execution order it knows about, but if you follow the "next"
 120 links around, you'll find it's actually a closed loop through the
 121 top level node.)
 122
 123 Whenever the bottom-up parser gets to a node that supplies context to
 124 its components, it invokes that portion of the top-down pass that applies
 125 to that part of the subtree (and marks the top node as processed, so
 126 if a node further up supplies context, it doesn't have to take the
 127 plunge again).  As a particular subcase of this, as the new node is
 128 built, it takes all the closed execution loops of its subcomponents
 129 and links them into a new closed loop for the higher level node.  But
 130 it's still not the real execution order.
 131
 132 The actual execution order is not known till we get a grammar reduction
 133 to a top-level unit like a subroutine or file that will be called by
 134 "name" rather than via a "next" pointer.  At that point, we can call
 135 into peep() to do that code's portion of the 3rd pass.  It has to be
 136 recursive, but it's recursive on basic blocks, not on tree nodes.
 137 */
 138
 139 /* To implement user lexical pragmas, there needs to be a way at run time to
 140    get the compile time state of %^H for that block.  Storing %^H in every
 141    block (or even COP) would be very expensive, so a different approach is
 142    taken.  The (running) state of %^H is serialised into a tree of HE-like
 143    structs.  Stores into %^H are chained onto the current leaf as a struct
 144    refcounted_he * with the key and the value.  Deletes from %^H are saved
 145    with a value of PL_sv_placeholder.  The state of %^H at any point can be
 146    turned back into a regular HV by walking back up the tree from that point's
 147    leaf, ignoring any key you've already seen (placeholder or not), storing
 148    the rest into the HV structure, then removing the placeholders. Hence
 149    memory is only used to store the %^H deltas from the enclosing COP, rather
 150    than the entire %^H on each COP.
 151
 152    To cause actions on %^H to write out the serialisation records, it has
 153    magic type 'H'. This magic (itself) does nothing, but its presence causes
 154    the values to gain magic type 'h', which has entries for set and clear.
 155    C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
 156    record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
 157    saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
 158    it will be correctly restored when any inner compiling scope is exited.
 159 */
 160
 161 #include "EXTERN.h"
 162 #define PERL_IN_OP_C
 163 #include "perl.h"
 164 #include "keywords.h"
 165 #include "feature.h"
 166 #include "regcomp.h"
 167
 168 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
 169 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
 170 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
 171
 172 static const char array_passed_to_stat[] = "Array passed to stat will be coerced to a scalar";
 173
 174 /* Used to avoid recursion through the op tree in scalarvoid() and
 175    op_free()
 176 */
 177
 178 #define DEFERRED_OP_STEP 100
 179 #define DEFER_OP(o) \
 180   STMT_START { \
 181     if (UNLIKELY(defer_ix == (defer_stack_alloc-1))) {    \
 182         defer_stack_alloc += DEFERRED_OP_STEP; \
 183         assert(defer_stack_alloc > 0); \
 184         Renew(defer_stack, defer_stack_alloc, OP *); \
 185     } \
 186     defer_stack[++defer_ix] = o; \
 187   } STMT_END
 188
 189 #define POP_DEFERRED_OP() (defer_ix >= 0 ? defer_stack[defer_ix--] : (OP *)NULL)
 190
 191 /* remove any leading "empty" ops from the op_next chain whose first
 192  * node's address is stored in op_p. Store the updated address of the
 193  * first node in op_p.
 194  */
 195
 196 STATIC void
 197 S_prune_chain_head(OP** op_p)
 198 {
 199     while (*op_p
 200         && (   (*op_p)->op_type == OP_NULL
 201             || (*op_p)->op_type == OP_SCOPE
 202             || (*op_p)->op_type == OP_SCALAR
 203             || (*op_p)->op_type == OP_LINESEQ)
 204     )
 205         *op_p = (*op_p)->op_next;
 206 }
 207
 208
 209 /* See the explanatory comments above struct opslab in op.h. */
 210
 211 #ifdef PERL_DEBUG_READONLY_OPS
 212 #  define PERL_SLAB_SIZE 128
 213 #  define PERL_MAX_SLAB_SIZE 4096
 214 #  include <sys/mman.h>
 215 #endif
 216
 217 #ifndef PERL_SLAB_SIZE
 218 #  define PERL_SLAB_SIZE 64
 219 #endif
 220 #ifndef PERL_MAX_SLAB_SIZE
 221 #  define PERL_MAX_SLAB_SIZE 2048
 222 #endif
 223
 224 /* rounds up to nearest pointer */
 225 #define SIZE_TO_PSIZE(x)        (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
 226 #define DIFF(o,p)               ((size_t)((I32 **)(p) - (I32**)(o)))
 227
 228 static OPSLAB *
 229 S_new_slab(pTHX_ size_t sz)
 230 {
 231 #ifdef PERL_DEBUG_READONLY_OPS
 232     OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
 233                                    PROT_READ|PROT_WRITE,
 234                                    MAP_ANON|MAP_PRIVATE, -1, 0);
 235     DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
 236                           (unsigned long) sz, slab));
 237     if (slab == MAP_FAILED) {
 238         perror("mmap failed");
 239         abort();
 240     }
 241     slab->opslab_size = (U16)sz;
 242 #else
 243     OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
 244 #endif
 245 #ifndef WIN32
 246     /* The context is unused in non-Windows */
 247     PERL_UNUSED_CONTEXT;
 248 #endif
 249     slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
 250     return slab;
 251 }
 252
 253 /* requires double parens and aTHX_ */
 254 #define DEBUG_S_warn(args)                                             \
 255     DEBUG_S(                                                            \
 256         PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
 257     )
 258
 259 void *
 260 Perl_Slab_Alloc(pTHX_ size_t sz)
 261 {
 262     OPSLAB *slab;
 263     OPSLAB *slab2;
 264     OPSLOT *slot;
 265     OP *o;
 266     size_t opsz, space;
 267
 268     /* We only allocate ops from the slab during subroutine compilation.
 269        We find the slab via PL_compcv, hence that must be non-NULL. It could
 270        also be pointing to a subroutine which is now fully set up (CvROOT()
 271        pointing to the top of the optree for that sub), or a subroutine
 272        which isn't using the slab allocator. If our sanity checks aren't met,
 273        don't use a slab, but allocate the OP directly from the heap.  */
 274     if (!PL_compcv || CvROOT(PL_compcv)
 275      || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
 276     {
 277         o = (OP*)PerlMemShared_calloc(1, sz);
 278         goto gotit;
 279     }
 280
 281     /* While the subroutine is under construction, the slabs are accessed via
 282        CvSTART(), to avoid needing to expand PVCV by one pointer for something
 283        unneeded at runtime. Once a subroutine is constructed, the slabs are
 284        accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
 285        allocated yet.  See the commit message for 8be227ab5eaa23f2 for more
 286        details.  */
 287     if (!CvSTART(PL_compcv)) {
 288         CvSTART(PL_compcv) =
 289             (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
 290         CvSLABBED_on(PL_compcv);
 291         slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
 292     }
 293     else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
 294
 295     opsz = SIZE_TO_PSIZE(sz);
 296     sz = opsz + OPSLOT_HEADER_P;
 297
 298     /* The slabs maintain a free list of OPs. In particular, constant folding
 299        will free up OPs, so it makes sense to re-use them where possible. A
 300        freed up slot is used in preference to a new allocation.  */
 301     if (slab->opslab_freed) {
 302         OP **too = &slab->opslab_freed;
 303         o = *too;
 304         DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", (void*)o, (void*)slab));
 305         while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
 306             DEBUG_S_warn((aTHX_ "Alas! too small"));
 307             o = *(too = &o->op_next);
 308             if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", (void*)o)); }
 309         }
 310         if (o) {
 311             *too = o->op_next;
 312             Zero(o, opsz, I32 *);
 313             o->op_slabbed = 1;
 314             goto gotit;
 315         }
 316     }
 317
 318 #define INIT_OPSLOT \
 319             slot->opslot_slab = slab;                   \
 320             slot->opslot_next = slab2->opslab_first;    \
 321             slab2->opslab_first = slot;                 \
 322             o = &slot->opslot_op;                       \
 323             o->op_slabbed = 1
 324
 325     /* The partially-filled slab is next in the chain. */
 326     slab2 = slab->opslab_next ? slab->opslab_next : slab;
 327     if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
 328         /* Remaining space is too small. */
 329
 330         /* If we can fit a BASEOP, add it to the free chain, so as not
 331            to waste it. */
 332         if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
 333             slot = &slab2->opslab_slots;
 334             INIT_OPSLOT;
 335             o->op_type = OP_FREED;
 336             o->op_next = slab->opslab_freed;
 337             slab->opslab_freed = o;
 338         }
 339
 340         /* Create a new slab.  Make this one twice as big. */
 341         slot = slab2->opslab_first;
 342         while (slot->opslot_next) slot = slot->opslot_next;
 343         slab2 = S_new_slab(aTHX_
 344                             (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
 345                                         ? PERL_MAX_SLAB_SIZE
 346                                         : (DIFF(slab2, slot)+1)*2);
 347         slab2->opslab_next = slab->opslab_next;
 348         slab->opslab_next = slab2;
 349     }
 350     assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
 351
 352     /* Create a new op slot */
 353     slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
 354     assert(slot >= &slab2->opslab_slots);
 355     if (DIFF(&slab2->opslab_slots, slot)
 356          < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
 357         slot = &slab2->opslab_slots;
 358     INIT_OPSLOT;
 359     DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab));
 360
 361   gotit:
 362 #ifdef PERL_OP_PARENT
 363     /* moresib == 0, op_sibling == 0 implies a solitary unattached op */
 364     assert(!o->op_moresib);
 365     assert(!o->op_sibparent);
 366 #endif
 367
 368     return (void *)o;
 369 }
 370
 371 #undef INIT_OPSLOT
 372
 373 #ifdef PERL_DEBUG_READONLY_OPS
 374 void
 375 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
 376 {
 377     PERL_ARGS_ASSERT_SLAB_TO_RO;
 378
 379     if (slab->opslab_readonly) return;
 380     slab->opslab_readonly = 1;
 381     for (; slab; slab = slab->opslab_next) {
 382         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
 383                               (unsigned long) slab->opslab_size, slab));*/
 384         if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
 385             Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
 386                              (unsigned long)slab->opslab_size, errno);
 387     }
 388 }
 389
 390 void
 391 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
 392 {
 393     OPSLAB *slab2;
 394
 395     PERL_ARGS_ASSERT_SLAB_TO_RW;
 396
 397     if (!slab->opslab_readonly) return;
 398     slab2 = slab;
 399     for (; slab2; slab2 = slab2->opslab_next) {
 400         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
 401                               (unsigned long) size, slab2));*/
 402         if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
 403                      PROT_READ|PROT_WRITE)) {
 404             Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
 405                              (unsigned long)slab2->opslab_size, errno);
 406         }
 407     }
 408     slab->opslab_readonly = 0;
 409 }
 410
 411 #else
 412 #  define Slab_to_rw(op)    NOOP
 413 #endif
 414
 415 /* This cannot possibly be right, but it was copied from the old slab
 416    allocator, to which it was originally added, without explanation, in
 417    commit 083fcd5. */
 418 #ifdef NETWARE
 419 #    define PerlMemShared PerlMem
 420 #endif
 421
 422 void
 423 Perl_Slab_Free(pTHX_ void *op)
 424 {
 425     OP * const o = (OP *)op;
 426     OPSLAB *slab;
 427
 428     PERL_ARGS_ASSERT_SLAB_FREE;
 429
 430     if (!o->op_slabbed) {
 431         if (!o->op_static)
 432             PerlMemShared_free(op);
 433         return;
 434     }
 435
 436     slab = OpSLAB(o);
 437     /* If this op is already freed, our refcount will get screwy. */
 438     assert(o->op_type != OP_FREED);
 439     o->op_type = OP_FREED;
 440     o->op_next = slab->opslab_freed;
 441     slab->opslab_freed = o;
 442     DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", (void*)o, (void*)slab));
 443     OpslabREFCNT_dec_padok(slab);
 444 }
 445
 446 void
 447 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
 448 {
 449     const bool havepad = !!PL_comppad;
 450     PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
 451     if (havepad) {
 452         ENTER;
 453         PAD_SAVE_SETNULLPAD();
 454     }
 455     opslab_free(slab);
 456     if (havepad) LEAVE;
 457 }
 458
 459 void
 460 Perl_opslab_free(pTHX_ OPSLAB *slab)
 461 {
 462     OPSLAB *slab2;
 463     PERL_ARGS_ASSERT_OPSLAB_FREE;
 464     PERL_UNUSED_CONTEXT;
 465     DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
 466     assert(slab->opslab_refcnt == 1);
 467     do {
 468         slab2 = slab->opslab_next;
 469 #ifdef DEBUGGING
 470         slab->opslab_refcnt = ~(size_t)0;
 471 #endif
 472 #ifdef PERL_DEBUG_READONLY_OPS
 473         DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
 474                                                (void*)slab));
 475         if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
 476             perror("munmap failed");
 477             abort();
 478         }
 479 #else
 480         PerlMemShared_free(slab);
 481 #endif
 482         slab = slab2;
 483     } while (slab);
 484 }
 485
 486 void
 487 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
 488 {
 489     OPSLAB *slab2;
 490 #ifdef DEBUGGING
 491     size_t savestack_count = 0;
 492 #endif
 493     PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
 494     slab2 = slab;
 495     do {
 496         OPSLOT *slot;
 497         for (slot = slab2->opslab_first;
 498              slot->opslot_next;
 499              slot = slot->opslot_next) {
 500             if (slot->opslot_op.op_type != OP_FREED
 501              && !(slot->opslot_op.op_savefree
 502 #ifdef DEBUGGING
 503                   && ++savestack_count
 504 #endif
 505                  )
 506             ) {
 507                 assert(slot->opslot_op.op_slabbed);
 508                 op_free(&slot->opslot_op);
 509                 if (slab->opslab_refcnt == 1) goto free;
 510             }
 511         }
 512     } while ((slab2 = slab2->opslab_next));
 513     /* > 1 because the CV still holds a reference count. */
 514     if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
 515 #ifdef DEBUGGING
 516         assert(savestack_count == slab->opslab_refcnt-1);
 517 #endif
 518         /* Remove the CV’s reference count. */
 519         slab->opslab_refcnt--;
 520         return;
 521     }
 522    free:
 523     opslab_free(slab);
 524 }
 525
 526 #ifdef PERL_DEBUG_READONLY_OPS
 527 OP *
 528 Perl_op_refcnt_inc(pTHX_ OP *o)
 529 {
 530     if(o) {
 531         OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
 532         if (slab && slab->opslab_readonly) {
 533             Slab_to_rw(slab);
 534             ++o->op_targ;
 535             Slab_to_ro(slab);
 536         } else {
 537             ++o->op_targ;
 538         }
 539     }
 540     return o;
 541
 542 }
 543
 544 PADOFFSET
 545 Perl_op_refcnt_dec(pTHX_ OP *o)
 546 {
 547     PADOFFSET result;
 548     OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
 549
 550     PERL_ARGS_ASSERT_OP_REFCNT_DEC;
 551
 552     if (slab && slab->opslab_readonly) {
 553         Slab_to_rw(slab);
 554         result = --o->op_targ;
 555         Slab_to_ro(slab);
 556     } else {
 557         result = --o->op_targ;
 558     }
 559     return result;
 560 }
 561 #endif
 562 /*
 563  * In the following definition, the ", (OP*)0" is just to make the compiler
 564  * think the expression is of the right type: croak actually does a Siglongjmp.
 565  */
 566 #define CHECKOP(type,o) \
 567     ((PL_op_mask && PL_op_mask[type])                           \
 568      ? ( op_free((OP*)o),                                       \
 569          Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]),  \
 570          (OP*)0 )                                               \
 571      : PL_check[type](aTHX_ (OP*)o))
 572
 573 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
 574
 575 #define OpTYPE_set(o,type) \
 576     STMT_START {                                \
 577         o->op_type = (OPCODE)type;              \
 578         o->op_ppaddr = PL_ppaddr[type];         \
 579     } STMT_END
 580
 581 STATIC OP *
 582 S_no_fh_allowed(pTHX_ OP *o)
 583 {
 584     PERL_ARGS_ASSERT_NO_FH_ALLOWED;
 585
 586     yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
 587                  OP_DESC(o)));
 588     return o;
 589 }
 590
 591 STATIC OP *
 592 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
 593 {
 594     PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
 595     yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
 596     return o;
 597 }
 598
 599 STATIC OP *
 600 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
 601 {
 602     PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
 603
 604     yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
 605     return o;
 606 }
 607
 608 STATIC void
 609 S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid)
 610 {
 611     PERL_ARGS_ASSERT_BAD_TYPE_PV;
 612
 613     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
 614                  (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);
 615 }
 616
 617 /* remove flags var, its unused in all callers, move to to right end since gv
 618   and kid are always the same */
 619 STATIC void
 620 S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)
 621 {
 622     SV * const namesv = cv_name((CV *)gv, NULL, 0);
 623     PERL_ARGS_ASSERT_BAD_TYPE_GV;
 624
 625     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %" SVf " must be %s (not %s)",
 626                  (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
 627 }
 628
 629 STATIC void
 630 S_no_bareword_allowed(pTHX_ OP *o)
 631 {
 632     PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
 633
 634     qerror(Perl_mess(aTHX_
 635                      "Bareword \"%" SVf "\" not allowed while \"strict subs\" in use",
 636                      SVfARG(cSVOPo_sv)));
 637     o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
 638 }
 639
 640 /* "register" allocation */
 641
 642 PADOFFSET
 643 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
 644 {
 645     PADOFFSET off;
 646     const bool is_our = (PL_parser->in_my == KEY_our);
 647
 648     PERL_ARGS_ASSERT_ALLOCMY;
 649
 650     if (flags & ~SVf_UTF8)
 651         Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
 652                    (UV)flags);
 653
 654     /* complain about "my $<special_var>" etc etc */
 655     if (   len
 656         && !(  is_our
 657             || isALPHA(name[1])
 658             || (   (flags & SVf_UTF8)
 659                 && isIDFIRST_utf8_safe((U8 *)name+1, name + len))
 660             || (name[1] == '_' && len > 2)))
 661     {
 662         if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
 663          && isASCII(name[1])
 664          && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
 665             /* diag_listed_as: Can't use global %s in "%s" */
 666             yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
 667                               name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
 668                               PL_parser->in_my == KEY_state ? "state" : "my"));
 669         } else {
 670             yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
 671                               PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
 672         }
 673     }
 674
 675     /* allocate a spare slot and store the name in that slot */
 676
 677     off = pad_add_name_pvn(name, len,
 678                        (is_our ? padadd_OUR :
 679                         PL_parser->in_my == KEY_state ? padadd_STATE : 0),
 680                     PL_parser->in_my_stash,
 681                     (is_our
 682                         /* $_ is always in main::, even with our */
 683                         ? (PL_curstash && !memEQs(name,len,"$_")
 684                             ? PL_curstash
 685                             : PL_defstash)
 686                         : NULL
 687                     )
 688     );
 689     /* anon sub prototypes contains state vars should always be cloned,
 690      * otherwise the state var would be shared between anon subs */
 691
 692     if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
 693         CvCLONE_on(PL_compcv);
 694
 695     return off;
 696 }
 697
 698 /*
 699 =head1 Optree Manipulation Functions
 700
 701 =for apidoc alloccopstash
 702
 703 Available only under threaded builds, this function allocates an entry in
 704 C<PL_stashpad> for the stash passed to it.
 705
 706 =cut
 707 */
 708
 709 #ifdef USE_ITHREADS
 710 PADOFFSET
 711 Perl_alloccopstash(pTHX_ HV *hv)
 712 {
 713     PADOFFSET off = 0, o = 1;
 714     bool found_slot = FALSE;
 715
 716     PERL_ARGS_ASSERT_ALLOCCOPSTASH;
 717
 718     if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
 719
 720     for (; o < PL_stashpadmax; ++o) {
 721         if (PL_stashpad[o] == hv) return PL_stashpadix = o;
 722         if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
 723             found_slot = TRUE, off = o;
 724     }
 725     if (!found_slot) {
 726         Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
 727         Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
 728         off = PL_stashpadmax;
 729         PL_stashpadmax += 10;
 730     }
 731
 732     PL_stashpad[PL_stashpadix = off] = hv;
 733     return off;
 734 }
 735 #endif
 736
 737 /* free the body of an op without examining its contents.
 738  * Always use this rather than FreeOp directly */
 739
 740 static void
 741 S_op_destroy(pTHX_ OP *o)
 742 {
 743     FreeOp(o);
 744 }
 745
 746 /* Destructor */
 747
 748 /*
 749 =for apidoc Am|void|op_free|OP *o
 750
 751 Free an op.  Only use this when an op is no longer linked to from any
 752 optree.
 753
 754 =cut
 755 */
 756
 757 void
 758 Perl_op_free(pTHX_ OP *o)
 759 {
 760     dVAR;
 761     OPCODE type;
 762     SSize_t defer_ix = -1;
 763     SSize_t defer_stack_alloc = 0;
 764     OP **defer_stack = NULL;
 765
 766     do {
 767
 768         /* Though ops may be freed twice, freeing the op after its slab is a
 769            big no-no. */
 770         assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
 771         /* During the forced freeing of ops after compilation failure, kidops
 772            may be freed before their parents. */
 773         if (!o || o->op_type == OP_FREED)
 774             continue;
 775
 776         type = o->op_type;
 777
 778         /* an op should only ever acquire op_private flags that we know about.
 779          * If this fails, you may need to fix something in regen/op_private.
 780          * Don't bother testing if:
 781          *   * the op_ppaddr doesn't match the op; someone may have
 782          *     overridden the op and be doing strange things with it;
 783          *   * we've errored, as op flags are often left in an
 784          *     inconsistent state then. Note that an error when
 785          *     compiling the main program leaves PL_parser NULL, so
 786          *     we can't spot faults in the main code, only
 787          *     evaled/required code */
 788 #ifdef DEBUGGING
 789         if (   o->op_ppaddr == PL_ppaddr[o->op_type]
 790             && PL_parser
 791             && !PL_parser->error_count)
 792         {
 793             assert(!(o->op_private & ~PL_op_private_valid[type]));
 794         }
 795 #endif
 796
 797         if (o->op_private & OPpREFCOUNTED) {
 798             switch (type) {
 799             case OP_LEAVESUB:
 800             case OP_LEAVESUBLV:
 801             case OP_LEAVEEVAL:
 802             case OP_LEAVE:
 803             case OP_SCOPE:
 804             case OP_LEAVEWRITE:
 805                 {
 806                 PADOFFSET refcnt;
 807                 OP_REFCNT_LOCK;
 808                 refcnt = OpREFCNT_dec(o);
 809                 OP_REFCNT_UNLOCK;
 810                 if (refcnt) {
 811                     /* Need to find and remove any pattern match ops from the list
 812                        we maintain for reset().  */
 813                     find_and_forget_pmops(o);
 814                     continue;
 815                 }
 816                 }
 817                 break;
 818             default:
 819                 break;
 820             }
 821         }
 822
 823         /* Call the op_free hook if it has been set. Do it now so that it's called
 824          * at the right time for refcounted ops, but still before all of the kids
 825          * are freed. */
 826         CALL_OPFREEHOOK(o);
 827
 828         if (o->op_flags & OPf_KIDS) {
 829             OP *kid, *nextkid;
 830             for (kid = cUNOPo->op_first; kid; kid = nextkid) {
 831                 nextkid = OpSIBLING(kid); /* Get before next freeing kid */
 832                 if (!kid || kid->op_type == OP_FREED)
 833                     /* During the forced freeing of ops after
 834                        compilation failure, kidops may be freed before
 835                        their parents. */
 836                     continue;
 837                 if (!(kid->op_flags & OPf_KIDS))
 838                     /* If it has no kids, just free it now */
 839                     op_free(kid);
 840                 else
 841                     DEFER_OP(kid);
 842             }
 843         }
 844         if (type == OP_NULL)
 845             type = (OPCODE)o->op_targ;
 846
 847         if (o->op_slabbed)
 848             Slab_to_rw(OpSLAB(o));
 849
 850         /* COP* is not cleared by op_clear() so that we may track line
 851          * numbers etc even after null() */
 852         if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
 853             cop_free((COP*)o);
 854         }
 855
 856         op_clear(o);
 857         FreeOp(o);
 858         if (PL_op == o)
 859             PL_op = NULL;
 860     } while ( (o = POP_DEFERRED_OP()) );
 861
 862     Safefree(defer_stack);
 863 }
 864
 865 /* S_op_clear_gv(): free a GV attached to an OP */
 866
 867 STATIC
 868 #ifdef USE_ITHREADS
 869 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
 870 #else
 871 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
 872 #endif
 873 {
 874
 875     GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
 876             || o->op_type == OP_MULTIDEREF)
 877 #ifdef USE_ITHREADS
 878                 && PL_curpad
 879                 ? ((GV*)PAD_SVl(*ixp)) : NULL;
 880 #else
 881                 ? (GV*)(*svp) : NULL;
 882 #endif
 883     /* It's possible during global destruction that the GV is freed
 884        before the optree. Whilst the SvREFCNT_inc is happy to bump from
 885        0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
 886        will trigger an assertion failure, because the entry to sv_clear
 887        checks that the scalar is not already freed.  A check of for
 888        !SvIS_FREED(gv) turns out to be invalid, because during global
 889        destruction the reference count can be forced down to zero
 890        (with SVf_BREAK set).  In which case raising to 1 and then
 891        dropping to 0 triggers cleanup before it should happen.  I
 892        *think* that this might actually be a general, systematic,
 893        weakness of the whole idea of SVf_BREAK, in that code *is*
 894        allowed to raise and lower references during global destruction,
 895        so any *valid* code that happens to do this during global
 896        destruction might well trigger premature cleanup.  */
 897     bool still_valid = gv && SvREFCNT(gv);
 898
 899     if (still_valid)
 900         SvREFCNT_inc_simple_void(gv);
 901 #ifdef USE_ITHREADS
 902     if (*ixp > 0) {
 903         pad_swipe(*ixp, TRUE);
 904         *ixp = 0;
 905     }
 906 #else
 907     SvREFCNT_dec(*svp);
 908     *svp = NULL;
 909 #endif
 910     if (still_valid) {
 911         int try_downgrade = SvREFCNT(gv) == 2;
 912         SvREFCNT_dec_NN(gv);
 913         if (try_downgrade)
 914             gv_try_downgrade(gv);
 915     }
 916 }
 917
 918
 919 void
 920 Perl_op_clear(pTHX_ OP *o)
 921 {
 922
 923     dVAR;
 924
 925     PERL_ARGS_ASSERT_OP_CLEAR;
 926
 927     switch (o->op_type) {
 928     case OP_NULL:       /* Was holding old type, if any. */
 929         /* FALLTHROUGH */
 930     case OP_ENTERTRY:
 931     case OP_ENTEREVAL:  /* Was holding hints. */
 932     case OP_ARGDEFELEM: /* Was holding signature index. */
 933         o->op_targ = 0;
 934         break;
 935     default:
 936         if (!(o->op_flags & OPf_REF)
 937             || (PL_check[o->op_type] != Perl_ck_ftst))
 938             break;
 939         /* FALLTHROUGH */
 940     case OP_GVSV:
 941     case OP_GV:
 942     case OP_AELEMFAST:
 943 #ifdef USE_ITHREADS
 944             S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
 945 #else
 946             S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
 947 #endif
 948         break;
 949     case OP_METHOD_REDIR:
 950     case OP_METHOD_REDIR_SUPER:
 951 #ifdef USE_ITHREADS
 952         if (cMETHOPx(o)->op_rclass_targ) {
 953             pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
 954             cMETHOPx(o)->op_rclass_targ = 0;
 955         }
 956 #else
 957         SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
 958         cMETHOPx(o)->op_rclass_sv = NULL;
 959 #endif
 960         /* FALLTHROUGH */
 961     case OP_METHOD_NAMED:
 962     case OP_METHOD_SUPER:
 963         SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
 964         cMETHOPx(o)->op_u.op_meth_sv = NULL;
 965 #ifdef USE_ITHREADS
 966         if (o->op_targ) {
 967             pad_swipe(o->op_targ, 1);
 968             o->op_targ = 0;
 969         }
 970 #endif
 971         break;
 972     case OP_CONST:
 973     case OP_HINTSEVAL:
 974         SvREFCNT_dec(cSVOPo->op_sv);
 975         cSVOPo->op_sv = NULL;
 976 #ifdef USE_ITHREADS
 977         /** Bug #15654
 978           Even if op_clear does a pad_free for the target of the op,
 979           pad_free doesn't actually remove the sv that exists in the pad;
 980           instead it lives on. This results in that it could be reused as
 981           a target later on when the pad was reallocated.
 982         **/
 983         if(o->op_targ) {
 984           pad_swipe(o->op_targ,1);
 985           o->op_targ = 0;
 986         }
 987 #endif
 988         break;
 989     case OP_DUMP:
 990     case OP_GOTO:
 991     case OP_NEXT:
 992     case OP_LAST:
 993     case OP_REDO:
 994         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
 995             break;
 996         /* FALLTHROUGH */
 997     case OP_TRANS:
 998     case OP_TRANSR:
 999         if (   (o->op_type == OP_TRANS || o->op_type == OP_TRANSR)
1000             && (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)))
1001         {
1002 #ifdef USE_ITHREADS
1003             if (cPADOPo->op_padix > 0) {
1004                 pad_swipe(cPADOPo->op_padix, TRUE);
1005                 cPADOPo->op_padix = 0;
1006             }
1007 #else
1008             SvREFCNT_dec(cSVOPo->op_sv);
1009             cSVOPo->op_sv = NULL;
1010 #endif
1011         }
1012         else {
1013             PerlMemShared_free(cPVOPo->op_pv);
1014             cPVOPo->op_pv = NULL;
1015         }
1016         break;
1017     case OP_SUBST:
1018         op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
1019         goto clear_pmop;
1020
1021     case OP_SPLIT:
1022         if (     (o->op_private & OPpSPLIT_ASSIGN) /* @array  = split */
1023             && !(o->op_flags & OPf_STACKED))       /* @{expr} = split */
1024         {
1025             if (o->op_private & OPpSPLIT_LEX)
1026                 pad_free(cPMOPo->op_pmreplrootu.op_pmtargetoff);
1027             else
1028 #ifdef USE_ITHREADS
1029                 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
1030 #else
1031                 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
1032 #endif
1033         }
1034         /* FALLTHROUGH */
1035     case OP_MATCH:
1036     case OP_QR:
1037     clear_pmop:
1038         if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
1039             op_free(cPMOPo->op_code_list);
1040         cPMOPo->op_code_list = NULL;
1041         forget_pmop(cPMOPo);
1042         cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
1043         /* we use the same protection as the "SAFE" version of the PM_ macros
1044          * here since sv_clean_all might release some PMOPs
1045          * after PL_regex_padav has been cleared
1046          * and the clearing of PL_regex_padav needs to
1047          * happen before sv_clean_all
1048          */
1049 #ifdef USE_ITHREADS
1050         if(PL_regex_pad) {        /* We could be in destruction */
1051             const IV offset = (cPMOPo)->op_pmoffset;
1052             ReREFCNT_dec(PM_GETRE(cPMOPo));
1053             PL_regex_pad[offset] = &PL_sv_undef;
1054             sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
1055                            sizeof(offset));
1056         }
1057 #else
1058         ReREFCNT_dec(PM_GETRE(cPMOPo));
1059         PM_SETRE(cPMOPo, NULL);
1060 #endif
1061
1062         break;
1063
1064     case OP_ARGCHECK:
1065         PerlMemShared_free(cUNOP_AUXo->op_aux);
1066         break;
1067
1068     case OP_MULTIDEREF:
1069         {
1070             UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1071             UV actions = items->uv;
1072             bool last = 0;
1073             bool is_hash = FALSE;
1074
1075             while (!last) {
1076                 switch (actions & MDEREF_ACTION_MASK) {
1077
1078                 case MDEREF_reload:
1079                     actions = (++items)->uv;
1080                     continue;
1081
1082                 case MDEREF_HV_padhv_helem:
1083                     is_hash = TRUE;
1084                     /* FALLTHROUGH */
1085                 case MDEREF_AV_padav_aelem:
1086                     pad_free((++items)->pad_offset);
1087                     goto do_elem;
1088
1089                 case MDEREF_HV_gvhv_helem:
1090                     is_hash = TRUE;
1091                     /* FALLTHROUGH */
1092                 case MDEREF_AV_gvav_aelem:
1093 #ifdef USE_ITHREADS
1094                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1095 #else
1096                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1097 #endif
1098                     goto do_elem;
1099
1100                 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1101                     is_hash = TRUE;
1102                     /* FALLTHROUGH */
1103                 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1104 #ifdef USE_ITHREADS
1105                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1106 #else
1107                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1108 #endif
1109                     goto do_vivify_rv2xv_elem;
1110
1111                 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1112                     is_hash = TRUE;
1113                     /* FALLTHROUGH */
1114                 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1115                     pad_free((++items)->pad_offset);
1116                     goto do_vivify_rv2xv_elem;
1117
1118                 case MDEREF_HV_pop_rv2hv_helem:
1119                 case MDEREF_HV_vivify_rv2hv_helem:
1120                     is_hash = TRUE;
1121                     /* FALLTHROUGH */
1122                 do_vivify_rv2xv_elem:
1123                 case MDEREF_AV_pop_rv2av_aelem:
1124                 case MDEREF_AV_vivify_rv2av_aelem:
1125                 do_elem:
1126                     switch (actions & MDEREF_INDEX_MASK) {
1127                     case MDEREF_INDEX_none:
1128                         last = 1;
1129                         break;
1130                     case MDEREF_INDEX_const:
1131                         if (is_hash) {
1132 #ifdef USE_ITHREADS
1133                             /* see RT #15654 */
1134                             pad_swipe((++items)->pad_offset, 1);
1135 #else
1136                             SvREFCNT_dec((++items)->sv);
1137 #endif
1138                         }
1139                         else
1140                             items++;
1141                         break;
1142                     case MDEREF_INDEX_padsv:
1143                         pad_free((++items)->pad_offset);
1144                         break;
1145                     case MDEREF_INDEX_gvsv:
1146 #ifdef USE_ITHREADS
1147                         S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1148 #else
1149                         S_op_clear_gv(aTHX_ o, &((++items)->sv));
1150 #endif
1151                         break;
1152                     }
1153
1154                     if (actions & MDEREF_FLAG_last)
1155                         last = 1;
1156                     is_hash = FALSE;
1157
1158                     break;
1159
1160                 default:
1161                     assert(0);
1162                     last = 1;
1163                     break;
1164
1165                 } /* switch */
1166
1167                 actions >>= MDEREF_SHIFT;
1168             } /* while */
1169
1170             /* start of malloc is at op_aux[-1], where the length is
1171              * stored */
1172             PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1173         }
1174         break;
1175     }
1176
1177     if (o->op_targ > 0) {
1178         pad_free(o->op_targ);
1179         o->op_targ = 0;
1180     }
1181 }
1182
1183 STATIC void
1184 S_cop_free(pTHX_ COP* cop)
1185 {
1186     PERL_ARGS_ASSERT_COP_FREE;
1187
1188     CopFILE_free(cop);
1189     if (! specialWARN(cop->cop_warnings))
1190         PerlMemShared_free(cop->cop_warnings);
1191     cophh_free(CopHINTHASH_get(cop));
1192     if (PL_curcop == cop)
1193        PL_curcop = NULL;
1194 }
1195
1196 STATIC void
1197 S_forget_pmop(pTHX_ PMOP *const o
1198               )
1199 {
1200     HV * const pmstash = PmopSTASH(o);
1201
1202     PERL_ARGS_ASSERT_FORGET_PMOP;
1203
1204     if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1205         MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1206         if (mg) {
1207             PMOP **const array = (PMOP**) mg->mg_ptr;
1208             U32 count = mg->mg_len / sizeof(PMOP**);
1209             U32 i = count;
1210
1211             while (i--) {
1212                 if (array[i] == o) {
1213                     /* Found it. Move the entry at the end to overwrite it.  */
1214                     array[i] = array[--count];
1215                     mg->mg_len = count * sizeof(PMOP**);
1216                     /* Could realloc smaller at this point always, but probably
1217                        not worth it. Probably worth free()ing if we're the
1218                        last.  */
1219                     if(!count) {
1220                         Safefree(mg->mg_ptr);
1221                         mg->mg_ptr = NULL;
1222                     }
1223                     break;
1224                 }
1225             }
1226         }
1227     }
1228     if (PL_curpm == o)
1229         PL_curpm = NULL;
1230 }
1231
1232 STATIC void
1233 S_find_and_forget_pmops(pTHX_ OP *o)
1234 {
1235     PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1236
1237     if (o->op_flags & OPf_KIDS) {
1238         OP *kid = cUNOPo->op_first;
1239         while (kid) {
1240             switch (kid->op_type) {
1241             case OP_SUBST:
1242             case OP_SPLIT:
1243             case OP_MATCH:
1244             case OP_QR:
1245                 forget_pmop((PMOP*)kid);
1246             }
1247             find_and_forget_pmops(kid);
1248             kid = OpSIBLING(kid);
1249         }
1250     }
1251 }
1252
1253 /*
1254 =for apidoc Am|void|op_null|OP *o
1255
1256 Neutralizes an op when it is no longer needed, but is still linked to from
1257 other ops.
1258
1259 =cut
1260 */
1261
1262 void
1263 Perl_op_null(pTHX_ OP *o)
1264 {
1265     dVAR;
1266
1267     PERL_ARGS_ASSERT_OP_NULL;
1268
1269     if (o->op_type == OP_NULL)
1270         return;
1271     op_clear(o);
1272     o->op_targ = o->op_type;
1273     OpTYPE_set(o, OP_NULL);
1274 }
1275
1276 void
1277 Perl_op_refcnt_lock(pTHX)
1278   PERL_TSA_ACQUIRE(PL_op_mutex)
1279 {
1280 #ifdef USE_ITHREADS
1281     dVAR;
1282 #endif
1283     PERL_UNUSED_CONTEXT;
1284     OP_REFCNT_LOCK;
1285 }
1286
1287 void
1288 Perl_op_refcnt_unlock(pTHX)
1289   PERL_TSA_RELEASE(PL_op_mutex)
1290 {
1291 #ifdef USE_ITHREADS
1292     dVAR;
1293 #endif
1294     PERL_UNUSED_CONTEXT;
1295     OP_REFCNT_UNLOCK;
1296 }
1297
1298
1299 /*
1300 =for apidoc op_sibling_splice
1301
1302 A general function for editing the structure of an existing chain of
1303 op_sibling nodes.  By analogy with the perl-level C<splice()> function, allows
1304 you to delete zero or more sequential nodes, replacing them with zero or
1305 more different nodes.  Performs the necessary op_first/op_last
1306 housekeeping on the parent node and op_sibling manipulation on the
1307 children.  The last deleted node will be marked as as the last node by
1308 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1309
1310 Note that op_next is not manipulated, and nodes are not freed; that is the
1311 responsibility of the caller.  It also won't create a new list op for an
1312 empty list etc; use higher-level functions like op_append_elem() for that.
1313
1314 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1315 the splicing doesn't affect the first or last op in the chain.
1316
1317 C<start> is the node preceding the first node to be spliced.  Node(s)
1318 following it will be deleted, and ops will be inserted after it.  If it is
1319 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1320 beginning.
1321
1322 C<del_count> is the number of nodes to delete.  If zero, no nodes are deleted.
1323 If -1 or greater than or equal to the number of remaining kids, all
1324 remaining kids are deleted.
1325
1326 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1327 If C<NULL>, no nodes are inserted.
1328
1329 The head of the chain of deleted ops is returned, or C<NULL> if no ops were
1330 deleted.
1331
1332 For example:
1333
1334     action                    before      after         returns
1335     ------                    -----       -----         -------
1336
1337                               P           P
1338     splice(P, A, 2, X-Y-Z)    |           |             B-C
1339                               A-B-C-D     A-X-Y-Z-D
1340
1341                               P           P
1342     splice(P, NULL, 1, X-Y)   |           |             A
1343                               A-B-C-D     X-Y-B-C-D
1344
1345                               P           P
1346     splice(P, NULL, 3, NULL)  |           |             A-B-C
1347                               A-B-C-D     D
1348
1349                               P           P
1350     splice(P, B, 0, X-Y)      |           |             NULL
1351                               A-B-C-D     A-B-X-Y-C-D
1352
1353
1354 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1355 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
1356
1357 =cut
1358 */
1359
1360 OP *
1361 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1362 {
1363     OP *first;
1364     OP *rest;
1365     OP *last_del = NULL;
1366     OP *last_ins = NULL;
1367
1368     if (start)
1369         first = OpSIBLING(start);
1370     else if (!parent)
1371         goto no_parent;
1372     else
1373         first = cLISTOPx(parent)->op_first;
1374
1375     assert(del_count >= -1);
1376
1377     if (del_count && first) {
1378         last_del = first;
1379         while (--del_count && OpHAS_SIBLING(last_del))
1380             last_del = OpSIBLING(last_del);
1381         rest = OpSIBLING(last_del);
1382         OpLASTSIB_set(last_del, NULL);
1383     }
1384     else
1385         rest = first;
1386
1387     if (insert) {
1388         last_ins = insert;
1389         while (OpHAS_SIBLING(last_ins))
1390             last_ins = OpSIBLING(last_ins);
1391         OpMAYBESIB_set(last_ins, rest, NULL);
1392     }
1393     else
1394         insert = rest;
1395
1396     if (start) {
1397         OpMAYBESIB_set(start, insert, NULL);
1398     }
1399     else {
1400         if (!parent)
1401             goto no_parent;
1402         cLISTOPx(parent)->op_first = insert;
1403         if (insert)
1404             parent->op_flags |= OPf_KIDS;
1405         else
1406             parent->op_flags &= ~OPf_KIDS;
1407     }
1408
1409     if (!rest) {
1410         /* update op_last etc */
1411         U32 type;
1412         OP *lastop;
1413
1414         if (!parent)
1415             goto no_parent;
1416
1417         /* ought to use OP_CLASS(parent) here, but that can't handle
1418          * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1419          * either */
1420         type = parent->op_type;
1421         if (type == OP_CUSTOM) {
1422             dTHX;
1423             type = XopENTRYCUSTOM(parent, xop_class);
1424         }
1425         else {
1426             if (type == OP_NULL)
1427                 type = parent->op_targ;
1428             type = PL_opargs[type] & OA_CLASS_MASK;
1429         }
1430
1431         lastop = last_ins ? last_ins : start ? start : NULL;
1432         if (   type == OA_BINOP
1433             || type == OA_LISTOP
1434             || type == OA_PMOP
1435             || type == OA_LOOP
1436         )
1437             cLISTOPx(parent)->op_last = lastop;
1438
1439         if (lastop)
1440             OpLASTSIB_set(lastop, parent);
1441     }
1442     return last_del ? first : NULL;
1443
1444   no_parent:
1445     Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1446 }
1447
1448
1449 #ifdef PERL_OP_PARENT
1450
1451 /*
1452 =for apidoc op_parent
1453
1454 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1455 This function is only available on perls built with C<-DPERL_OP_PARENT>.
1456
1457 =cut
1458 */
1459
1460 OP *
1461 Perl_op_parent(OP *o)
1462 {
1463     PERL_ARGS_ASSERT_OP_PARENT;
1464     while (OpHAS_SIBLING(o))
1465         o = OpSIBLING(o);
1466     return o->op_sibparent;
1467 }
1468
1469 #endif
1470
1471
1472 /* replace the sibling following start with a new UNOP, which becomes
1473  * the parent of the original sibling; e.g.
1474  *
1475  *  op_sibling_newUNOP(P, A, unop-args...)
1476  *
1477  *  P              P
1478  *  |      becomes |
1479  *  A-B-C          A-U-C
1480  *                   |
1481  *                   B
1482  *
1483  * where U is the new UNOP.
1484  *
1485  * parent and start args are the same as for op_sibling_splice();
1486  * type and flags args are as newUNOP().
1487  *
1488  * Returns the new UNOP.
1489  */
1490
1491 STATIC OP *
1492 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1493 {
1494     OP *kid, *newop;
1495
1496     kid = op_sibling_splice(parent, start, 1, NULL);
1497     newop = newUNOP(type, flags, kid);
1498     op_sibling_splice(parent, start, 0, newop);
1499     return newop;
1500 }
1501
1502
1503 /* lowest-level newLOGOP-style function - just allocates and populates
1504  * the struct. Higher-level stuff should be done by S_new_logop() /
1505  * newLOGOP(). This function exists mainly to avoid op_first assignment
1506  * being spread throughout this file.
1507  */
1508
1509 LOGOP *
1510 Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1511 {
1512     dVAR;
1513     LOGOP *logop;
1514     OP *kid = first;
1515     NewOp(1101, logop, 1, LOGOP);
1516     OpTYPE_set(logop, type);
1517     logop->op_first = first;
1518     logop->op_other = other;
1519     logop->op_flags = OPf_KIDS;
1520     while (kid && OpHAS_SIBLING(kid))
1521         kid = OpSIBLING(kid);
1522     if (kid)
1523         OpLASTSIB_set(kid, (OP*)logop);
1524     return logop;
1525 }
1526
1527
1528 /* Contextualizers */
1529
1530 /*
1531 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1532
1533 Applies a syntactic context to an op tree representing an expression.
1534 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
1535 or C<G_VOID> to specify the context to apply.  The modified op tree
1536 is returned.
1537
1538 =cut
1539 */
1540
1541 OP *
1542 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1543 {
1544     PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1545     switch (context) {
1546         case G_SCALAR: return scalar(o);
1547         case G_ARRAY:  return list(o);
1548         case G_VOID:   return scalarvoid(o);
1549         default:
1550             Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1551                        (long) context);
1552     }
1553 }
1554
1555 /*
1556
1557 =for apidoc Am|OP*|op_linklist|OP *o
1558 This function is the implementation of the L</LINKLIST> macro.  It should
1559 not be called directly.
1560
1561 =cut
1562 */
1563
1564 OP *
1565 Perl_op_linklist(pTHX_ OP *o)
1566 {
1567     OP *first;
1568
1569     PERL_ARGS_ASSERT_OP_LINKLIST;
1570
1571     if (o->op_next)
1572         return o->op_next;
1573
1574     /* establish postfix order */
1575     first = cUNOPo->op_first;
1576     if (first) {
1577         OP *kid;
1578         o->op_next = LINKLIST(first);
1579         kid = first;
1580         for (;;) {
1581             OP *sibl = OpSIBLING(kid);
1582             if (sibl) {
1583                 kid->op_next = LINKLIST(sibl);
1584                 kid = sibl;
1585             } else {
1586                 kid->op_next = o;
1587                 break;
1588             }
1589         }
1590     }
1591     else
1592         o->op_next = o;
1593
1594     return o->op_next;
1595 }
1596
1597 static OP *
1598 S_scalarkids(pTHX_ OP *o)
1599 {
1600     if (o && o->op_flags & OPf_KIDS) {
1601         OP *kid;
1602         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1603             scalar(kid);
1604     }
1605     return o;
1606 }
1607
1608 STATIC OP *
1609 S_scalarboolean(pTHX_ OP *o)
1610 {
1611     PERL_ARGS_ASSERT_SCALARBOOLEAN;
1612
1613     if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1614          !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1615         (o->op_type == OP_NOT     && cUNOPo->op_first->op_type == OP_SASSIGN &&
1616          cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1617          !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
1618         if (ckWARN(WARN_SYNTAX)) {
1619             const line_t oldline = CopLINE(PL_curcop);
1620
1621             if (PL_parser && PL_parser->copline != NOLINE) {
1622                 /* This ensures that warnings are reported at the first line
1623                    of the conditional, not the last.  */
1624                 CopLINE_set(PL_curcop, PL_parser->copline);
1625             }
1626             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1627             CopLINE_set(PL_curcop, oldline);
1628         }
1629     }
1630     return scalar(o);
1631 }
1632
1633 static SV *
1634 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1635 {
1636     assert(o);
1637     assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1638            o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1639     {
1640         const char funny  = o->op_type == OP_PADAV
1641                          || o->op_type == OP_RV2AV ? '@' : '%';
1642         if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1643             GV *gv;
1644             if (cUNOPo->op_first->op_type != OP_GV
1645              || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1646                 return NULL;
1647             return varname(gv, funny, 0, NULL, 0, subscript_type);
1648         }
1649         return
1650             varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1651     }
1652 }
1653
1654 static SV *
1655 S_op_varname(pTHX_ const OP *o)
1656 {
1657     return S_op_varname_subscript(aTHX_ o, 1);
1658 }
1659
1660 static void
1661 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1662 { /* or not so pretty :-) */
1663     if (o->op_type == OP_CONST) {
1664         *retsv = cSVOPo_sv;
1665         if (SvPOK(*retsv)) {
1666             SV *sv = *retsv;
1667             *retsv = sv_newmortal();
1668             pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1669                       PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1670         }
1671         else if (!SvOK(*retsv))
1672             *retpv = "undef";
1673     }
1674     else *retpv = "...";
1675 }
1676
1677 static void
1678 S_scalar_slice_warning(pTHX_ const OP *o)
1679 {
1680     OP *kid;
1681     const bool h = o->op_type == OP_HSLICE
1682                 || (o->op_type == OP_NULL && o->op_targ == OP_HSLICE);
1683     const char lbrack =
1684         h ? '{' : '[';
1685     const char rbrack =
1686         h ? '}' : ']';
1687     SV *name;
1688     SV *keysv = NULL; /* just to silence compiler warnings */
1689     const char *key = NULL;
1690
1691     if (!(o->op_private & OPpSLICEWARNING))
1692         return;
1693     if (PL_parser && PL_parser->error_count)
1694         /* This warning can be nonsensical when there is a syntax error. */
1695         return;
1696
1697     kid = cLISTOPo->op_first;
1698     kid = OpSIBLING(kid); /* get past pushmark */
1699     /* weed out false positives: any ops that can return lists */
1700     switch (kid->op_type) {
1701     case OP_BACKTICK:
1702     case OP_GLOB:
1703     case OP_READLINE:
1704     case OP_MATCH:
1705     case OP_RV2AV:
1706     case OP_EACH:
1707     case OP_VALUES:
1708     case OP_KEYS:
1709     case OP_SPLIT:
1710     case OP_LIST:
1711     case OP_SORT:
1712     case OP_REVERSE:
1713     case OP_ENTERSUB:
1714     case OP_CALLER:
1715     case OP_LSTAT:
1716     case OP_STAT:
1717     case OP_READDIR:
1718     case OP_SYSTEM:
1719     case OP_TMS:
1720     case OP_LOCALTIME:
1721     case OP_GMTIME:
1722     case OP_ENTEREVAL:
1723         return;
1724     }
1725
1726     /* Don't warn if we have a nulled list either. */
1727     if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1728         return;
1729
1730     assert(OpSIBLING(kid));
1731     name = S_op_varname(aTHX_ OpSIBLING(kid));
1732     if (!name) /* XS module fiddling with the op tree */
1733         return;
1734     S_op_pretty(aTHX_ kid, &keysv, &key);
1735     assert(SvPOK(name));
1736     sv_chop(name,SvPVX(name)+1);
1737     if (key)
1738        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1739         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1740                    "Scalar value @%" SVf "%c%s%c better written as $%" SVf
1741                    "%c%s%c",
1742                     SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1743                     lbrack, key, rbrack);
1744     else
1745        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1746         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1747                    "Scalar value @%" SVf "%c%" SVf "%c better written as $%"
1748                     SVf "%c%" SVf "%c",
1749                     SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1750                     SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1751 }
1752
1753 OP *
1754 Perl_scalar(pTHX_ OP *o)
1755 {
1756     OP *kid;
1757
1758     /* assumes no premature commitment */
1759     if (!o || (PL_parser && PL_parser->error_count)
1760          || (o->op_flags & OPf_WANT)
1761          || o->op_type == OP_RETURN)
1762     {
1763         return o;
1764     }
1765
1766     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1767
1768     switch (o->op_type) {
1769     case OP_REPEAT:
1770         scalar(cBINOPo->op_first);
1771         if (o->op_private & OPpREPEAT_DOLIST) {
1772             kid = cLISTOPx(cUNOPo->op_first)->op_first;
1773             assert(kid->op_type == OP_PUSHMARK);
1774             if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1775                 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1776                 o->op_private &=~ OPpREPEAT_DOLIST;
1777             }
1778         }
1779         break;
1780     case OP_OR:
1781     case OP_AND:
1782     case OP_COND_EXPR:
1783         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
1784             scalar(kid);
1785         break;
1786         /* FALLTHROUGH */
1787     case OP_SPLIT:
1788     case OP_MATCH:
1789     case OP_QR:
1790     case OP_SUBST:
1791     case OP_NULL:
1792     default:
1793         if (o->op_flags & OPf_KIDS) {
1794             for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1795                 scalar(kid);
1796         }
1797         break;
1798     case OP_LEAVE:
1799     case OP_LEAVETRY:
1800         kid = cLISTOPo->op_first;
1801         scalar(kid);
1802         kid = OpSIBLING(kid);
1803     do_kids:
1804         while (kid) {
1805             OP *sib = OpSIBLING(kid);
1806             if (sib && kid->op_type != OP_LEAVEWHEN
1807              && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
1808                 || (  sib->op_targ != OP_NEXTSTATE
1809                    && sib->op_targ != OP_DBSTATE  )))
1810                 scalarvoid(kid);
1811             else
1812                 scalar(kid);
1813             kid = sib;
1814         }
1815         PL_curcop = &PL_compiling;
1816         break;
1817     case OP_SCOPE:
1818     case OP_LINESEQ:
1819     case OP_LIST:
1820         kid = cLISTOPo->op_first;
1821         goto do_kids;
1822     case OP_SORT:
1823         Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1824         break;
1825     case OP_KVHSLICE:
1826     case OP_KVASLICE:
1827     {
1828         /* Warn about scalar context */
1829         const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1830         const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1831         SV *name;
1832         SV *keysv;
1833         const char *key = NULL;
1834
1835         /* This warning can be nonsensical when there is a syntax error. */
1836         if (PL_parser && PL_parser->error_count)
1837             break;
1838
1839         if (!ckWARN(WARN_SYNTAX)) break;
1840
1841         kid = cLISTOPo->op_first;
1842         kid = OpSIBLING(kid); /* get past pushmark */
1843         assert(OpSIBLING(kid));
1844         name = S_op_varname(aTHX_ OpSIBLING(kid));
1845         if (!name) /* XS module fiddling with the op tree */
1846             break;
1847         S_op_pretty(aTHX_ kid, &keysv, &key);
1848         assert(SvPOK(name));
1849         sv_chop(name,SvPVX(name)+1);
1850         if (key)
1851   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1852             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1853                        "%%%" SVf "%c%s%c in scalar context better written "
1854                        "as $%" SVf "%c%s%c",
1855                         SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1856                         lbrack, key, rbrack);
1857         else
1858   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1859             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1860                        "%%%" SVf "%c%" SVf "%c in scalar context better "
1861                        "written as $%" SVf "%c%" SVf "%c",
1862                         SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1863                         SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1864     }
1865     }
1866     return o;
1867 }
1868
1869 OP *
1870 Perl_scalarvoid(pTHX_ OP *arg)
1871 {
1872     dVAR;
1873     OP *kid;
1874     SV* sv;
1875     SSize_t defer_stack_alloc = 0;
1876     SSize_t defer_ix = -1;
1877     OP **defer_stack = NULL;
1878     OP *o = arg;
1879
1880     PERL_ARGS_ASSERT_SCALARVOID;
1881
1882     do {
1883         U8 want;
1884         SV *useless_sv = NULL;
1885         const char* useless = NULL;
1886
1887         if (o->op_type == OP_NEXTSTATE
1888             || o->op_type == OP_DBSTATE
1889             || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1890                                           || o->op_targ == OP_DBSTATE)))
1891             PL_curcop = (COP*)o;                /* for warning below */
1892
1893         /* assumes no premature commitment */
1894         want = o->op_flags & OPf_WANT;
1895         if ((want && want != OPf_WANT_SCALAR)
1896             || (PL_parser && PL_parser->error_count)
1897             || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1898         {
1899             continue;
1900         }
1901
1902         if ((o->op_private & OPpTARGET_MY)
1903             && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1904         {
1905             /* newASSIGNOP has already applied scalar context, which we
1906                leave, as if this op is inside SASSIGN.  */
1907             continue;
1908         }
1909
1910         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1911
1912         switch (o->op_type) {
1913         default:
1914             if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1915                 break;
1916             /* FALLTHROUGH */
1917         case OP_REPEAT:
1918             if (o->op_flags & OPf_STACKED)
1919                 break;
1920             if (o->op_type == OP_REPEAT)
1921                 scalar(cBINOPo->op_first);
1922             goto func_ops;
1923         case OP_SUBSTR:
1924             if (o->op_private == 4)
1925                 break;
1926             /* FALLTHROUGH */
1927         case OP_WANTARRAY:
1928         case OP_GV:
1929         case OP_SMARTMATCH:
1930         case OP_AV2ARYLEN:
1931         case OP_REF:
1932         case OP_REFGEN:
1933         case OP_SREFGEN:
1934         case OP_DEFINED:
1935         case OP_HEX:
1936         case OP_OCT:
1937         case OP_LENGTH:
1938         case OP_VEC:
1939         case OP_INDEX:
1940         case OP_RINDEX:
1941         case OP_SPRINTF:
1942         case OP_KVASLICE:
1943         case OP_KVHSLICE:
1944         case OP_UNPACK:
1945         case OP_PACK:
1946         case OP_JOIN:
1947         case OP_LSLICE:
1948         case OP_ANONLIST:
1949         case OP_ANONHASH:
1950         case OP_SORT:
1951         case OP_REVERSE:
1952         case OP_RANGE:
1953         case OP_FLIP:
1954         case OP_FLOP:
1955         case OP_CALLER:
1956         case OP_FILENO:
1957         case OP_EOF:
1958         case OP_TELL:
1959         case OP_GETSOCKNAME:
1960         case OP_GETPEERNAME:
1961         case OP_READLINK:
1962         case OP_TELLDIR:
1963         case OP_GETPPID:
1964         case OP_GETPGRP:
1965         case OP_GETPRIORITY:
1966         case OP_TIME:
1967         case OP_TMS:
1968         case OP_LOCALTIME:
1969         case OP_GMTIME:
1970         case OP_GHBYNAME:
1971         case OP_GHBYADDR:
1972         case OP_GHOSTENT:
1973         case OP_GNBYNAME:
1974         case OP_GNBYADDR:
1975         case OP_GNETENT:
1976         case OP_GPBYNAME:
1977         case OP_GPBYNUMBER:
1978         case OP_GPROTOENT:
1979         case OP_GSBYNAME:
1980         case OP_GSBYPORT:
1981         case OP_GSERVENT:
1982         case OP_GPWNAM:
1983         case OP_GPWUID:
1984         case OP_GGRNAM:
1985         case OP_GGRGID:
1986         case OP_GETLOGIN:
1987         case OP_PROTOTYPE:
1988         case OP_RUNCV:
1989         func_ops:
1990             useless = OP_DESC(o);
1991             break;
1992
1993         case OP_GVSV:
1994         case OP_PADSV:
1995         case OP_PADAV:
1996         case OP_PADHV:
1997         case OP_PADANY:
1998         case OP_AELEM:
1999         case OP_AELEMFAST:
2000         case OP_AELEMFAST_LEX:
2001         case OP_ASLICE:
2002         case OP_HELEM:
2003         case OP_HSLICE:
2004             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
2005                 /* Otherwise it's "Useless use of grep iterator" */
2006                 useless = OP_DESC(o);
2007             break;
2008
2009         case OP_SPLIT:
2010             if (!(o->op_private & OPpSPLIT_ASSIGN))
2011                 useless = OP_DESC(o);
2012             break;
2013
2014         case OP_NOT:
2015             kid = cUNOPo->op_first;
2016             if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2017                 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2018                 goto func_ops;
2019             }
2020             useless = "negative pattern binding (!~)";
2021             break;
2022
2023         case OP_SUBST:
2024             if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2025                 useless = "non-destructive substitution (s///r)";
2026             break;
2027
2028         case OP_TRANSR:
2029             useless = "non-destructive transliteration (tr///r)";
2030             break;
2031
2032         case OP_RV2GV:
2033         case OP_RV2SV:
2034         case OP_RV2AV:
2035         case OP_RV2HV:
2036             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
2037                 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
2038                 useless = "a variable";
2039             break;
2040
2041         case OP_CONST:
2042             sv = cSVOPo_sv;
2043             if (cSVOPo->op_private & OPpCONST_STRICT)
2044                 no_bareword_allowed(o);
2045             else {
2046                 if (ckWARN(WARN_VOID)) {
2047                     NV nv;
2048                     /* don't warn on optimised away booleans, eg
2049                      * use constant Foo, 5; Foo || print; */
2050                     if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2051                         useless = NULL;
2052                     /* the constants 0 and 1 are permitted as they are
2053                        conventionally used as dummies in constructs like
2054                        1 while some_condition_with_side_effects;  */
2055                     else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2056                         useless = NULL;
2057                     else if (SvPOK(sv)) {
2058                         SV * const dsv = newSVpvs("");
2059                         useless_sv
2060                             = Perl_newSVpvf(aTHX_
2061                                             "a constant (%s)",
2062                                             pv_pretty(dsv, SvPVX_const(sv),
2063                                                       SvCUR(sv), 32, NULL, NULL,
2064                                                       PERL_PV_PRETTY_DUMP
2065                                                       | PERL_PV_ESCAPE_NOCLEAR
2066                                                       | PERL_PV_ESCAPE_UNI_DETECT));
2067                         SvREFCNT_dec_NN(dsv);
2068                     }
2069                     else if (SvOK(sv)) {
2070                         useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv));
2071                     }
2072                     else
2073                         useless = "a constant (undef)";
2074                 }
2075             }
2076             op_null(o);         /* don't execute or even remember it */
2077             break;
2078
2079         case OP_POSTINC:
2080             OpTYPE_set(o, OP_PREINC);  /* pre-increment is faster */
2081             break;
2082
2083         case OP_POSTDEC:
2084             OpTYPE_set(o, OP_PREDEC);  /* pre-decrement is faster */
2085             break;
2086
2087         case OP_I_POSTINC:
2088             OpTYPE_set(o, OP_I_PREINC);        /* pre-increment is faster */
2089             break;
2090
2091         case OP_I_POSTDEC:
2092             OpTYPE_set(o, OP_I_PREDEC);        /* pre-decrement is faster */
2093             break;
2094
2095         case OP_SASSIGN: {
2096             OP *rv2gv;
2097             UNOP *refgen, *rv2cv;
2098             LISTOP *exlist;
2099
2100             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2101                 break;
2102
2103             rv2gv = ((BINOP *)o)->op_last;
2104             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2105                 break;
2106
2107             refgen = (UNOP *)((BINOP *)o)->op_first;
2108
2109             if (!refgen || (refgen->op_type != OP_REFGEN
2110                             && refgen->op_type != OP_SREFGEN))
2111                 break;
2112
2113             exlist = (LISTOP *)refgen->op_first;
2114             if (!exlist || exlist->op_type != OP_NULL
2115                 || exlist->op_targ != OP_LIST)
2116                 break;
2117
2118             if (exlist->op_first->op_type != OP_PUSHMARK
2119                 && exlist->op_first != exlist->op_last)
2120                 break;
2121
2122             rv2cv = (UNOP*)exlist->op_last;
2123
2124             if (rv2cv->op_type != OP_RV2CV)
2125                 break;
2126
2127             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2128             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2129             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2130
2131             o->op_private |= OPpASSIGN_CV_TO_GV;
2132             rv2gv->op_private |= OPpDONT_INIT_GV;
2133             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2134
2135             break;
2136         }
2137
2138         case OP_AASSIGN: {
2139             inplace_aassign(o);
2140             break;
2141         }
2142
2143         case OP_OR:
2144         case OP_AND:
2145             kid = cLOGOPo->op_first;
2146             if (kid->op_type == OP_NOT
2147                 && (kid->op_flags & OPf_KIDS)) {
2148                 if (o->op_type == OP_AND) {
2149                     OpTYPE_set(o, OP_OR);
2150                 } else {
2151                     OpTYPE_set(o, OP_AND);
2152                 }
2153                 op_null(kid);
2154             }
2155             /* FALLTHROUGH */
2156
2157         case OP_DOR:
2158         case OP_COND_EXPR:
2159         case OP_ENTERGIVEN:
2160         case OP_ENTERWHEN:
2161             for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2162                 if (!(kid->op_flags & OPf_KIDS))
2163                     scalarvoid(kid);
2164                 else
2165                     DEFER_OP(kid);
2166         break;
2167
2168         case OP_NULL:
2169             if (o->op_flags & OPf_STACKED)
2170                 break;
2171             /* FALLTHROUGH */
2172         case OP_NEXTSTATE:
2173         case OP_DBSTATE:
2174         case OP_ENTERTRY:
2175         case OP_ENTER:
2176             if (!(o->op_flags & OPf_KIDS))
2177                 break;
2178             /* FALLTHROUGH */
2179         case OP_SCOPE:
2180         case OP_LEAVE:
2181         case OP_LEAVETRY:
2182         case OP_LEAVELOOP:
2183         case OP_LINESEQ:
2184         case OP_LEAVEGIVEN:
2185         case OP_LEAVEWHEN:
2186         kids:
2187             for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2188                 if (!(kid->op_flags & OPf_KIDS))
2189                     scalarvoid(kid);
2190                 else
2191                     DEFER_OP(kid);
2192             break;
2193         case OP_LIST:
2194             /* If the first kid after pushmark is something that the padrange
2195                optimisation would reject, then null the list and the pushmark.
2196             */
2197             if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2198                 && (  !(kid = OpSIBLING(kid))
2199                       || (  kid->op_type != OP_PADSV
2200                             && kid->op_type != OP_PADAV
2201                             && kid->op_type != OP_PADHV)
2202                       || kid->op_private & ~OPpLVAL_INTRO
2203                       || !(kid = OpSIBLING(kid))
2204                       || (  kid->op_type != OP_PADSV
2205                             && kid->op_type != OP_PADAV
2206                             && kid->op_type != OP_PADHV)
2207                       || kid->op_private & ~OPpLVAL_INTRO)
2208             ) {
2209                 op_null(cUNOPo->op_first); /* NULL the pushmark */
2210                 op_null(o); /* NULL the list */
2211             }
2212             goto kids;
2213         case OP_ENTEREVAL:
2214             scalarkids(o);
2215             break;
2216         case OP_SCALAR:
2217             scalar(o);
2218             break;
2219         }
2220
2221         if (useless_sv) {
2222             /* mortalise it, in case warnings are fatal.  */
2223             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2224                            "Useless use of %" SVf " in void context",
2225                            SVfARG(sv_2mortal(useless_sv)));
2226         }
2227         else if (useless) {
2228             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2229                            "Useless use of %s in void context",
2230                            useless);
2231         }
2232     } while ( (o = POP_DEFERRED_OP()) );
2233
2234     Safefree(defer_stack);
2235
2236     return arg;
2237 }
2238
2239 static OP *
2240 S_listkids(pTHX_ OP *o)
2241 {
2242     if (o && o->op_flags & OPf_KIDS) {
2243         OP *kid;
2244         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2245             list(kid);
2246     }
2247     return o;
2248 }
2249
2250 OP *
2251 Perl_list(pTHX_ OP *o)
2252 {
2253     OP *kid;
2254
2255     /* assumes no premature commitment */
2256     if (!o || (o->op_flags & OPf_WANT)
2257          || (PL_parser && PL_parser->error_count)
2258          || o->op_type == OP_RETURN)
2259     {
2260         return o;
2261     }
2262
2263     if ((o->op_private & OPpTARGET_MY)
2264         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2265     {
2266         return o;                               /* As if inside SASSIGN */
2267     }
2268
2269     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2270
2271     switch (o->op_type) {
2272     case OP_FLOP:
2273         list(cBINOPo->op_first);
2274         break;
2275     case OP_REPEAT:
2276         if (o->op_private & OPpREPEAT_DOLIST
2277          && !(o->op_flags & OPf_STACKED))
2278         {
2279             list(cBINOPo->op_first);
2280             kid = cBINOPo->op_last;
2281             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2282              && SvIVX(kSVOP_sv) == 1)
2283             {
2284                 op_null(o); /* repeat */
2285                 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2286                 /* const (rhs): */
2287                 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2288             }
2289         }
2290         break;
2291     case OP_OR:
2292     case OP_AND:
2293     case OP_COND_EXPR:
2294         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2295             list(kid);
2296         break;
2297     default:
2298     case OP_MATCH:
2299     case OP_QR:
2300     case OP_SUBST:
2301     case OP_NULL:
2302         if (!(o->op_flags & OPf_KIDS))
2303             break;
2304         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2305             list(cBINOPo->op_first);
2306             return gen_constant_list(o);
2307         }
2308         listkids(o);
2309         break;
2310     case OP_LIST:
2311         listkids(o);
2312         if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2313             op_null(cUNOPo->op_first); /* NULL the pushmark */
2314             op_null(o); /* NULL the list */
2315         }
2316         break;
2317     case OP_LEAVE:
2318     case OP_LEAVETRY:
2319         kid = cLISTOPo->op_first;
2320         list(kid);
2321         kid = OpSIBLING(kid);
2322     do_kids:
2323         while (kid) {
2324             OP *sib = OpSIBLING(kid);
2325             if (sib && kid->op_type != OP_LEAVEWHEN)
2326                 scalarvoid(kid);
2327             else
2328                 list(kid);
2329             kid = sib;
2330         }
2331         PL_curcop = &PL_compiling;
2332         break;
2333     case OP_SCOPE:
2334     case OP_LINESEQ:
2335         kid = cLISTOPo->op_first;
2336         goto do_kids;
2337     }
2338     return o;
2339 }
2340
2341 static OP *
2342 S_scalarseq(pTHX_ OP *o)
2343 {
2344     if (o) {
2345         const OPCODE type = o->op_type;
2346
2347         if (type == OP_LINESEQ || type == OP_SCOPE ||
2348             type == OP_LEAVE || type == OP_LEAVETRY)
2349         {
2350             OP *kid, *sib;
2351             for (kid = cLISTOPo->op_first; kid; kid = sib) {
2352                 if ((sib = OpSIBLING(kid))
2353                  && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2354                     || (  sib->op_targ != OP_NEXTSTATE
2355                        && sib->op_targ != OP_DBSTATE  )))
2356                 {
2357                     scalarvoid(kid);
2358                 }
2359             }
2360             PL_curcop = &PL_compiling;
2361         }
2362         o->op_flags &= ~OPf_PARENS;
2363         if (PL_hints & HINT_BLOCK_SCOPE)
2364             o->op_flags |= OPf_PARENS;
2365     }
2366     else
2367         o = newOP(OP_STUB, 0);
2368     return o;
2369 }
2370
2371 STATIC OP *
2372 S_modkids(pTHX_ OP *o, I32 type)
2373 {
2374     if (o && o->op_flags & OPf_KIDS) {
2375         OP *kid;
2376         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2377             op_lvalue(kid, type);
2378     }
2379     return o;
2380 }
2381
2382
2383 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2384  * const fields. Also, convert CONST keys to HEK-in-SVs.
2385  * rop is the op that retrieves the hash;
2386  * key_op is the first key
2387  */
2388
2389 STATIC void
2390 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op)
2391 {
2392     PADNAME *lexname;
2393     GV **fields;
2394     bool check_fields;
2395
2396     /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2397     if (rop) {
2398         if (rop->op_first->op_type == OP_PADSV)
2399             /* @$hash{qw(keys here)} */
2400             rop = (UNOP*)rop->op_first;
2401         else {
2402             /* @{$hash}{qw(keys here)} */
2403             if (rop->op_first->op_type == OP_SCOPE
2404                 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2405                 {
2406                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2407                 }
2408             else
2409                 rop = NULL;
2410         }
2411     }
2412
2413     lexname = NULL; /* just to silence compiler warnings */
2414     fields  = NULL; /* just to silence compiler warnings */
2415
2416     check_fields =
2417             rop
2418          && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2419              SvPAD_TYPED(lexname))
2420          && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2421          && isGV(*fields) && GvHV(*fields);
2422
2423     for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2424         SV **svp, *sv;
2425         if (key_op->op_type != OP_CONST)
2426             continue;
2427         svp = cSVOPx_svp(key_op);
2428
2429         /* make sure it's not a bareword under strict subs */
2430         if (key_op->op_private & OPpCONST_BARE &&
2431             key_op->op_private & OPpCONST_STRICT)
2432         {
2433             no_bareword_allowed((OP*)key_op);
2434         }
2435
2436         /* Make the CONST have a shared SV */
2437         if (   !SvIsCOW_shared_hash(sv = *svp)
2438             && SvTYPE(sv) < SVt_PVMG
2439             && SvOK(sv)
2440             && !SvROK(sv))
2441         {
2442             SSize_t keylen;
2443             const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2444             SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2445             SvREFCNT_dec_NN(sv);
2446             *svp = nsv;
2447         }
2448
2449         if (   check_fields
2450             && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2451         {
2452             Perl_croak(aTHX_ "No such class field \"%" SVf "\" "
2453                         "in variable %" PNf " of type %" HEKf,
2454                         SVfARG(*svp), PNfARG(lexname),
2455                         HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2456         }
2457     }
2458 }
2459
2460
2461 /* do all the final processing on an optree (e.g. running the peephole
2462  * optimiser on it), then attach it to cv (if cv is non-null)
2463  */
2464
2465 static void
2466 S_process_optree(pTHX_ CV *cv, OP *optree, OP* start)
2467 {
2468     OP **startp;
2469
2470     /* XXX for some reason, evals, require and main optrees are
2471      * never attached to their CV; instead they just hang off
2472      * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start
2473      * and get manually freed when appropriate */
2474     if (cv)
2475         startp = &CvSTART(cv);
2476     else
2477         startp = PL_in_eval? &PL_eval_start : &PL_main_start;
2478
2479     *startp = start;
2480     optree->op_private |= OPpREFCOUNTED;
2481     OpREFCNT_set(optree, 1);
2482     CALL_PEEP(*startp);
2483     finalize_optree(optree);
2484     S_prune_chain_head(startp);
2485
2486     if (cv) {
2487         /* now that optimizer has done its work, adjust pad values */
2488         pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT
2489                  : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
2490     }
2491 }
2492
2493
2494 /*
2495 =for apidoc finalize_optree
2496
2497 This function finalizes the optree.  Should be called directly after
2498 the complete optree is built.  It does some additional
2499 checking which can't be done in the normal C<ck_>xxx functions and makes
2500 the tree thread-safe.
2501
2502 =cut
2503 */
2504 void
2505 Perl_finalize_optree(pTHX_ OP* o)
2506 {
2507     PERL_ARGS_ASSERT_FINALIZE_OPTREE;
2508
2509     ENTER;
2510     SAVEVPTR(PL_curcop);
2511
2512     finalize_op(o);
2513
2514     LEAVE;
2515 }
2516
2517 #ifdef USE_ITHREADS
2518 /* Relocate sv to the pad for thread safety.
2519  * Despite being a "constant", the SV is written to,
2520  * for reference counts, sv_upgrade() etc. */
2521 PERL_STATIC_INLINE void
2522 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
2523 {
2524     PADOFFSET ix;
2525     PERL_ARGS_ASSERT_OP_RELOCATE_SV;
2526     if (!*svp) return;
2527     ix = pad_alloc(OP_CONST, SVf_READONLY);
2528     SvREFCNT_dec(PAD_SVl(ix));
2529     PAD_SETSV(ix, *svp);
2530     /* XXX I don't know how this isn't readonly already. */
2531     if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
2532     *svp = NULL;
2533     *targp = ix;
2534 }
2535 #endif
2536
2537
2538 STATIC void
2539 S_finalize_op(pTHX_ OP* o)
2540 {
2541     PERL_ARGS_ASSERT_FINALIZE_OP;
2542
2543     assert(o->op_type != OP_FREED);
2544
2545     switch (o->op_type) {
2546     case OP_NEXTSTATE:
2547     case OP_DBSTATE:
2548         PL_curcop = ((COP*)o);          /* for warnings */
2549         break;
2550     case OP_EXEC:
2551         if (OpHAS_SIBLING(o)) {
2552             OP *sib = OpSIBLING(o);
2553             if ((  sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
2554                 && ckWARN(WARN_EXEC)
2555                 && OpHAS_SIBLING(sib))
2556             {
2557                     const OPCODE type = OpSIBLING(sib)->op_type;
2558                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
2559                         const line_t oldline = CopLINE(PL_curcop);
2560                         CopLINE_set(PL_curcop, CopLINE((COP*)sib));
2561                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
2562                             "Statement unlikely to be reached");
2563                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
2564                             "\t(Maybe you meant system() when you said exec()?)\n");
2565                         CopLINE_set(PL_curcop, oldline);
2566                     }
2567             }
2568         }
2569         break;
2570
2571     case OP_GV:
2572         if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
2573             GV * const gv = cGVOPo_gv;
2574             if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
2575                 /* XXX could check prototype here instead of just carping */
2576                 SV * const sv = sv_newmortal();
2577                 gv_efullname3(sv, gv, NULL);
2578                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
2579                     "%" SVf "() called too early to check prototype",
2580                     SVfARG(sv));
2581             }
2582         }
2583         break;
2584
2585     case OP_CONST:
2586         if (cSVOPo->op_private & OPpCONST_STRICT)
2587             no_bareword_allowed(o);
2588 #ifdef USE_ITHREADS
2589         /* FALLTHROUGH */
2590     case OP_HINTSEVAL:
2591         op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
2592 #endif
2593         break;
2594
2595 #ifdef USE_ITHREADS
2596     /* Relocate all the METHOP's SVs to the pad for thread safety. */
2597     case OP_METHOD_NAMED:
2598     case OP_METHOD_SUPER:
2599     case OP_METHOD_REDIR:
2600     case OP_METHOD_REDIR_SUPER:
2601         op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
2602         break;
2603 #endif
2604
2605     case OP_HELEM: {
2606         UNOP *rop;
2607         SVOP *key_op;
2608         OP *kid;
2609
2610         if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
2611             break;
2612
2613         rop = (UNOP*)((BINOP*)o)->op_first;
2614
2615         goto check_keys;
2616
2617     case OP_HSLICE:
2618         S_scalar_slice_warning(aTHX_ o);
2619         /* FALLTHROUGH */
2620
2621     case OP_KVHSLICE:
2622         kid = OpSIBLING(cLISTOPo->op_first);
2623         if (/* I bet there's always a pushmark... */
2624             OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
2625             && OP_TYPE_ISNT_NN(kid, OP_CONST))
2626         {
2627             break;
2628         }
2629
2630         key_op = (SVOP*)(kid->op_type == OP_CONST
2631                                 ? kid
2632                                 : OpSIBLING(kLISTOP->op_first));
2633
2634         rop = (UNOP*)((LISTOP*)o)->op_last;
2635
2636       check_keys:
2637         if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
2638             rop = NULL;
2639         S_check_hash_fields_and_hekify(aTHX_ rop, key_op);
2640         break;
2641     }
2642     case OP_NULL:
2643         if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE)
2644             break;
2645         /* FALLTHROUGH */
2646     case OP_ASLICE:
2647         S_scalar_slice_warning(aTHX_ o);
2648         break;
2649
2650     case OP_SUBST: {
2651         if (cPMOPo->op_pmreplrootu.op_pmreplroot)
2652             finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
2653         break;
2654     }
2655     default:
2656         break;
2657     }
2658
2659     if (o->op_flags & OPf_KIDS) {
2660         OP *kid;
2661
2662 #ifdef DEBUGGING
2663         /* check that op_last points to the last sibling, and that
2664          * the last op_sibling/op_sibparent field points back to the
2665          * parent, and that the only ops with KIDS are those which are
2666          * entitled to them */
2667         U32 type = o->op_type;
2668         U32 family;
2669         bool has_last;
2670
2671         if (type == OP_NULL) {
2672             type = o->op_targ;
2673             /* ck_glob creates a null UNOP with ex-type GLOB
2674              * (which is a list op. So pretend it wasn't a listop */
2675             if (type == OP_GLOB)
2676                 type = OP_NULL;
2677         }
2678         family = PL_opargs[type] & OA_CLASS_MASK;
2679
2680         has_last = (   family == OA_BINOP
2681                     || family == OA_LISTOP
2682                     || family == OA_PMOP
2683                     || family == OA_LOOP
2684                    );
2685         assert(  has_last /* has op_first and op_last, or ...
2686               ... has (or may have) op_first: */
2687               || family == OA_UNOP
2688               || family == OA_UNOP_AUX
2689               || family == OA_LOGOP
2690               || family == OA_BASEOP_OR_UNOP
2691               || family == OA_FILESTATOP
2692               || family == OA_LOOPEXOP
2693               || family == OA_METHOP
2694               || type == OP_CUSTOM
2695               || type == OP_NULL /* new_logop does this */
2696               );
2697
2698         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2699 #  ifdef PERL_OP_PARENT
2700             if (!OpHAS_SIBLING(kid)) {
2701                 if (has_last)
2702                     assert(kid == cLISTOPo->op_last);
2703                 assert(kid->op_sibparent == o);
2704             }
2705 #  else
2706             if (has_last && !OpHAS_SIBLING(kid))
2707                 assert(kid == cLISTOPo->op_last);
2708 #  endif
2709         }
2710 #endif
2711
2712         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
2713             finalize_op(kid);
2714     }
2715 }
2716
2717 /*
2718 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
2719
2720 Propagate lvalue ("modifiable") context to an op and its children.
2721 C<type> represents the context type, roughly based on the type of op that
2722 would do the modifying, although C<local()> is represented by C<OP_NULL>,
2723 because it has no op type of its own (it is signalled by a flag on
2724 the lvalue op).
2725
2726 This function detects things that can't be modified, such as C<$x+1>, and
2727 generates errors for them.  For example, C<$x+1 = 2> would cause it to be
2728 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
2729
2730 It also flags things that need to behave specially in an lvalue context,
2731 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
2732
2733 =cut
2734 */
2735
2736 static void
2737 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
2738 {
2739     CV *cv = PL_compcv;
2740     PadnameLVALUE_on(pn);
2741     while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
2742         cv = CvOUTSIDE(cv);
2743         /* RT #127786: cv can be NULL due to an eval within the DB package
2744          * called from an anon sub - anon subs don't have CvOUTSIDE() set
2745          * unless they contain an eval, but calling eval within DB
2746          * pretends the eval was done in the caller's scope.
2747          */
2748         if (!cv)
2749             break;
2750         assert(CvPADLIST(cv));
2751         pn =
2752            PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
2753         assert(PadnameLEN(pn));
2754         PadnameLVALUE_on(pn);
2755     }
2756 }
2757
2758 static bool
2759 S_vivifies(const OPCODE type)
2760 {
2761     switch(type) {
2762     case OP_RV2AV:     case   OP_ASLICE:
2763     case OP_RV2HV:     case OP_KVASLICE:
2764     case OP_RV2SV:     case   OP_HSLICE:
2765     case OP_AELEMFAST: case OP_KVHSLICE:
2766     case OP_HELEM:
2767     case OP_AELEM:
2768         return 1;
2769     }
2770     return 0;
2771 }
2772
2773 static void
2774 S_lvref(pTHX_ OP *o, I32 type)
2775 {
2776     dVAR;
2777     OP *kid;
2778     switch (o->op_type) {
2779     case OP_COND_EXPR:
2780         for (kid = OpSIBLING(cUNOPo->op_first); kid;
2781              kid = OpSIBLING(kid))
2782             S_lvref(aTHX_ kid, type);
2783         /* FALLTHROUGH */
2784     case OP_PUSHMARK:
2785         return;
2786     case OP_RV2AV:
2787         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2788         o->op_flags |= OPf_STACKED;
2789         if (o->op_flags & OPf_PARENS) {
2790             if (o->op_private & OPpLVAL_INTRO) {
2791                  yyerror(Perl_form(aTHX_ "Can't modify reference to "
2792                       "localized parenthesized array in list assignment"));
2793                 return;
2794             }
2795           slurpy:
2796             OpTYPE_set(o, OP_LVAVREF);
2797             o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
2798             o->op_flags |= OPf_MOD|OPf_REF;
2799             return;
2800         }
2801         o->op_private |= OPpLVREF_AV;
2802         goto checkgv;
2803     case OP_RV2CV:
2804         kid = cUNOPo->op_first;
2805         if (kid->op_type == OP_NULL)
2806             kid = cUNOPx(OpSIBLING(kUNOP->op_first))
2807                 ->op_first;
2808         o->op_private = OPpLVREF_CV;
2809         if (kid->op_type == OP_GV)
2810             o->op_flags |= OPf_STACKED;
2811         else if (kid->op_type == OP_PADCV) {
2812             o->op_targ = kid->op_targ;
2813             kid->op_targ = 0;
2814             op_free(cUNOPo->op_first);
2815             cUNOPo->op_first = NULL;
2816             o->op_flags &=~ OPf_KIDS;
2817         }
2818         else goto badref;
2819         break;
2820     case OP_RV2HV:
2821         if (o->op_flags & OPf_PARENS) {
2822           parenhash:
2823             yyerror(Perl_form(aTHX_ "Can't modify reference to "
2824                                  "parenthesized hash in list assignment"));
2825                 return;
2826         }
2827         o->op_private |= OPpLVREF_HV;
2828         /* FALLTHROUGH */
2829     case OP_RV2SV:
2830       checkgv:
2831         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2832         o->op_flags |= OPf_STACKED;
2833         break;
2834     case OP_PADHV:
2835         if (o->op_flags & OPf_PARENS) goto parenhash;
2836         o->op_private |= OPpLVREF_HV;
2837         /* FALLTHROUGH */
2838     case OP_PADSV:
2839         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2840         break;
2841     case OP_PADAV:
2842         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2843         if (o->op_flags & OPf_PARENS) goto slurpy;
2844         o->op_private |= OPpLVREF_AV;
2845         break;
2846     case OP_AELEM:
2847     case OP_HELEM:
2848         o->op_private |= OPpLVREF_ELEM;
2849         o->op_flags   |= OPf_STACKED;
2850         break;
2851     case OP_ASLICE:
2852     case OP_HSLICE:
2853         OpTYPE_set(o, OP_LVREFSLICE);
2854         o->op_private &= OPpLVAL_INTRO;
2855         return;
2856     case OP_NULL:
2857         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
2858             goto badref;
2859         else if (!(o->op_flags & OPf_KIDS))
2860             return;
2861         if (o->op_targ != OP_LIST) {
2862             S_lvref(aTHX_ cBINOPo->op_first, type);
2863             return;
2864         }
2865         /* FALLTHROUGH */
2866     case OP_LIST:
2867         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
2868             assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
2869             S_lvref(aTHX_ kid, type);
2870         }
2871         return;
2872     case OP_STUB:
2873         if (o->op_flags & OPf_PARENS)
2874             return;
2875         /* FALLTHROUGH */
2876     default:
2877       badref:
2878         /* diag_listed_as: Can't modify reference to %s in %s assignment */
2879         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
2880                      o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
2881                       ? "do block"
2882                       : OP_DESC(o),
2883                      PL_op_desc[type]));
2884         return;
2885     }
2886     OpTYPE_set(o, OP_LVREF);
2887     o->op_private &=
2888         OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
2889     if (type == OP_ENTERLOOP)
2890         o->op_private |= OPpLVREF_ITER;
2891 }
2892
2893 PERL_STATIC_INLINE bool
2894 S_potential_mod_type(I32 type)
2895 {
2896     /* Types that only potentially result in modification.  */
2897     return type == OP_GREPSTART || type == OP_ENTERSUB
2898         || type == OP_REFGEN    || type == OP_LEAVESUBLV;
2899 }
2900
2901 OP *
2902 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
2903 {
2904     dVAR;
2905     OP *kid;
2906     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2907     int localize = -1;
2908
2909     if (!o || (PL_parser && PL_parser->error_count))
2910         return o;
2911
2912     if ((o->op_private & OPpTARGET_MY)
2913         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2914     {
2915         return o;
2916     }
2917
2918     assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2919
2920     if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2921
2922     switch (o->op_type) {
2923     case OP_UNDEF:
2924         PL_modcount++;
2925         return o;
2926     case OP_STUB:
2927         if ((o->op_flags & OPf_PARENS))
2928             break;
2929         goto nomod;
2930     case OP_ENTERSUB:
2931         if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
2932             !(o->op_flags & OPf_STACKED)) {
2933             OpTYPE_set(o, OP_RV2CV);            /* entersub => rv2cv */
2934             assert(cUNOPo->op_first->op_type == OP_NULL);
2935             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
2936             break;
2937         }
2938         else {                          /* lvalue subroutine call */
2939             o->op_private |= OPpLVAL_INTRO;
2940             PL_modcount = RETURN_UNLIMITED_NUMBER;
2941             if (S_potential_mod_type(type)) {
2942                 o->op_private |= OPpENTERSUB_INARGS;
2943                 break;
2944             }
2945             else {                      /* Compile-time error message: */
2946                 OP *kid = cUNOPo->op_first;
2947                 CV *cv;
2948                 GV *gv;
2949                 SV *namesv;
2950
2951                 if (kid->op_type != OP_PUSHMARK) {
2952                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2953                         Perl_croak(aTHX_
2954                                 "panic: unexpected lvalue entersub "
2955                                 "args: type/targ %ld:%" UVuf,
2956                                 (long)kid->op_type, (UV)kid->op_targ);
2957                     kid = kLISTOP->op_first;
2958                 }
2959                 while (OpHAS_SIBLING(kid))
2960                     kid = OpSIBLING(kid);
2961                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
2962                     break;      /* Postpone until runtime */
2963                 }
2964
2965                 kid = kUNOP->op_first;
2966                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2967                     kid = kUNOP->op_first;
2968                 if (kid->op_type == OP_NULL)
2969                     Perl_croak(aTHX_
2970                                "Unexpected constant lvalue entersub "
2971                                "entry via type/targ %ld:%" UVuf,
2972                                (long)kid->op_type, (UV)kid->op_targ);
2973                 if (kid->op_type != OP_GV) {
2974                     break;
2975                 }
2976
2977                 gv = kGVOP_gv;
2978                 cv = isGV(gv)
2979                     ? GvCV(gv)
2980                     : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
2981                         ? MUTABLE_CV(SvRV(gv))
2982                         : NULL;
2983                 if (!cv)
2984                     break;
2985                 if (CvLVALUE(cv))
2986                     break;
2987                 if (flags & OP_LVALUE_NO_CROAK)
2988                     return NULL;
2989
2990                 namesv = cv_name(cv, NULL, 0);
2991                 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
2992                                      "subroutine call of &%" SVf " in %s",
2993                                      SVfARG(namesv), PL_op_desc[type]),
2994                            SvUTF8(namesv));
2995                 return o;
2996             }
2997         }
2998         /* FALLTHROUGH */
2999     default:
3000       nomod:
3001         if (flags & OP_LVALUE_NO_CROAK) return NULL;
3002         /* grep, foreach, subcalls, refgen */
3003         if (S_potential_mod_type(type))
3004             break;
3005         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
3006                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
3007                       ? "do block"
3008                       : OP_DESC(o)),
3009                      type ? PL_op_desc[type] : "local"));
3010         return o;
3011
3012     case OP_PREINC:
3013     case OP_PREDEC:
3014     case OP_POW:
3015     case OP_MULTIPLY:
3016     case OP_DIVIDE:
3017     case OP_MODULO:
3018     case OP_ADD:
3019     case OP_SUBTRACT:
3020     case OP_CONCAT:
3021     case OP_LEFT_SHIFT:
3022     case OP_RIGHT_SHIFT:
3023     case OP_BIT_AND:
3024     case OP_BIT_XOR:
3025     case OP_BIT_OR:
3026     case OP_I_MULTIPLY:
3027     case OP_I_DIVIDE:
3028     case OP_I_MODULO:
3029     case OP_I_ADD:
3030     case OP_I_SUBTRACT:
3031         if (!(o->op_flags & OPf_STACKED))
3032             goto nomod;
3033         PL_modcount++;
3034         break;
3035
3036     case OP_REPEAT:
3037         if (o->op_flags & OPf_STACKED) {
3038             PL_modcount++;
3039             break;
3040         }
3041         if (!(o->op_private & OPpREPEAT_DOLIST))
3042             goto nomod;
3043         else {
3044             const I32 mods = PL_modcount;
3045             modkids(cBINOPo->op_first, type);
3046             if (type != OP_AASSIGN)
3047                 goto nomod;
3048             kid = cBINOPo->op_last;
3049             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
3050                 const IV iv = SvIV(kSVOP_sv);
3051                 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
3052                     PL_modcount =
3053                         mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
3054             }
3055             else
3056                 PL_modcount = RETURN_UNLIMITED_NUMBER;
3057         }
3058         break;
3059
3060     case OP_COND_EXPR:
3061         localize = 1;
3062         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
3063             op_lvalue(kid, type);
3064         break;
3065
3066     case OP_RV2AV:
3067     case OP_RV2HV:
3068         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
3069            PL_modcount = RETURN_UNLIMITED_NUMBER;
3070             return o;           /* Treat \(@foo) like ordinary list. */
3071         }
3072         /* FALLTHROUGH */
3073     case OP_RV2GV:
3074         if (scalar_mod_type(o, type))
3075             goto nomod;
3076         ref(cUNOPo->op_first, o->op_type);
3077         /* FALLTHROUGH */
3078     case OP_ASLICE:
3079     case OP_HSLICE:
3080         localize = 1;
3081         /* FALLTHROUGH */
3082     case OP_AASSIGN:
3083         /* Do not apply the lvsub flag for rv2[ah]v in scalar context.  */
3084         if (type == OP_LEAVESUBLV && (
3085                 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
3086              || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
3087            ))
3088             o->op_private |= OPpMAYBE_LVSUB;
3089         /* FALLTHROUGH */
3090     case OP_NEXTSTATE:
3091     case OP_DBSTATE:
3092        PL_modcount = RETURN_UNLIMITED_NUMBER;
3093         break;
3094     case OP_KVHSLICE:
3095     case OP_KVASLICE:
3096     case OP_AKEYS:
3097         if (type == OP_LEAVESUBLV)
3098             o->op_private |= OPpMAYBE_LVSUB;
3099         goto nomod;
3100     case OP_AVHVSWITCH:
3101         if (type == OP_LEAVESUBLV
3102          && (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS)
3103             o->op_private |= OPpMAYBE_LVSUB;
3104         goto nomod;
3105     case OP_AV2ARYLEN:
3106         PL_hints |= HINT_BLOCK_SCOPE;
3107         if (type == OP_LEAVESUBLV)
3108             o->op_private |= OPpMAYBE_LVSUB;
3109         PL_modcount++;
3110         break;
3111     case OP_RV2SV:
3112         ref(cUNOPo->op_first, o->op_type);
3113         localize = 1;
3114         /* FALLTHROUGH */
3115     case OP_GV:
3116         PL_hints |= HINT_BLOCK_SCOPE;
3117         /* FALLTHROUGH */
3118     case OP_SASSIGN:
3119     case OP_ANDASSIGN:
3120     case OP_ORASSIGN:
3121     case OP_DORASSIGN:
3122         PL_modcount++;
3123         break;
3124
3125     case OP_AELEMFAST:
3126     case OP_AELEMFAST_LEX:
3127         localize = -1;
3128         PL_modcount++;
3129         break;
3130
3131     case OP_PADAV:
3132     case OP_PADHV:
3133        PL_modcount = RETURN_UNLIMITED_NUMBER;
3134         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
3135             return o;           /* Treat \(@foo) like ordinary list. */
3136         if (scalar_mod_type(o, type))
3137             goto nomod;
3138         if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
3139           && type == OP_LEAVESUBLV)
3140             o->op_private |= OPpMAYBE_LVSUB;
3141         /* FALLTHROUGH */
3142     case OP_PADSV:
3143         PL_modcount++;
3144         if (!type) /* local() */
3145             Perl_croak(aTHX_ "Can't localize lexical variable %" PNf,
3146                               PNfARG(PAD_COMPNAME(o->op_targ)));
3147         if (!(o->op_private & OPpLVAL_INTRO)
3148          || (  type != OP_SASSIGN && type != OP_AASSIGN
3149             && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ))  ))
3150             S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
3151         break;
3152
3153     case OP_PUSHMARK:
3154         localize = 0;
3155         break;
3156
3157     case OP_KEYS:
3158         if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
3159             goto nomod;
3160         goto lvalue_func;
3161     case OP_SUBSTR:
3162         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
3163             goto nomod;
3164         /* FALLTHROUGH */
3165     case OP_POS:
3166     case OP_VEC:
3167       lvalue_func:
3168         if (type == OP_LEAVESUBLV)
3169             o->op_private |= OPpMAYBE_LVSUB;
3170         if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
3171             /* substr and vec */
3172             /* If this op is in merely potential (non-fatal) modifiable
3173                context, then apply OP_ENTERSUB context to
3174                the kid op (to avoid croaking).  Other-
3175                wise pass this op’s own type so the correct op is mentioned
3176                in error messages.  */
3177             op_lvalue(OpSIBLING(cBINOPo->op_first),
3178                       S_potential_mod_type(type)
3179                         ? (I32)OP_ENTERSUB
3180                         : o->op_type);
3181         }
3182         break;
3183
3184     case OP_AELEM:
3185     case OP_HELEM:
3186         ref(cBINOPo->op_first, o->op_type);
3187         if (type == OP_ENTERSUB &&
3188              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
3189             o->op_private |= OPpLVAL_DEFER;
3190         if (type == OP_LEAVESUBLV)
3191             o->op_private |= OPpMAYBE_LVSUB;
3192         localize = 1;
3193         PL_modcount++;
3194         break;
3195
3196     case OP_LEAVE:
3197     case OP_LEAVELOOP:
3198         o->op_private |= OPpLVALUE;
3199         /* FALLTHROUGH */
3200     case OP_SCOPE:
3201     case OP_ENTER:
3202     case OP_LINESEQ:
3203         localize = 0;
3204         if (o->op_flags & OPf_KIDS)
3205             op_lvalue(cLISTOPo->op_last, type);
3206         break;
3207
3208     case OP_NULL:
3209         localize = 0;
3210         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
3211             goto nomod;
3212         else if (!(o->op_flags & OPf_KIDS))
3213             break;
3214
3215         if (o->op_targ != OP_LIST) {
3216             OP *sib = OpSIBLING(cLISTOPo->op_first);
3217             /* OP_TRANS and OP_TRANSR with argument have a weird optree
3218              * that looks like
3219              *
3220              *   null
3221              *      arg
3222              *      trans
3223              *
3224              * compared with things like OP_MATCH which have the argument
3225              * as a child:
3226              *
3227              *   match
3228              *      arg
3229              *
3230              * so handle specially to correctly get "Can't modify" croaks etc
3231              */
3232
3233             if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR))
3234             {
3235                 /* this should trigger a "Can't modify transliteration" err */
3236                 op_lvalue(sib, type);
3237             }
3238             op_lvalue(cBINOPo->op_first, type);
3239             break;
3240         }
3241         /* FALLTHROUGH */
3242     case OP_LIST:
3243         localize = 0;
3244         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3245             /* elements might be in void context because the list is
3246                in scalar context or because they are attribute sub calls */
3247             if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
3248                 op_lvalue(kid, type);
3249         break;
3250
3251     case OP_COREARGS:
3252         return o;
3253
3254     case OP_AND:
3255     case OP_OR:
3256         if (type == OP_LEAVESUBLV
3257          || !S_vivifies(cLOGOPo->op_first->op_type))
3258             op_lvalue(cLOGOPo->op_first, type);
3259         if (type == OP_LEAVESUBLV
3260          || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
3261             op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
3262         goto nomod;
3263
3264     case OP_SREFGEN:
3265         if (type == OP_NULL) { /* local */
3266           local_refgen:
3267             if (!FEATURE_MYREF_IS_ENABLED)
3268                 Perl_croak(aTHX_ "The experimental declared_refs "
3269                                  "feature is not enabled");
3270             Perl_ck_warner_d(aTHX_
3271                      packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
3272                     "Declaring references is experimental");
3273             op_lvalue(cUNOPo->op_first, OP_NULL);
3274             return o;
3275         }
3276         if (type != OP_AASSIGN && type != OP_SASSIGN
3277          && type != OP_ENTERLOOP)
3278             goto nomod;
3279         /* Don’t bother applying lvalue context to the ex-list.  */
3280         kid = cUNOPx(cUNOPo->op_first)->op_first;
3281         assert (!OpHAS_SIBLING(kid));
3282         goto kid_2lvref;
3283     case OP_REFGEN:
3284         if (type == OP_NULL) /* local */
3285             goto local_refgen;
3286         if (type != OP_AASSIGN) goto nomod;
3287         kid = cUNOPo->op_first;
3288       kid_2lvref:
3289         {
3290             const U8 ec = PL_parser ? PL_parser->error_count : 0;
3291             S_lvref(aTHX_ kid, type);
3292             if (!PL_parser || PL_parser->error_count == ec) {
3293                 if (!FEATURE_REFALIASING_IS_ENABLED)
3294                     Perl_croak(aTHX_
3295                        "Experimental aliasing via reference not enabled");
3296                 Perl_ck_warner_d(aTHX_
3297                                  packWARN(WARN_EXPERIMENTAL__REFALIASING),
3298                                 "Aliasing via reference is experimental");
3299             }
3300         }
3301         if (o->op_type == OP_REFGEN)
3302             op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
3303         op_null(o);
3304         return o;
3305
3306     case OP_SPLIT:
3307         if ((o->op_private & OPpSPLIT_ASSIGN)) {
3308             /* This is actually @array = split.  */
3309             PL_modcount = RETURN_UNLIMITED_NUMBER;
3310             break;
3311         }
3312         goto nomod;
3313
3314     case OP_SCALAR:
3315         op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
3316         goto nomod;
3317     }
3318
3319     /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
3320        their argument is a filehandle; thus \stat(".") should not set
3321        it. AMS 20011102 */
3322     if (type == OP_REFGEN &&
3323         PL_check[o->op_type] == Perl_ck_ftst)
3324         return o;
3325
3326     if (type != OP_LEAVESUBLV)
3327         o->op_flags |= OPf_MOD;
3328
3329     if (type == OP_AASSIGN || type == OP_SASSIGN)
3330         o->op_flags |= OPf_SPECIAL
3331                       |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF);
3332     else if (!type) { /* local() */
3333         switch (localize) {
3334         case 1:
3335             o->op_private |= OPpLVAL_INTRO;
3336             o->op_flags &= ~OPf_SPECIAL;
3337             PL_hints |= HINT_BLOCK_SCOPE;
3338             break;
3339         case 0:
3340             break;
3341         case -1:
3342             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
3343                            "Useless localization of %s", OP_DESC(o));
3344         }
3345     }
3346     else if (type != OP_GREPSTART && type != OP_ENTERSUB
3347              && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
3348         o->op_flags |= OPf_REF;
3349     return o;
3350 }
3351
3352 STATIC bool
3353 S_scalar_mod_type(const OP *o, I32 type)
3354 {
3355     switch (type) {
3356     case OP_POS:
3357     case OP_SASSIGN:
3358         if (o && o->op_type == OP_RV2GV)
3359             return FALSE;
3360         /* FALLTHROUGH */
3361     case OP_PREINC:
3362     case OP_PREDEC:
3363     case OP_POSTINC:
3364     case OP_POSTDEC:
3365     case OP_I_PREINC:
3366     case OP_I_PREDEC:
3367     case OP_I_POSTINC:
3368     case OP_I_POSTDEC:
3369     case OP_POW:
3370     case OP_MULTIPLY:
3371     case OP_DIVIDE:
3372     case OP_MODULO:
3373     case OP_REPEAT:
3374     case OP_ADD:
3375     case OP_SUBTRACT:
3376     case OP_I_MULTIPLY:
3377     case OP_I_DIVIDE:
3378     case OP_I_MODULO:
3379     case OP_I_ADD:
3380     case OP_I_SUBTRACT:
3381     case OP_LEFT_SHIFT:
3382     case OP_RIGHT_SHIFT:
3383     case OP_BIT_AND:
3384     case OP_BIT_XOR:
3385     case OP_BIT_OR:
3386     case OP_NBIT_AND:
3387     case OP_NBIT_XOR:
3388     case OP_NBIT_OR:
3389     case OP_SBIT_AND:
3390     case OP_SBIT_XOR:
3391     case OP_SBIT_OR:
3392     case OP_CONCAT:
3393     case OP_SUBST:
3394     case OP_TRANS:
3395     case OP_TRANSR:
3396     case OP_READ:
3397     case OP_SYSREAD:
3398     case OP_RECV:
3399     case OP_ANDASSIGN:
3400     case OP_ORASSIGN:
3401     case OP_DORASSIGN:
3402     case OP_VEC:
3403     case OP_SUBSTR:
3404         return TRUE;
3405     default:
3406         return FALSE;
3407     }
3408 }
3409
3410 STATIC bool
3411 S_is_handle_constructor(const OP *o, I32 numargs)
3412 {
3413     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
3414
3415     switch (o->op_type) {
3416     case OP_PIPE_OP:
3417     case OP_SOCKPAIR:
3418         if (numargs == 2)
3419             return TRUE;
3420         /* FALLTHROUGH */
3421     case OP_SYSOPEN:
3422     case OP_OPEN:
3423     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
3424     case OP_SOCKET:
3425     case OP_OPEN_DIR:
3426     case OP_ACCEPT:
3427         if (numargs == 1)
3428             return TRUE;
3429         /* FALLTHROUGH */
3430     default:
3431         return FALSE;
3432     }
3433 }
3434
3435 static OP *
3436 S_refkids(pTHX_ OP *o, I32 type)
3437 {
3438     if (o && o->op_flags & OPf_KIDS) {
3439         OP *kid;
3440         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3441             ref(kid, type);
3442     }
3443     return o;
3444 }
3445
3446 OP *
3447 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
3448 {
3449     dVAR;
3450     OP *kid;
3451
3452     PERL_ARGS_ASSERT_DOREF;
3453
3454     if (PL_parser && PL_parser->error_count)
3455         return o;
3456
3457     switch (o->op_type) {
3458     case OP_ENTERSUB:
3459         if ((type == OP_EXISTS || type == OP_DEFINED) &&
3460             !(o->op_flags & OPf_STACKED)) {
3461             OpTYPE_set(o, OP_RV2CV);             /* entersub => rv2cv */
3462             assert(cUNOPo->op_first->op_type == OP_NULL);
3463             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
3464             o->op_flags |= OPf_SPECIAL;
3465         }
3466         else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
3467             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3468                               : type == OP_RV2HV ? OPpDEREF_HV
3469                               : OPpDEREF_SV);
3470             o->op_flags |= OPf_MOD;
3471         }
3472
3473         break;
3474
3475     case OP_COND_EXPR:
3476         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
3477             doref(kid, type, set_op_ref);
3478         break;
3479     case OP_RV2SV:
3480         if (type == OP_DEFINED)
3481             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
3482         doref(cUNOPo->op_first, o->op_type, set_op_ref);
3483         /* FALLTHROUGH */
3484     case OP_PADSV:
3485         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3486             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3487                               : type == OP_RV2HV ? OPpDEREF_HV
3488                               : OPpDEREF_SV);
3489             o->op_flags |= OPf_MOD;
3490         }
3491         break;
3492
3493     case OP_RV2AV:
3494     case OP_RV2HV:
3495         if (set_op_ref)
3496             o->op_flags |= OPf_REF;
3497         /* FALLTHROUGH */
3498     case OP_RV2GV:
3499         if (type == OP_DEFINED)
3500             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
3501         doref(cUNOPo->op_first, o->op_type, set_op_ref);
3502         break;
3503
3504     case OP_PADAV:
3505     case OP_PADHV:
3506         if (set_op_ref)
3507             o->op_flags |= OPf_REF;
3508         break;
3509
3510     case OP_SCALAR:
3511     case OP_NULL:
3512         if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
3513             break;
3514         doref(cBINOPo->op_first, type, set_op_ref);
3515         break;
3516     case OP_AELEM:
3517     case OP_HELEM:
3518         doref(cBINOPo->op_first, o->op_type, set_op_ref);
3519         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3520             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3521                               : type == OP_RV2HV ? OPpDEREF_HV
3522                               : OPpDEREF_SV);
3523             o->op_flags |= OPf_MOD;
3524         }
3525         break;
3526
3527     case OP_SCOPE:
3528     case OP_LEAVE:
3529         set_op_ref = FALSE;
3530         /* FALLTHROUGH */
3531     case OP_ENTER:
3532     case OP_LIST:
3533         if (!(o->op_flags & OPf_KIDS))
3534             break;
3535         doref(cLISTOPo->op_last, type, set_op_ref);
3536         break;
3537     default:
3538         break;
3539     }
3540     return scalar(o);
3541
3542 }
3543
3544 STATIC OP *
3545 S_dup_attrlist(pTHX_ OP *o)
3546 {
3547     OP *rop;
3548
3549     PERL_ARGS_ASSERT_DUP_ATTRLIST;
3550
3551     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
3552      * where the first kid is OP_PUSHMARK and the remaining ones
3553      * are OP_CONST.  We need to push the OP_CONST values.
3554      */
3555     if (o->op_type == OP_CONST)
3556         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
3557     else {
3558         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
3559         rop = NULL;
3560         for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
3561             if (o->op_type == OP_CONST)
3562                 rop = op_append_elem(OP_LIST, rop,
3563                                   newSVOP(OP_CONST, o->op_flags,
3564                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
3565         }
3566     }
3567     return rop;
3568 }
3569
3570 STATIC void
3571 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
3572 {
3573     PERL_ARGS_ASSERT_APPLY_ATTRS;
3574     {
3575         SV * const stashsv = newSVhek(HvNAME_HEK(stash));
3576
3577         /* fake up C<use attributes $pkg,$rv,@attrs> */
3578
3579 #define ATTRSMODULE "attributes"
3580 #define ATTRSMODULE_PM "attributes.pm"
3581
3582         Perl_load_module(
3583           aTHX_ PERL_LOADMOD_IMPORT_OPS,
3584           newSVpvs(ATTRSMODULE),
3585           NULL,
3586           op_prepend_elem(OP_LIST,
3587                           newSVOP(OP_CONST, 0, stashsv),
3588                           op_prepend_elem(OP_LIST,
3589                                           newSVOP(OP_CONST, 0,
3590                                                   newRV(target)),
3591                                           dup_attrlist(attrs))));
3592     }
3593 }
3594
3595 STATIC void
3596 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
3597 {
3598     OP *pack, *imop, *arg;
3599     SV *meth, *stashsv, **svp;
3600
3601     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
3602
3603     if (!attrs)
3604         return;
3605
3606     assert(target->op_type == OP_PADSV ||
3607            target->op_type == OP_PADHV ||
3608            target->op_type == OP_PADAV);
3609
3610     /* Ensure that attributes.pm is loaded. */
3611     /* Don't force the C<use> if we don't need it. */
3612     svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
3613     if (svp && *svp != &PL_sv_undef)
3614         NOOP;   /* already in %INC */
3615     else
3616         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
3617                                newSVpvs(ATTRSMODULE), NULL);
3618
3619     /* Need package name for method call. */
3620     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
3621
3622     /* Build up the real arg-list. */
3623     stashsv = newSVhek(HvNAME_HEK(stash));
3624
3625     arg = newOP(OP_PADSV, 0);
3626     arg->op_targ = target->op_targ;
3627     arg = op_prepend_elem(OP_LIST,
3628                        newSVOP(OP_CONST, 0, stashsv),
3629                        op_prepend_elem(OP_LIST,
3630                                     newUNOP(OP_REFGEN, 0,
3631                                             arg),
3632                                     dup_attrlist(attrs)));
3633
3634     /* Fake up a method call to import */
3635     meth = newSVpvs_share("import");
3636     imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
3637                    op_append_elem(OP_LIST,
3638                                op_prepend_elem(OP_LIST, pack, arg),
3639                                newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
3640
3641     /* Combine the ops. */
3642     *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
3643 }
3644
3645 /*
3646 =notfor apidoc apply_attrs_string
3647
3648 Attempts to apply a list of attributes specified by the C<attrstr> and
3649 C<len> arguments to the subroutine identified by the C<cv> argument which
3650 is expected to be associated with the package identified by the C<stashpv>
3651 argument (see L<attributes>).  It gets this wrong, though, in that it
3652 does not correctly identify the boundaries of the individual attribute
3653 specifications within C<attrstr>.  This is not really intended for the
3654 public API, but has to be listed here for systems such as AIX which
3655 need an explicit export list for symbols.  (It's called from XS code
3656 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
3657 to respect attribute syntax properly would be welcome.
3658
3659 =cut
3660 */
3661
3662 void
3663 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
3664                         const char *attrstr, STRLEN len)
3665 {
3666     OP *attrs = NULL;
3667
3668     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
3669
3670     if (!len) {
3671         len = strlen(attrstr);
3672     }
3673
3674     while (len) {
3675         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
3676         if (len) {
3677             const char * const sstr = attrstr;
3678             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
3679             attrs = op_append_elem(OP_LIST, attrs,
3680                                 newSVOP(OP_CONST, 0,
3681                                         newSVpvn(sstr, attrstr-sstr)));
3682         }
3683     }
3684
3685     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3686                      newSVpvs(ATTRSMODULE),
3687                      NULL, op_prepend_elem(OP_LIST,
3688                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
3689                                   op_prepend_elem(OP_LIST,
3690                                                newSVOP(OP_CONST, 0,
3691                                                        newRV(MUTABLE_SV(cv))),
3692                                                attrs)));
3693 }
3694
3695 STATIC void
3696 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name,
3697                         bool curstash)
3698 {
3699     OP *new_proto = NULL;
3700     STRLEN pvlen;
3701     char *pv;
3702     OP *o;
3703
3704     PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
3705
3706     if (!*attrs)
3707         return;
3708
3709     o = *attrs;
3710     if (o->op_type == OP_CONST) {
3711         pv = SvPV(cSVOPo_sv, pvlen);
3712         if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3713             SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3714             SV ** const tmpo = cSVOPx_svp(o);
3715             SvREFCNT_dec(cSVOPo_sv);
3716             *tmpo = tmpsv;
3717             new_proto = o;
3718             *attrs = NULL;
3719         }
3720     } else if (o->op_type == OP_LIST) {
3721         OP * lasto;
3722         assert(o->op_flags & OPf_KIDS);
3723         lasto = cLISTOPo->op_first;
3724         assert(lasto->op_type == OP_PUSHMARK);
3725         for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
3726             if (o->op_type == OP_CONST) {
3727                 pv = SvPV(cSVOPo_sv, pvlen);
3728                 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3729                     SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3730                     SV ** const tmpo = cSVOPx_svp(o);
3731                     SvREFCNT_dec(cSVOPo_sv);
3732                     *tmpo = tmpsv;
3733                     if (new_proto && ckWARN(WARN_MISC)) {
3734                         STRLEN new_len;
3735                         const char * newp = SvPV(cSVOPo_sv, new_len);
3736                         Perl_warner(aTHX_ packWARN(WARN_MISC),
3737                             "Attribute prototype(%" UTF8f ") discards earlier prototype attribute in same sub",
3738                             UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
3739                         op_free(new_proto);
3740                     }
3741                     else if (new_proto)
3742                         op_free(new_proto);
3743                     new_proto = o;
3744                     /* excise new_proto from the list */
3745                     op_sibling_splice(*attrs, lasto, 1, NULL);
3746                     o = lasto;
3747                     continue;
3748                 }
3749             }
3750             lasto = o;
3751         }
3752         /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
3753            would get pulled in with no real need */
3754         if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
3755             op_free(*attrs);
3756             *attrs = NULL;
3757         }
3758     }
3759
3760     if (new_proto) {
3761         SV *svname;
3762         if (isGV(name)) {
3763             svname = sv_newmortal();
3764             gv_efullname3(svname, name, NULL);
3765         }
3766         else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
3767             svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
3768         else
3769             svname = (SV *)name;
3770         if (ckWARN(WARN_ILLEGALPROTO))
3771             (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE,
3772                                  curstash);
3773         if (*proto && ckWARN(WARN_PROTOTYPE)) {
3774             STRLEN old_len, new_len;
3775             const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
3776             const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
3777
3778             if (curstash && svname == (SV *)name
3779              && !memchr(SvPVX(svname), ':', SvCUR(svname))) {
3780                 svname = sv_2mortal(newSVsv(PL_curstname));
3781                 sv_catpvs(svname, "::");
3782                 sv_catsv(svname, (SV *)name);
3783             }
3784
3785             Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3786                 "Prototype '%" UTF8f "' overridden by attribute 'prototype(%" UTF8f ")'"
3787                 " in %" SVf,
3788                 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
3789                 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
3790                 SVfARG(svname));
3791         }
3792         if (*proto)
3793             op_free(*proto);
3794         *proto = new_proto;
3795     }
3796 }
3797
3798 static void
3799 S_cant_declare(pTHX_ OP *o)
3800 {
3801     if (o->op_type == OP_NULL
3802      && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
3803         o = cUNOPo->op_first;
3804     yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
3805                              o->op_type == OP_NULL
3806                                && o->op_flags & OPf_SPECIAL
3807                                  ? "do block"
3808                                  : OP_DESC(o),
3809                              PL_parser->in_my == KEY_our   ? "our"   :
3810                              PL_parser->in_my == KEY_state ? "state" :
3811                                                              "my"));
3812 }
3813
3814 STATIC OP *
3815 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
3816 {
3817     I32 type;
3818     const bool stately = PL_parser && PL_parser->in_my == KEY_state;
3819
3820     PERL_ARGS_ASSERT_MY_KID;
3821
3822     if (!o || (PL_parser && PL_parser->error_count))
3823         return o;
3824
3825     type = o->op_type;
3826
3827     if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
3828         OP *kid;
3829         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3830             my_kid(kid, attrs, imopsp);
3831         return o;
3832     } else if (type == OP_UNDEF || type == OP_STUB) {
3833         return o;
3834     } else if (type == OP_RV2SV ||      /* "our" declaration */
3835                type == OP_RV2AV ||
3836                type == OP_RV2HV) {
3837         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
3838             S_cant_declare(aTHX_ o);
3839         } else if (attrs) {
3840             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
3841             assert(PL_parser);
3842             PL_parser->in_my = FALSE;
3843             PL_parser->in_my_stash = NULL;
3844             apply_attrs(GvSTASH(gv),
3845                         (type == OP_RV2SV ? GvSVn(gv) :
3846                          type == OP_RV2AV ? MUTABLE_SV(GvAVn(gv)) :
3847                          type == OP_RV2HV ? MUTABLE_SV(GvHVn(gv)) : MUTABLE_SV(gv)),
3848                         attrs);
3849         }
3850         o->op_private |= OPpOUR_INTRO;
3851         return o;
3852     }
3853     else if (type == OP_REFGEN || type == OP_SREFGEN) {
3854         if (!FEATURE_MYREF_IS_ENABLED)
3855             Perl_croak(aTHX_ "The experimental declared_refs "
3856                              "feature is not enabled");
3857         Perl_ck_warner_d(aTHX_
3858              packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
3859             "Declaring references is experimental");
3860         /* Kid is a nulled OP_LIST, handled above.  */
3861         my_kid(cUNOPo->op_first, attrs, imopsp);
3862         return o;
3863     }
3864     else if (type != OP_PADSV &&
3865              type != OP_PADAV &&
3866              type != OP_PADHV &&
3867              type != OP_PUSHMARK)
3868     {
3869         S_cant_declare(aTHX_ o);
3870         return o;
3871     }
3872     else if (attrs && type != OP_PUSHMARK) {
3873         HV *stash;
3874
3875         assert(PL_parser);
3876         PL_parser->in_my = FALSE;
3877         PL_parser->in_my_stash = NULL;
3878
3879         /* check for C<my Dog $spot> when deciding package */
3880         stash = PAD_COMPNAME_TYPE(o->op_targ);
3881         if (!stash)
3882             stash = PL_curstash;
3883         apply_attrs_my(stash, o, attrs, imopsp);
3884     }
3885     o->op_flags |= OPf_MOD;
3886     o->op_private |= OPpLVAL_INTRO;
3887     if (stately)
3888         o->op_private |= OPpPAD_STATE;
3889     return o;
3890 }
3891
3892 OP *
3893 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
3894 {
3895     OP *rops;
3896     int maybe_scalar = 0;
3897
3898     PERL_ARGS_ASSERT_MY_ATTRS;
3899
3900 /* [perl #17376]: this appears to be premature, and results in code such as
3901    C< our(%x); > executing in list mode rather than void mode */
3902 #if 0
3903     if (o->op_flags & OPf_PARENS)
3904         list(o);
3905     else
3906         maybe_scalar = 1;
3907 #else
3908     maybe_scalar = 1;
3909 #endif
3910     if (attrs)
3911         SAVEFREEOP(attrs);
3912     rops = NULL;
3913     o = my_kid(o, attrs, &rops);
3914     if (rops) {
3915         if (maybe_scalar && o->op_type == OP_PADSV) {
3916             o = scalar(op_append_list(OP_LIST, rops, o));
3917             o->op_private |= OPpLVAL_INTRO;
3918         }
3919         else {
3920             /* The listop in rops might have a pushmark at the beginning,
3921                which will mess up list assignment. */
3922             LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
3923             if (rops->op_type == OP_LIST &&
3924                 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
3925             {
3926                 OP * const pushmark = lrops->op_first;
3927                 /* excise pushmark */
3928                 op_sibling_splice(rops, NULL, 1, NULL);
3929                 op_free(pushmark);
3930             }
3931             o = op_append_list(OP_LIST, o, rops);
3932         }
3933     }
3934     PL_parser->in_my = FALSE;
3935     PL_parser->in_my_stash = NULL;
3936     return o;
3937 }
3938
3939 OP *
3940 Perl_sawparens(pTHX_ OP *o)
3941 {
3942     PERL_UNUSED_CONTEXT;
3943     if (o)
3944         o->op_flags |= OPf_PARENS;
3945     return o;
3946 }
3947
3948 OP *
3949 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
3950 {
3951     OP *o;
3952     bool ismatchop = 0;
3953     const OPCODE ltype = left->op_type;
3954     const OPCODE rtype = right->op_type;
3955
3956     PERL_ARGS_ASSERT_BIND_MATCH;
3957
3958     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
3959           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
3960     {
3961       const char * const desc
3962           = PL_op_desc[(
3963                           rtype == OP_SUBST || rtype == OP_TRANS
3964                        || rtype == OP_TRANSR
3965                        )
3966                        ? (int)rtype : OP_MATCH];
3967       const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
3968       SV * const name =
3969         S_op_varname(aTHX_ left);
3970       if (name)
3971         Perl_warner(aTHX_ packWARN(WARN_MISC),
3972              "Applying %s to %" SVf " will act on scalar(%" SVf ")",
3973              desc, SVfARG(name), SVfARG(name));
3974       else {
3975         const char * const sample = (isary
3976              ? "@array" : "%hash");
3977         Perl_warner(aTHX_ packWARN(WARN_MISC),
3978              "Applying %s to %s will act on scalar(%s)",
3979              desc, sample, sample);
3980       }
3981     }
3982
3983     if (rtype == OP_CONST &&
3984         cSVOPx(right)->op_private & OPpCONST_BARE &&
3985         cSVOPx(right)->op_private & OPpCONST_STRICT)
3986     {
3987         no_bareword_allowed(right);
3988     }
3989
3990     /* !~ doesn't make sense with /r, so error on it for now */
3991     if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
3992         type == OP_NOT)
3993         /* diag_listed_as: Using !~ with %s doesn't make sense */
3994         yyerror("Using !~ with s///r doesn't make sense");
3995     if (rtype == OP_TRANSR && type == OP_NOT)
3996         /* diag_listed_as: Using !~ with %s doesn't make sense */
3997         yyerror("Using !~ with tr///r doesn't make sense");
3998
3999     ismatchop = (rtype == OP_MATCH ||
4000                  rtype == OP_SUBST ||
4001                  rtype == OP_TRANS || rtype == OP_TRANSR)
4002              && !(right->op_flags & OPf_SPECIAL);
4003     if (ismatchop && right->op_private & OPpTARGET_MY) {
4004         right->op_targ = 0;
4005         right->op_private &= ~OPpTARGET_MY;
4006     }
4007     if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
4008         if (left->op_type == OP_PADSV
4009          && !(left->op_private & OPpLVAL_INTRO))
4010         {
4011             right->op_targ = left->op_targ;
4012             op_free(left);
4013             o = right;
4014         }
4015         else {
4016             right->op_flags |= OPf_STACKED;
4017             if (rtype != OP_MATCH && rtype != OP_TRANSR &&
4018             ! (rtype == OP_TRANS &&
4019                right->op_private & OPpTRANS_IDENTICAL) &&
4020             ! (rtype == OP_SUBST &&
4021                (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
4022                 left = op_lvalue(left, rtype);
4023             if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
4024                 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
4025             else
4026                 o = op_prepend_elem(rtype, scalar(left), right);
4027         }
4028         if (type == OP_NOT)
4029             return newUNOP(OP_NOT, 0, scalar(o));
4030         return o;
4031     }
4032     else
4033         return bind_match(type, left,
4034                 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
4035 }
4036
4037 OP *
4038 Perl_invert(pTHX_ OP *o)
4039 {
4040     if (!o)
4041         return NULL;
4042     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
4043 }
4044
4045 /*
4046 =for apidoc Amx|OP *|op_scope|OP *o
4047
4048 Wraps up an op tree with some additional ops so that at runtime a dynamic
4049 scope will be created.  The original ops run in the new dynamic scope,
4050 and then, provided that they exit normally, the scope will be unwound.
4051 The additional ops used to create and unwind the dynamic scope will
4052 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
4053 instead if the ops are simple enough to not need the full dynamic scope
4054 structure.
4055
4056 =cut
4057 */
4058
4059 OP *
4060 Perl_op_scope(pTHX_ OP *o)
4061 {
4062     dVAR;
4063     if (o) {
4064         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
4065             o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
4066             OpTYPE_set(o, OP_LEAVE);
4067         }
4068         else if (o->op_type == OP_LINESEQ) {
4069             OP *kid;
4070             OpTYPE_set(o, OP_SCOPE);
4071             kid = ((LISTOP*)o)->op_first;
4072             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
4073                 op_null(kid);
4074
4075                 /* The following deals with things like 'do {1 for 1}' */
4076                 kid = OpSIBLING(kid);
4077                 if (kid &&
4078                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
4079                     op_null(kid);
4080             }
4081         }
4082         else
4083             o = newLISTOP(OP_SCOPE, 0, o, NULL);
4084     }
4085     return o;
4086 }
4087
4088 OP *
4089 Perl_op_unscope(pTHX_ OP *o)
4090 {
4091     if (o && o->op_type == OP_LINESEQ) {
4092         OP *kid = cLISTOPo->op_first;
4093         for(; kid; kid = OpSIBLING(kid))
4094             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
4095                 op_null(kid);
4096     }
4097     return o;
4098 }
4099
4100 /*
4101 =for apidoc Am|int|block_start|int full
4102
4103 Handles compile-time scope entry.
4104 Arranges for hints to be restored on block
4105 exit and also handles pad sequence numbers to make lexical variables scope
4106 right.  Returns a savestack index for use with C<block_end>.
4107
4108 =cut
4109 */
4110
4111 int
4112 Perl_block_start(pTHX_ int full)
4113 {
4114     const int retval = PL_savestack_ix;
4115
4116     PL_compiling.cop_seq = PL_cop_seqmax;
4117     COP_SEQMAX_INC;
4118     pad_block_start(full);
4119     SAVEHINTS();
4120     PL_hints &= ~HINT_BLOCK_SCOPE;
4121     SAVECOMPILEWARNINGS();
4122     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
4123     SAVEI32(PL_compiling.cop_seq);
4124     PL_compiling.cop_seq = 0;
4125
4126     CALL_BLOCK_HOOKS(bhk_start, full);
4127
4128     return retval;
4129 }
4130
4131 /*
4132 =for apidoc Am|OP *|block_end|I32 floor|OP *seq
4133
4134 Handles compile-time scope exit.  C<floor>
4135 is the savestack index returned by
4136 C<block_start>, and C<seq> is the body of the block.  Returns the block,
4137 possibly modified.
4138
4139 =cut
4140 */
4141
4142 OP*
4143 Perl_block_end(pTHX_ I32 floor, OP *seq)
4144 {
4145     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
4146     OP* retval = scalarseq(seq);
4147     OP *o;
4148
4149     /* XXX Is the null PL_parser check necessary here? */
4150     assert(PL_parser); /* Let’s find out under debugging builds.  */
4151     if (PL_parser && PL_parser->parsed_sub) {
4152         o = newSTATEOP(0, NULL, NULL);
4153         op_null(o);
4154         retval = op_append_elem(OP_LINESEQ, retval, o);
4155     }
4156
4157     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
4158
4159     LEAVE_SCOPE(floor);
4160     if (needblockscope)
4161         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
4162     o = pad_leavemy();
4163
4164     if (o) {
4165         /* pad_leavemy has created a sequence of introcv ops for all my
4166            subs declared in the block.  We have to replicate that list with
4167            clonecv ops, to deal with this situation:
4168
4169                sub {
4170                    my sub s1;
4171                    my sub s2;
4172                    sub s1 { state sub foo { \&s2 } }
4173                }->()
4174
4175            Originally, I was going to have introcv clone the CV and turn
4176            off the stale flag.  Since &s1 is declared before &s2, the
4177            introcv op for &s1 is executed (on sub entry) before the one for
4178            &s2.  But the &foo sub inside &s1 (which is cloned when &s1 is
4179            cloned, since it is a state sub) closes over &s2 and expects
4180            to see it in its outer CV’s pad.  If the introcv op clones &s1,
4181            then &s2 is still marked stale.  Since &s1 is not active, and
4182            &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
4183            ble will not stay shared’ warning.  Because it is the same stub
4184            that will be used when the introcv op for &s2 is executed, clos-
4185            ing over it is safe.  Hence, we have to turn off the stale flag
4186            on all lexical subs in the block before we clone any of them.
4187            Hence, having introcv clone the sub cannot work.  So we create a
4188            list of ops like this:
4189
4190                lineseq
4191                   |
4192                   +-- introcv
4193                   |
4194                   +-- introcv
4195                   |
4196                   +-- introcv
4197                   |
4198                   .
4199                   .
4200                   .
4201                   |
4202                   +-- clonecv
4203                   |
4204                   +-- clonecv
4205                   |
4206                   +-- clonecv
4207                   |
4208                   .
4209                   .
4210                   .
4211          */
4212         OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
4213         OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
4214         for (;; kid = OpSIBLING(kid)) {
4215             OP *newkid = newOP(OP_CLONECV, 0);
4216             newkid->op_targ = kid->op_targ;
4217             o = op_append_elem(OP_LINESEQ, o, newkid);
4218             if (kid == last) break;
4219         }
4220         retval = op_prepend_elem(OP_LINESEQ, o, retval);
4221     }
4222
4223     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
4224
4225     return retval;
4226 }
4227
4228 /*
4229 =head1 Compile-time scope hooks
4230
4231 =for apidoc Aox||blockhook_register
4232
4233 Register a set of hooks to be called when the Perl lexical scope changes
4234 at compile time.  See L<perlguts/"Compile-time scope hooks">.
4235
4236 =cut
4237 */
4238
4239 void
4240 Perl_blockhook_register(pTHX_ BHK *hk)
4241 {
4242     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
4243
4244     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
4245 }
4246
4247 void
4248 Perl_newPROG(pTHX_ OP *o)
4249 {
4250     OP *start;
4251
4252     PERL_ARGS_ASSERT_NEWPROG;
4253
4254     if (PL_in_eval) {
4255         PERL_CONTEXT *cx;
4256         I32 i;
4257         if (PL_eval_root)
4258                 return;
4259         PL_eval_root = newUNOP(OP_LEAVEEVAL,
4260                                ((PL_in_eval & EVAL_KEEPERR)
4261                                 ? OPf_SPECIAL : 0), o);
4262
4263         cx = CX_CUR();
4264         assert(CxTYPE(cx) == CXt_EVAL);
4265
4266         if ((cx->blk_gimme & G_WANT) == G_VOID)
4267             scalarvoid(PL_eval_root);
4268         else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
4269             list(PL_eval_root);
4270         else
4271             scalar(PL_eval_root);
4272
4273         start = op_linklist(PL_eval_root);
4274         PL_eval_root->op_next = 0;
4275         i = PL_savestack_ix;
4276         SAVEFREEOP(o);
4277         ENTER;
4278         S_process_optree(aTHX_ NULL, PL_eval_root, start);
4279         LEAVE;
4280         PL_savestack_ix = i;
4281     }
4282     else {
4283         if (o->op_type == OP_STUB) {
4284             /* This block is entered if nothing is compiled for the main
4285                program. This will be the case for an genuinely empty main
4286                program, or one which only has BEGIN blocks etc, so already
4287                run and freed.
4288
4289                Historically (5.000) the guard above was !o. However, commit
4290                f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
4291                c71fccf11fde0068, changed perly.y so that newPROG() is now
4292                called with the output of block_end(), which returns a new
4293                OP_STUB for the case of an empty optree. ByteLoader (and
4294                maybe other things) also take this path, because they set up
4295                PL_main_start and PL_main_root directly, without generating an
4296                optree.
4297
4298                If the parsing the main program aborts (due to parse errors,
4299                or due to BEGIN or similar calling exit), then newPROG()
4300                isn't even called, and hence this code path and its cleanups
4301                are skipped. This shouldn't make a make a difference:
4302                * a non-zero return from perl_parse is a failure, and
4303                  perl_destruct() should be called immediately.
4304                * however, if exit(0) is called during the parse, then
4305                  perl_parse() returns 0, and perl_run() is called. As
4306                  PL_main_start will be NULL, perl_run() will return
4307                  promptly, and the exit code will remain 0.
4308             */
4309
4310             PL_comppad_name = 0;
4311             PL_compcv = 0;
4312             S_op_destroy(aTHX_ o);
4313             return;
4314         }
4315         PL_main_root = op_scope(sawparens(scalarvoid(o)));
4316         PL_curcop = &PL_compiling;
4317         start = LINKLIST(PL_main_root);
4318         PL_main_root->op_next = 0;
4319         S_process_optree(aTHX_ NULL, PL_main_root, start);
4320         cv_forget_slab(PL_compcv);
4321         PL_compcv = 0;
4322
4323         /* Register with debugger */
4324         if (PERLDB_INTER) {
4325             CV * const cv = get_cvs("DB::postponed", 0);
4326             if (cv) {
4327                 dSP;
4328                 PUSHMARK(SP);
4329                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
4330                 PUTBACK;
4331                 call_sv(MUTABLE_SV(cv), G_DISCARD);
4332             }
4333         }
4334     }
4335 }
4336
4337 OP *
4338 Perl_localize(pTHX_ OP *o, I32 lex)
4339 {
4340     PERL_ARGS_ASSERT_LOCALIZE;
4341
4342     if (o->op_flags & OPf_PARENS)
4343 /* [perl #17376]: this appears to be premature, and results in code such as
4344    C< our(%x); > executing in list mode rather than void mode */
4345 #if 0
4346         list(o);
4347 #else
4348         NOOP;
4349 #endif
4350     else {
4351         if ( PL_parser->bufptr > PL_parser->oldbufptr
4352             && PL_parser->bufptr[-1] == ','
4353             && ckWARN(WARN_PARENTHESIS))
4354         {
4355             char *s = PL_parser->bufptr;
4356             bool sigil = FALSE;
4357
4358             /* some heuristics to detect a potential error */
4359             while (*s && (strchr(", \t\n", *s)))
4360                 s++;
4361
4362             while (1) {
4363                 if (*s && (strchr("@$%", *s) || (!lex && *s == '*'))
4364                        && *++s
4365                        && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
4366                     s++;
4367                     sigil = TRUE;
4368                     while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
4369                         s++;
4370                     while (*s && (strchr(", \t\n", *s)))
4371                         s++;
4372                 }
4373                 else
4374                     break;
4375             }
4376             if (sigil && (*s == ';' || *s == '=')) {
4377                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
4378                                 "Parentheses missing around \"%s\" list",
4379                                 lex
4380                                     ? (PL_parser->in_my == KEY_our
4381                                         ? "our"
4382                                         : PL_parser->in_my == KEY_state
4383                                             ? "state"
4384                                             : "my")
4385                                     : "local");
4386             }
4387         }
4388     }
4389     if (lex)
4390         o = my(o);
4391     else
4392         o = op_lvalue(o, OP_NULL);              /* a bit kludgey */
4393     PL_parser->in_my = FALSE;
4394     PL_parser->in_my_stash = NULL;
4395     return o;
4396 }
4397
4398 OP *
4399 Perl_jmaybe(pTHX_ OP *o)
4400 {
4401     PERL_ARGS_ASSERT_JMAYBE;
4402
4403     if (o->op_type == OP_LIST) {
4404         OP * const o2
4405             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
4406         o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
4407     }
4408     return o;
4409 }
4410
4411 PERL_STATIC_INLINE OP *
4412 S_op_std_init(pTHX_ OP *o)
4413 {
4414     I32 type = o->op_type;
4415
4416     PERL_ARGS_ASSERT_OP_STD_INIT;
4417
4418     if (PL_opargs[type] & OA_RETSCALAR)
4419         scalar(o);
4420     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
4421         o->op_targ = pad_alloc(type, SVs_PADTMP);
4422
4423     return o;
4424 }
4425
4426 PERL_STATIC_INLINE OP *
4427 S_op_integerize(pTHX_ OP *o)
4428 {
4429     I32 type = o->op_type;
4430
4431     PERL_ARGS_ASSERT_OP_INTEGERIZE;
4432
4433     /* integerize op. */
4434     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
4435     {
4436         dVAR;
4437         o->op_ppaddr = PL_ppaddr[++(o->op_type)];
4438     }
4439
4440     if (type == OP_NEGATE)
4441         /* XXX might want a ck_negate() for this */
4442         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
4443
4444     return o;
4445 }
4446
4447 static OP *
4448 S_fold_constants(pTHX_ OP *const o)
4449 {
4450     dVAR;
4451     OP * volatile curop;
4452     OP *newop;
4453     volatile I32 type = o->op_type;
4454     bool is_stringify;
4455     SV * volatile sv = NULL;
4456     int ret = 0;
4457     OP *old_next;
4458     SV * const oldwarnhook = PL_warnhook;
4459     SV * const olddiehook  = PL_diehook;
4460     COP not_compiling;
4461     U8 oldwarn = PL_dowarn;
4462     I32 old_cxix;
4463     dJMPENV;
4464
4465     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
4466
4467     if (!(PL_opargs[type] & OA_FOLDCONST))
4468         goto nope;
4469
4470     switch (type) {
4471     case OP_UCFIRST:
4472     case OP_LCFIRST:
4473     case OP_UC:
4474     case OP_LC:
4475     case OP_FC:
4476 #ifdef USE_LOCALE_CTYPE
4477         if (IN_LC_COMPILETIME(LC_CTYPE))
4478             goto nope;
4479 #endif
4480         break;
4481     case OP_SLT:
4482     case OP_SGT:
4483     case OP_SLE:
4484     case OP_SGE:
4485     case OP_SCMP:
4486 #ifdef USE_LOCALE_COLLATE
4487         if (IN_LC_COMPILETIME(LC_COLLATE))
4488             goto nope;
4489 #endif
4490         break;
4491     case OP_SPRINTF:
4492         /* XXX what about the numeric ops? */
4493 #ifdef USE_LOCALE_NUMERIC
4494         if (IN_LC_COMPILETIME(LC_NUMERIC))
4495             goto nope;
4496 #endif
4497         break;
4498     case OP_PACK:
4499         if (!OpHAS_SIBLING(cLISTOPo->op_first)
4500           || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
4501             goto nope;
4502         {
4503             SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
4504             if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
4505             {
4506                 const char *s = SvPVX_const(sv);
4507                 while (s < SvEND(sv)) {
4508                     if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
4509                     s++;
4510                 }
4511             }
4512         }
4513         break;
4514     case OP_REPEAT:
4515         if (o->op_private & OPpREPEAT_DOLIST) goto nope;
4516         break;
4517     case OP_SREFGEN:
4518         if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
4519          || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
4520             goto nope;
4521     }
4522
4523     if (PL_parser && PL_parser->error_count)
4524         goto nope;              /* Don't try to run w/ errors */
4525
4526     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4527         switch (curop->op_type) {
4528         case OP_CONST:
4529             if (   (curop->op_private & OPpCONST_BARE)
4530                 && (curop->op_private & OPpCONST_STRICT)) {
4531                 no_bareword_allowed(curop);
4532                 goto nope;
4533             }
4534             /* FALLTHROUGH */
4535         case OP_LIST:
4536         case OP_SCALAR:
4537         case OP_NULL:
4538         case OP_PUSHMARK:
4539             /* Foldable; move to next op in list */
4540             break;
4541
4542         default:
4543             /* No other op types are considered foldable */
4544             goto nope;
4545         }
4546     }
4547
4548     curop = LINKLIST(o);
4549     old_next = o->op_next;
4550     o->op_next = 0;
4551     PL_op = curop;
4552
4553     old_cxix = cxstack_ix;
4554     create_eval_scope(NULL, G_FAKINGEVAL);
4555
4556     /* Verify that we don't need to save it:  */
4557     assert(PL_curcop == &PL_compiling);
4558     StructCopy(&PL_compiling, &not_compiling, COP);
4559     PL_curcop = &not_compiling;
4560     /* The above ensures that we run with all the correct hints of the
4561        currently compiling COP, but that IN_PERL_RUNTIME is true. */
4562     assert(IN_PERL_RUNTIME);
4563     PL_warnhook = PERL_WARNHOOK_FATAL;
4564     PL_diehook  = NULL;
4565     JMPENV_PUSH(ret);
4566
4567     /* Effective $^W=1.  */
4568     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
4569         PL_dowarn |= G_WARN_ON;
4570
4571     switch (ret) {
4572     case 0:
4573         CALLRUNOPS(aTHX);
4574         sv = *(PL_stack_sp--);
4575         if (o->op_targ && sv == PAD_SV(o->op_targ)) {   /* grab pad temp? */
4576             pad_swipe(o->op_targ,  FALSE);
4577         }
4578         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
4579             SvREFCNT_inc_simple_void(sv);
4580             SvTEMP_off(sv);
4581         }
4582         else { assert(SvIMMORTAL(sv)); }
4583         break;
4584     case 3:
4585         /* Something tried to die.  Abandon constant folding.  */
4586         /* Pretend the error never happened.  */
4587         CLEAR_ERRSV();
4588         o->op_next = old_next;
4589         break;
4590     default:
4591         JMPENV_POP;
4592         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
4593         PL_warnhook = oldwarnhook;
4594         PL_diehook  = olddiehook;
4595         /* XXX note that this croak may fail as we've already blown away
4596          * the stack - eg any nested evals */
4597         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
4598     }
4599     JMPENV_POP;
4600     PL_dowarn   = oldwarn;
4601     PL_warnhook = oldwarnhook;
4602     PL_diehook  = olddiehook;
4603     PL_curcop = &PL_compiling;
4604
4605     /* if we croaked, depending on how we croaked the eval scope
4606      * may or may not have already been popped */
4607     if (cxstack_ix > old_cxix) {
4608         assert(cxstack_ix == old_cxix + 1);
4609         assert(CxTYPE(CX_CUR()) == CXt_EVAL);
4610         delete_eval_scope();
4611     }
4612     if (ret)
4613         goto nope;
4614
4615     /* OP_STRINGIFY and constant folding are used to implement qq.
4616        Here the constant folding is an implementation detail that we
4617        want to hide.  If the stringify op is itself already marked
4618        folded, however, then it is actually a folded join.  */
4619     is_stringify = type == OP_STRINGIFY && !o->op_folded;
4620     op_free(o);
4621     assert(sv);
4622     if (is_stringify)
4623         SvPADTMP_off(sv);
4624     else if (!SvIMMORTAL(sv)) {
4625         SvPADTMP_on(sv);
4626         SvREADONLY_on(sv);
4627     }
4628     newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
4629     if (!is_stringify) newop->op_folded = 1;
4630     return newop;
4631
4632  nope:
4633     return o;
4634 }
4635
4636 static OP *
4637 S_gen_constant_list(pTHX_ OP *o)
4638 {
4639     dVAR;
4640     OP *curop, *old_next;
4641     SV * const oldwarnhook = PL_warnhook;
4642     SV * const olddiehook  = PL_diehook;
4643     COP *old_curcop;
4644     U8 oldwarn = PL_dowarn;
4645     SV **svp;
4646     AV *av;
4647     I32 old_cxix;
4648     COP not_compiling;
4649     int ret = 0;
4650     dJMPENV;
4651     bool op_was_null;
4652
4653     list(o);
4654     if (PL_parser && PL_parser->error_count)
4655         return o;               /* Don't attempt to run with errors */
4656
4657     curop = LINKLIST(o);
4658     old_next = o->op_next;
4659     o->op_next = 0;
4660     op_was_null = o->op_type == OP_NULL;
4661     if (op_was_null) /* b3698342565fb462291fba4b432cfcd05b6eb4e1 */
4662         o->op_type = OP_CUSTOM;
4663     CALL_PEEP(curop);
4664     if (op_was_null)
4665         o->op_type = OP_NULL;
4666     S_prune_chain_head(&curop);
4667     PL_op = curop;
4668
4669     old_cxix = cxstack_ix;
4670     create_eval_scope(NULL, G_FAKINGEVAL);
4671
4672     old_curcop = PL_curcop;
4673     StructCopy(old_curcop, &not_compiling, COP);
4674     PL_curcop = &not_compiling;
4675     /* The above ensures that we run with all the correct hints of the
4676        current COP, but that IN_PERL_RUNTIME is true. */
4677     assert(IN_PERL_RUNTIME);
4678     PL_warnhook = PERL_WARNHOOK_FATAL;
4679     PL_diehook  = NULL;
4680     JMPENV_PUSH(ret);
4681
4682     /* Effective $^W=1.  */
4683     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
4684         PL_dowarn |= G_WARN_ON;
4685
4686     switch (ret) {
4687     case 0:
4688 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
4689         PL_curstackinfo->si_stack_hwm = 0; /* stop valgrind complaining */
4690 #endif
4691         Perl_pp_pushmark(aTHX);
4692         CALLRUNOPS(aTHX);
4693         PL_op = curop;
4694         assert (!(curop->op_flags & OPf_SPECIAL));
4695         assert(curop->op_type == OP_RANGE);
4696         Perl_pp_anonlist(aTHX);
4697         break;
4698     case 3:
4699         CLEAR_ERRSV();
4700         o->op_next = old_next;
4701         break;
4702     default:
4703         JMPENV_POP;
4704         PL_warnhook = oldwarnhook;
4705         PL_diehook = olddiehook;
4706         Perl_croak(aTHX_ "panic: gen_constant_list JMPENV_PUSH returned %d",
4707             ret);
4708     }
4709
4710     JMPENV_POP;
4711     PL_dowarn = oldwarn;
4712     PL_warnhook = oldwarnhook;
4713     PL_diehook = olddiehook;
4714     PL_curcop = old_curcop;
4715
4716     if (cxstack_ix > old_cxix) {
4717         assert(cxstack_ix == old_cxix + 1);
4718         assert(CxTYPE(CX_CUR()) == CXt_EVAL);
4719         delete_eval_scope();
4720     }
4721     if (ret)
4722         return o;
4723
4724     OpTYPE_set(o, OP_RV2AV);
4725     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
4726     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
4727     o->op_opt = 0;              /* needs to be revisited in rpeep() */
4728     av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
4729
4730     /* replace subtree with an OP_CONST */
4731     curop = ((UNOP*)o)->op_first;
4732     op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
4733     op_free(curop);
4734
4735     if (AvFILLp(av) != -1)
4736         for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
4737         {
4738             SvPADTMP_on(*svp);
4739             SvREADONLY_on(*svp);
4740         }
4741     LINKLIST(o);
4742     return list(o);
4743 }
4744
4745 /*
4746 =head1 Optree Manipulation Functions
4747 */
4748
4749 /* List constructors */
4750
4751 /*
4752 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
4753
4754 Append an item to the list of ops contained directly within a list-type
4755 op, returning the lengthened list.  C<first> is the list-type op,
4756 and C<last> is the op to append to the list.  C<optype> specifies the
4757 intended opcode for the list.  If C<first> is not already a list of the
4758 right type, it will be upgraded into one.  If either C<first> or C<last>
4759 is null, the other is returned unchanged.
4760
4761 =cut
4762 */
4763
4764 OP *
4765 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
4766 {
4767     if (!first)
4768         return last;
4769
4770     if (!last)
4771         return first;
4772
4773     if (first->op_type != (unsigned)type
4774         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
4775     {
4776         return newLISTOP(type, 0, first, last);
4777     }
4778
4779     op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
4780     first->op_flags |= OPf_KIDS;
4781     return first;
4782 }
4783
4784 /*
4785 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
4786
4787 Concatenate the lists of ops contained directly within two list-type ops,
4788 returning the combined list.  C<first> and C<last> are the list-type ops
4789 to concatenate.  C<optype> specifies the intended opcode for the list.
4790 If either C<first> or C<last> is not already a list of the right type,
4791 it will be upgraded into one.  If either C<first> or C<last> is null,
4792 the other is returned unchanged.
4793
4794 =cut
4795 */
4796
4797 OP *
4798 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
4799 {
4800     if (!first)
4801         return last;
4802
4803     if (!last)
4804         return first;
4805
4806     if (first->op_type != (unsigned)type)
4807         return op_prepend_elem(type, first, last);
4808
4809     if (last->op_type != (unsigned)type)
4810         return op_append_elem(type, first, last);
4811
4812     OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
4813     ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
4814     OpLASTSIB_set(((LISTOP*)first)->op_last, first);
4815     first->op_flags |= (last->op_flags & OPf_KIDS);
4816
4817     S_op_destroy(aTHX_ last);
4818
4819     return first;
4820 }
4821
4822 /*
4823 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
4824
4825 Prepend an item to the list of ops contained directly within a list-type
4826 op, returning the lengthened list.  C<first> is the op to prepend to the
4827 list, and C<last> is the list-type op.  C<optype> specifies the intended
4828 opcode for the list.  If C<last> is not already a list of the right type,
4829 it will be upgraded into one.  If either C<first> or C<last> is null,
4830 the other is returned unchanged.
4831
4832 =cut
4833 */
4834
4835 OP *
4836 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
4837 {
4838     if (!first)
4839         return last;
4840
4841     if (!last)
4842         return first;
4843
4844     if (last->op_type == (unsigned)type) {
4845         if (type == OP_LIST) {  /* already a PUSHMARK there */
4846             /* insert 'first' after pushmark */
4847             op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
4848             if (!(first->op_flags & OPf_PARENS))
4849                 last->op_flags &= ~OPf_PARENS;
4850         }
4851         else
4852             op_sibling_splice(last, NULL, 0, first);
4853         last->op_flags |= OPf_KIDS;
4854         return last;
4855     }
4856
4857     return newLISTOP(type, 0, first, last);
4858 }
4859
4860 /*
4861 =for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
4862
4863 Converts C<o> into a list op if it is not one already, and then converts it
4864 into the specified C<type>, calling its check function, allocating a target if
4865 it needs one, and folding constants.
4866
4867 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
4868 C<op_prepend_elem> and C<op_append_elem>.  Then finally it is passed to
4869 C<op_convert_list> to make it the right type.
4870
4871 =cut
4872 */
4873
4874 OP *
4875 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
4876 {
4877     dVAR;
4878     if (type < 0) type = -type, flags |= OPf_SPECIAL;
4879     if (!o || o->op_type != OP_LIST)
4880         o = force_list(o, 0);
4881     else
4882     {
4883         o->op_flags &= ~OPf_WANT;
4884         o->op_private &= ~OPpLVAL_INTRO;
4885     }
4886
4887     if (!(PL_opargs[type] & OA_MARK))
4888         op_null(cLISTOPo->op_first);
4889     else {
4890         OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
4891         if (kid2 && kid2->op_type == OP_COREARGS) {
4892             op_null(cLISTOPo->op_first);
4893             kid2->op_private |= OPpCOREARGS_PUSHMARK;
4894         }
4895     }
4896
4897     if (type != OP_SPLIT)
4898         /* At this point o is a LISTOP, but OP_SPLIT is a PMOP; let
4899          * ck_split() create a real PMOP and leave the op's type as listop
4900          * for now. Otherwise op_free() etc will crash.
4901          */
4902         OpTYPE_set(o, type);
4903
4904     o->op_flags |= flags;
4905     if (flags & OPf_FOLDED)
4906         o->op_folded = 1;
4907
4908     o = CHECKOP(type, o);
4909     if (o->op_type != (unsigned)type)
4910         return o;
4911
4912     return fold_constants(op_integerize(op_std_init(o)));
4913 }
4914
4915 /* Constructors */
4916
4917
4918 /*
4919 =head1 Optree construction
4920
4921 =for apidoc Am|OP *|newNULLLIST
4922
4923 Constructs, checks, and returns a new C<stub> op, which represents an
4924 empty list expression.
4925
4926 =cut
4927 */
4928
4929 OP *
4930 Perl_newNULLLIST(pTHX)
4931 {
4932     return newOP(OP_STUB, 0);
4933 }
4934
4935 /* promote o and any siblings to be a list if its not already; i.e.
4936  *
4937  *  o - A - B
4938  *
4939  * becomes
4940  *
4941  *  list
4942  *    |
4943  *  pushmark - o - A - B
4944  *
4945  * If nullit it true, the list op is nulled.
4946  */
4947
4948 static OP *
4949 S_force_list(pTHX_ OP *o, bool nullit)
4950 {
4951     if (!o || o->op_type != OP_LIST) {
4952         OP *rest = NULL;
4953         if (o) {
4954             /* manually detach any siblings then add them back later */
4955             rest = OpSIBLING(o);
4956             OpLASTSIB_set(o, NULL);
4957         }
4958         o = newLISTOP(OP_LIST, 0, o, NULL);
4959         if (rest)
4960             op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
4961     }
4962     if (nullit)
4963         op_null(o);
4964     return o;
4965 }
4966
4967 /*
4968 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
4969
4970 Constructs, checks, and returns an op of any list type.  C<type> is
4971 the opcode.  C<flags> gives the eight bits of C<op_flags>, except that
4972 C<OPf_KIDS> will be set automatically if required.  C<first> and C<last>
4973 supply up to two ops to be direct children of the list op; they are
4974 consumed by this function and become part of the constructed op tree.
4975
4976 For most list operators, the check function expects all the kid ops to be
4977 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
4978 appropriate.  What you want to do in that case is create an op of type
4979 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
4980 See L</op_convert_list> for more information.
4981
4982
4983 =cut
4984 */
4985
4986 OP *
4987 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4988 {
4989     dVAR;
4990     LISTOP *listop;
4991
4992     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
4993         || type == OP_CUSTOM);
4994
4995     NewOp(1101, listop, 1, LISTOP);
4996
4997     OpTYPE_set(listop, type);
4998     if (first || last)
4999         flags |= OPf_KIDS;
5000     listop->op_flags = (U8)flags;
5001
5002     if (!last && first)
5003         last = first;
5004     else if (!first && last)
5005         first = last;
5006     else if (first)
5007         OpMORESIB_set(first, last);
5008     listop->op_first = first;
5009     listop->op_last = last;
5010     if (type == OP_LIST) {
5011         OP* const pushop = newOP(OP_PUSHMARK, 0);
5012         OpMORESIB_set(pushop, first);
5013         listop->op_first = pushop;
5014         listop->op_flags |= OPf_KIDS;
5015         if (!last)
5016             listop->op_last = pushop;
5017     }
5018     if (listop->op_last)
5019         OpLASTSIB_set(listop->op_last, (OP*)listop);
5020
5021     return CHECKOP(type, listop);
5022 }
5023
5024 /*
5025 =for apidoc Am|OP *|newOP|I32 type|I32 flags
5026
5027 Constructs, checks, and returns an op of any base type (any type that
5028 has no extra fields).  C<type> is the opcode.  C<flags> gives the
5029 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
5030 of C<op_private>.
5031
5032 =cut
5033 */
5034
5035 OP *
5036 Perl_newOP(pTHX_ I32 type, I32 flags)
5037 {
5038     dVAR;
5039     OP *o;
5040
5041     if (type == -OP_ENTEREVAL) {
5042         type = OP_ENTEREVAL;
5043         flags |= OPpEVAL_BYTES<<8;
5044     }
5045
5046     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
5047         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
5048         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5049         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5050
5051     NewOp(1101, o, 1, OP);
5052     OpTYPE_set(o, type);
5053     o->op_flags = (U8)flags;
5054
5055     o->op_next = o;
5056     o->op_private = (U8)(0 | (flags >> 8));
5057     if (PL_opargs[type] & OA_RETSCALAR)
5058         scalar(o);
5059     if (PL_opargs[type] & OA_TARGET)
5060         o->op_targ = pad_alloc(type, SVs_PADTMP);
5061     return CHECKOP(type, o);
5062 }
5063
5064 /*
5065 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
5066
5067 Constructs, checks, and returns an op of any unary type.  C<type> is
5068 the opcode.  C<flags> gives the eight bits of C<op_flags>, except that
5069 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
5070 bits, the eight bits of C<op_private>, except that the bit with value 1
5071 is automatically set.  C<first> supplies an optional op to be the direct
5072 child of the unary op; it is consumed by this function and become part
5073 of the constructed op tree.
5074
5075 =cut
5076 */
5077
5078 OP *
5079 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
5080 {
5081     dVAR;
5082     UNOP *unop;
5083
5084     if (type == -OP_ENTEREVAL) {
5085         type = OP_ENTEREVAL;
5086         flags |= OPpEVAL_BYTES<<8;
5087     }
5088
5089     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
5090         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
5091         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5092         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
5093         || type == OP_SASSIGN
5094         || type == OP_ENTERTRY
5095         || type == OP_CUSTOM
5096         || type == OP_NULL );
5097
5098     if (!first)
5099         first = newOP(OP_STUB, 0);
5100     if (PL_opargs[type] & OA_MARK)
5101         first = force_list(first, 1);
5102
5103     NewOp(1101, unop, 1, UNOP);
5104     OpTYPE_set(unop, type);
5105     unop->op_first = first;
5106     unop->op_flags = (U8)(flags | OPf_KIDS);
5107     unop->op_private = (U8)(1 | (flags >> 8));
5108
5109     if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
5110         OpLASTSIB_set(first, (OP*)unop);
5111
5112     unop = (UNOP*) CHECKOP(type, unop);
5113     if (unop->op_next)
5114         return (OP*)unop;
5115
5116     return fold_constants(op_integerize(op_std_init((OP *) unop)));
5117 }
5118
5119 /*
5120 =for apidoc newUNOP_AUX
5121
5122 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
5123 initialised to C<aux>
5124
5125 =cut
5126 */
5127
5128 OP *
5129 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
5130 {
5131     dVAR;
5132     UNOP_AUX *unop;
5133
5134     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
5135         || type == OP_CUSTOM);
5136
5137     NewOp(1101, unop, 1, UNOP_AUX);
5138     unop->op_type = (OPCODE)type;
5139     unop->op_ppaddr = PL_ppaddr[type];
5140     unop->op_first = first;
5141     unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
5142     unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
5143     unop->op_aux = aux;
5144
5145     if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
5146         OpLASTSIB_set(first, (OP*)unop);
5147
5148     unop = (UNOP_AUX*) CHECKOP(type, unop);
5149
5150     return op_std_init((OP *) unop);
5151 }
5152
5153 /*
5154 =for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
5155
5156 Constructs, checks, and returns an op of method type with a method name
5157 evaluated at runtime.  C<type> is the opcode.  C<flags> gives the eight
5158 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
5159 and, shifted up eight bits, the eight bits of C<op_private>, except that
5160 the bit with value 1 is automatically set.  C<dynamic_meth> supplies an
5161 op which evaluates method name; it is consumed by this function and
5162 become part of the constructed op tree.
5163 Supported optypes: C<OP_METHOD>.
5164
5165 =cut
5166 */
5167
5168 static OP*
5169 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
5170     dVAR;
5171     METHOP *methop;
5172
5173     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
5174         || type == OP_CUSTOM);
5175
5176     NewOp(1101, methop, 1, METHOP);
5177     if (dynamic_meth) {
5178         if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
5179         methop->op_flags = (U8)(flags | OPf_KIDS);
5180         methop->op_u.op_first = dynamic_meth;
5181         methop->op_private = (U8)(1 | (flags >> 8));
5182
5183         if (!OpHAS_SIBLING(dynamic_meth))
5184             OpLASTSIB_set(dynamic_meth, (OP*)methop);
5185     }
5186     else {
5187         assert(const_meth);
5188         methop->op_flags = (U8)(flags & ~OPf_KIDS);
5189         methop->op_u.op_meth_sv = const_meth;
5190         methop->op_private = (U8)(0 | (flags >> 8));
5191         methop->op_next = (OP*)methop;
5192     }
5193
5194 #ifdef USE_ITHREADS
5195     methop->op_rclass_targ = 0;
5196 #else
5197     methop->op_rclass_sv = NULL;
5198 #endif
5199
5200     OpTYPE_set(methop, type);
5201     return CHECKOP(type, methop);
5202 }
5203
5204 OP *
5205 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
5206     PERL_ARGS_ASSERT_NEWMETHOP;
5207     return newMETHOP_internal(type, flags, dynamic_meth, NULL);
5208 }
5209
5210 /*
5211 =for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
5212
5213 Constructs, checks, and returns an op of method type with a constant
5214 method name.  C<type> is the opcode.  C<flags> gives the eight bits of
5215 C<op_flags>, and, shifted up eight bits, the eight bits of
5216 C<op_private>.  C<const_meth> supplies a constant method name;
5217 it must be a shared COW string.
5218 Supported optypes: C<OP_METHOD_NAMED>.
5219
5220 =cut
5221 */
5222
5223 OP *
5224 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
5225     PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
5226     return newMETHOP_internal(type, flags, NULL, const_meth);
5227 }
5228
5229 /*
5230 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
5231
5232 Constructs, checks, and returns an op of any binary type.  C<type>
5233 is the opcode.  C<flags> gives the eight bits of C<op_flags>, except
5234 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
5235 the eight bits of C<op_private>, except that the bit with value 1 or
5236 2 is automatically set as required.  C<first> and C<last> supply up to
5237 two ops to be the direct children of the binary op; they are consumed
5238 by this function and become part of the constructed op tree.
5239
5240 =cut
5241 */
5242
5243 OP *
5244 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
5245 {
5246     dVAR;
5247     BINOP *binop;
5248
5249     ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
5250         || type == OP_NULL || type == OP_CUSTOM);
5251
5252     NewOp(1101, binop, 1, BINOP);
5253
5254     if (!first)
5255         first = newOP(OP_NULL, 0);
5256
5257     OpTYPE_set(binop, type);
5258     binop->op_first = first;
5259     binop->op_flags = (U8)(flags | OPf_KIDS);
5260     if (!last) {
5261         last = first;
5262         binop->op_private = (U8)(1 | (flags >> 8));
5263     }
5264     else {
5265         binop->op_private = (U8)(2 | (flags >> 8));
5266         OpMORESIB_set(first, last);
5267     }
5268
5269     if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
5270         OpLASTSIB_set(last, (OP*)binop);
5271
5272     binop->op_last = OpSIBLING(binop->op_first);
5273     if (binop->op_last)
5274         OpLASTSIB_set(binop->op_last, (OP*)binop);
5275
5276     binop = (BINOP*)CHECKOP(type, binop);
5277     if (binop->op_next || binop->op_type != (OPCODE)type)
5278         return (OP*)binop;
5279
5280     return fold_constants(op_integerize(op_std_init((OP *)binop)));
5281 }
5282
5283 static int uvcompare(const void *a, const void *b)
5284     __attribute__nonnull__(1)
5285     __attribute__nonnull__(2)
5286     __attribute__pure__;
5287 static int uvcompare(const void *a, const void *b)
5288 {
5289     if (*((const UV *)a) < (*(const UV *)b))
5290         return -1;
5291     if (*((const UV *)a) > (*(const UV *)b))
5292         return 1;
5293     if (*((const UV *)a+1) < (*(const UV *)b+1))
5294         return -1;
5295     if (*((const UV *)a+1) > (*(const UV *)b+1))
5296         return 1;
5297     return 0;
5298 }
5299
5300 static OP *
5301 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
5302 {
5303     SV * const tstr = ((SVOP*)expr)->op_sv;
5304     SV * const rstr =
5305                               ((SVOP*)repl)->op_sv;
5306     STRLEN tlen;
5307     STRLEN rlen;
5308     const U8 *t = (U8*)SvPV_const(tstr, tlen);
5309     const U8 *r = (U8*)SvPV_const(rstr, rlen);
5310     I32 i;
5311     I32 j;
5312     I32 grows = 0;
5313     short *tbl;
5314
5315     const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
5316     const I32 squash     = o->op_private & OPpTRANS_SQUASH;
5317     I32 del              = o->op_private & OPpTRANS_DELETE;
5318     SV* swash;
5319
5320     PERL_ARGS_ASSERT_PMTRANS;
5321
5322     PL_hints |= HINT_BLOCK_SCOPE;
5323
5324     if (SvUTF8(tstr))
5325         o->op_private |= OPpTRANS_FROM_UTF;
5326
5327     if (SvUTF8(rstr))
5328         o->op_private |= OPpTRANS_TO_UTF;
5329
5330     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
5331         SV* const listsv = newSVpvs("# comment\n");
5332         SV* transv = NULL;
5333         const U8* tend = t + tlen;
5334         const U8* rend = r + rlen;
5335         STRLEN ulen;
5336         UV tfirst = 1;
5337         UV tlast = 0;
5338         IV tdiff;
5339         STRLEN tcount = 0;
5340         UV rfirst = 1;
5341         UV rlast = 0;
5342         IV rdiff;
5343         STRLEN rcount = 0;
5344         IV diff;
5345         I32 none = 0;
5346         U32 max = 0;
5347         I32 bits;
5348         I32 havefinal = 0;
5349         U32 final = 0;
5350         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
5351         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
5352         U8* tsave = NULL;
5353         U8* rsave = NULL;
5354         const U32 flags = UTF8_ALLOW_DEFAULT;
5355
5356         if (!from_utf) {
5357             STRLEN len = tlen;
5358             t = tsave = bytes_to_utf8(t, &len);
5359             tend = t + len;
5360         }
5361         if (!to_utf && rlen) {
5362             STRLEN len = rlen;
5363             r = rsave = bytes_to_utf8(r, &len);
5364             rend = r + len;
5365         }
5366
5367 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
5368  * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
5369  * odd.  */
5370
5371         if (complement) {
5372             U8 tmpbuf[UTF8_MAXBYTES+1];
5373             UV *cp;
5374             UV nextmin = 0;
5375             Newx(cp, 2*tlen, UV);
5376             i = 0;
5377             transv = newSVpvs("");
5378             while (t < tend) {
5379                 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
5380                 t += ulen;
5381                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
5382                     t++;
5383                     cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
5384                     t += ulen;
5385                 }
5386                 else {
5387                  cp[2*i+1] = cp[2*i];
5388                 }
5389                 i++;
5390             }
5391             qsort(cp, i, 2*sizeof(UV), uvcompare);
5392             for (j = 0; j < i; j++) {
5393                 UV  val = cp[2*j];
5394                 diff = val - nextmin;
5395                 if (diff > 0) {
5396                     t = uvchr_to_utf8(tmpbuf,nextmin);
5397                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5398                     if (diff > 1) {
5399                         U8  range_mark = ILLEGAL_UTF8_BYTE;
5400                         t = uvchr_to_utf8(tmpbuf, val - 1);
5401                         sv_catpvn(transv, (char *)&range_mark, 1);
5402                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5403                     }
5404                 }
5405                 val = cp[2*j+1];
5406                 if (val >= nextmin)
5407                     nextmin = val + 1;
5408             }
5409             t = uvchr_to_utf8(tmpbuf,nextmin);
5410             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5411             {
5412                 U8 range_mark = ILLEGAL_UTF8_BYTE;
5413                 sv_catpvn(transv, (char *)&range_mark, 1);
5414             }
5415             t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
5416             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5417             t = (const U8*)SvPVX_const(transv);
5418             tlen = SvCUR(transv);
5419             tend = t + tlen;
5420             Safefree(cp);
5421         }
5422         else if (!rlen && !del) {
5423             r = t; rlen = tlen; rend = tend;
5424         }
5425         if (!squash) {
5426                 if ((!rlen && !del) || t == r ||
5427                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
5428                 {
5429                     o->op_private |= OPpTRANS_IDENTICAL;
5430                 }
5431         }
5432
5433         while (t < tend || tfirst <= tlast) {
5434             /* see if we need more "t" chars */
5435             if (tfirst > tlast) {
5436                 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
5437                 t += ulen;
5438                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {      /* illegal utf8 val indicates range */
5439                     t++;
5440                     tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
5441                     t += ulen;
5442                 }
5443                 else
5444                     tlast = tfirst;
5445             }
5446
5447             /* now see if we need more "r" chars */
5448             if (rfirst > rlast) {
5449                 if (r < rend) {
5450                     rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
5451                     r += ulen;
5452                     if (r < rend && *r == ILLEGAL_UTF8_BYTE) {  /* illegal utf8 val indicates range */
5453                         r++;
5454                         rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
5455                         r += ulen;
5456                     }
5457                     else
5458                         rlast = rfirst;
5459                 }
5460                 else {
5461                     if (!havefinal++)
5462                         final = rlast;
5463                     rfirst = rlast = 0xffffffff;
5464                 }
5465             }
5466
5467             /* now see which range will peter out first, if either. */
5468             tdiff = tlast - tfirst;
5469             rdiff = rlast - rfirst;
5470             tcount += tdiff + 1;
5471             rcount += rdiff + 1;
5472
5473             if (tdiff <= rdiff)
5474                 diff = tdiff;
5475             else
5476                 diff = rdiff;
5477
5478             if (rfirst == 0xffffffff) {
5479                 diff = tdiff;   /* oops, pretend rdiff is infinite */
5480                 if (diff > 0)
5481                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
5482                                    (long)tfirst, (long)tlast);
5483                 else
5484                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
5485             }
5486             else {
5487                 if (diff > 0)
5488                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
5489                                    (long)tfirst, (long)(tfirst + diff),
5490                                    (long)rfirst);
5491                 else
5492                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
5493                                    (long)tfirst, (long)rfirst);
5494
5495                 if (rfirst + diff > max)
5496                     max = rfirst + diff;
5497                 if (!grows)
5498                     grows = (tfirst < rfirst &&
5499                              UVCHR_SKIP(tfirst) < UVCHR_SKIP(rfirst + diff));
5500                 rfirst += diff + 1;
5501             }
5502             tfirst += diff + 1;
5503         }
5504
5505         none = ++max;
5506         if (del)
5507             del = ++max;
5508
5509         if (max > 0xffff)
5510             bits = 32;
5511         else if (max > 0xff)
5512             bits = 16;
5513         else
5514             bits = 8;
5515
5516         swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
5517 #ifdef USE_ITHREADS
5518         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
5519         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
5520         PAD_SETSV(cPADOPo->op_padix, swash);
5521         SvPADTMP_on(swash);
5522         SvREADONLY_on(swash);
5523 #else
5524         cSVOPo->op_sv = swash;
5525 #endif
5526         SvREFCNT_dec(listsv);
5527         SvREFCNT_dec(transv);
5528
5529         if (!del && havefinal && rlen)
5530             (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
5531                            newSVuv((UV)final), 0);
5532
5533         Safefree(tsave);
5534         Safefree(rsave);
5535
5536         tlen = tcount;
5537         rlen = rcount;
5538         if (r < rend)
5539             rlen++;
5540         else if (rlast == 0xffffffff)
5541             rlen = 0;
5542
5543         goto warnins;
5544     }
5545
5546     tbl = (short*)PerlMemShared_calloc(
5547         (o->op_private & OPpTRANS_COMPLEMENT) &&
5548             !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
5549         sizeof(short));
5550     cPVOPo->op_pv = (char*)tbl;
5551     if (complement) {
5552         for (i = 0; i < (I32)tlen; i++)
5553             tbl[t[i]] = -1;
5554         for (i = 0, j = 0; i < 256; i++) {
5555             if (!tbl[i]) {
5556                 if (j >= (I32)rlen) {
5557                     if (del)
5558                         tbl[i] = -2;
5559                     else if (rlen)
5560                         tbl[i] = r[j-1];
5561                     else
5562                         tbl[i] = (short)i;
5563                 }
5564                 else {
5565                     if (UVCHR_IS_INVARIANT(i) && ! UVCHR_IS_INVARIANT(r[j]))
5566                         grows = 1;
5567                     tbl[i] = r[j++];
5568                 }
5569             }
5570         }
5571         if (!del) {
5572             if (!rlen) {
5573                 j = rlen;
5574                 if (!squash)
5575                     o->op_private |= OPpTRANS_IDENTICAL;
5576             }
5577             else if (j >= (I32)rlen)
5578                 j = rlen - 1;
5579             else {
5580                 tbl =
5581                     (short *)
5582                     PerlMemShared_realloc(tbl,
5583                                           (0x101+rlen-j) * sizeof(short));
5584                 cPVOPo->op_pv = (char*)tbl;
5585             }
5586             tbl[0x100] = (short)(rlen - j);
5587             for (i=0; i < (I32)rlen - j; i++)
5588                 tbl[0x101+i] = r[j+i];
5589         }
5590     }
5591     else {
5592         if (!rlen && !del) {
5593             r = t; rlen = tlen;
5594             if (!squash)
5595                 o->op_private |= OPpTRANS_IDENTICAL;
5596         }
5597         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
5598             o->op_private |= OPpTRANS_IDENTICAL;
5599         }
5600         for (i = 0; i < 256; i++)
5601             tbl[i] = -1;
5602         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
5603             if (j >= (I32)rlen) {
5604                 if (del) {
5605                     if (tbl[t[i]] == -1)
5606                         tbl[t[i]] = -2;
5607                     continue;
5608                 }
5609                 --j;
5610             }
5611             if (tbl[t[i]] == -1) {
5612                 if (     UVCHR_IS_INVARIANT(t[i])
5613                     && ! UVCHR_IS_INVARIANT(r[j]))
5614                     grows = 1;
5615                 tbl[t[i]] = r[j];
5616             }
5617         }
5618     }
5619
5620   warnins:
5621     if(del && rlen == tlen) {
5622         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
5623     } else if(rlen > tlen && !complement) {
5624         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
5625     }
5626
5627     if (grows)
5628         o->op_private |= OPpTRANS_GROWS;
5629     op_free(expr);
5630     op_free(repl);
5631
5632     return o;
5633 }
5634
5635 /*
5636 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
5637
5638 Constructs, checks, and returns an op of any pattern matching type.
5639 C<type> is the opcode.  C<flags> gives the eight bits of C<op_flags>
5640 and, shifted up eight bits, the eight bits of C<op_private>.
5641
5642 =cut
5643 */
5644
5645 OP *
5646 Perl_newPMOP(pTHX_ I32 type, I32 flags)
5647 {
5648     dVAR;
5649     PMOP *pmop;
5650
5651     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
5652         || type == OP_CUSTOM);
5653
5654     NewOp(1101, pmop, 1, PMOP);
5655     OpTYPE_set(pmop, type);
5656     pmop->op_flags = (U8)flags;
5657     pmop->op_private = (U8)(0 | (flags >> 8));
5658     if (PL_opargs[type] & OA_RETSCALAR)
5659         scalar((OP *)pmop);
5660
5661     if (PL_hints & HINT_RE_TAINT)
5662         pmop->op_pmflags |= PMf_RETAINT;
5663 #ifdef USE_LOCALE_CTYPE
5664     if (IN_LC_COMPILETIME(LC_CTYPE)) {
5665         set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
5666     }
5667     else
5668 #endif
5669          if (IN_UNI_8_BIT) {
5670         set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
5671     }
5672     if (PL_hints & HINT_RE_FLAGS) {
5673         SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5674          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
5675         );
5676         if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
5677         reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5678          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
5679         );
5680         if (reflags && SvOK(reflags)) {
5681             set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
5682         }
5683     }
5684
5685
5686 #ifdef USE_ITHREADS
5687     assert(SvPOK(PL_regex_pad[0]));
5688     if (SvCUR(PL_regex_pad[0])) {
5689         /* Pop off the "packed" IV from the end.  */
5690         SV *const repointer_list = PL_regex_pad[0];
5691         const char *p = SvEND(repointer_list) - sizeof(IV);
5692         const IV offset = *((IV*)p);
5693
5694         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
5695
5696         SvEND_set(repointer_list, p);
5697
5698         pmop->op_pmoffset = offset;
5699         /* This slot should be free, so assert this:  */
5700         assert(PL_regex_pad[offset] == &PL_sv_undef);
5701     } else {
5702         SV * const repointer = &PL_sv_undef;
5703         av_push(PL_regex_padav, repointer);
5704         pmop->op_pmoffset = av_tindex(PL_regex_padav);
5705         PL_regex_pad = AvARRAY(PL_regex_padav);
5706     }
5707 #endif
5708
5709     return CHECKOP(type, pmop);
5710 }
5711
5712 static void
5713 S_set_haseval(pTHX)
5714 {
5715     PADOFFSET i = 1;
5716     PL_cv_has_eval = 1;
5717     /* Any pad names in scope are potentially lvalues.  */
5718     for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
5719         PADNAME *pn = PAD_COMPNAME_SV(i);
5720         if (!pn || !PadnameLEN(pn))
5721             continue;
5722         if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
5723             S_mark_padname_lvalue(aTHX_ pn);
5724     }
5725 }
5726
5727 /* Given some sort of match op o, and an expression expr containing a
5728  * pattern, either compile expr into a regex and attach it to o (if it's
5729  * constant), or convert expr into a runtime regcomp op sequence (if it's
5730  * not)
5731  *
5732  * Flags currently has 2 bits of meaning:
5733  * 1: isreg indicates that the pattern is part of a regex construct, eg
5734  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
5735  * split "pattern", which aren't. In the former case, expr will be a list
5736  * if the pattern contains more than one term (eg /a$b/).
5737  * 2: The pattern is for a split.
5738  *
5739  * When the pattern has been compiled within a new anon CV (for
5740  * qr/(?{...})/ ), then floor indicates the savestack level just before
5741  * the new sub was created
5742  */
5743
5744 OP *
5745 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor)
5746 {
5747     PMOP *pm;
5748     LOGOP *rcop;
5749     I32 repl_has_vars = 0;
5750     bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
5751     bool is_compiletime;
5752     bool has_code;
5753     bool isreg    = cBOOL(flags & 1);
5754     bool is_split = cBOOL(flags & 2);
5755
5756     PERL_ARGS_ASSERT_PMRUNTIME;
5757
5758     if (is_trans) {
5759         return pmtrans(o, expr, repl);
5760     }
5761
5762     /* find whether we have any runtime or code elements;
5763      * at the same time, temporarily set the op_next of each DO block;
5764      * then when we LINKLIST, this will cause the DO blocks to be excluded
5765      * from the op_next chain (and from having LINKLIST recursively
5766      * applied to them). We fix up the DOs specially later */
5767
5768     is_compiletime = 1;
5769     has_code = 0;
5770     if (expr->op_type == OP_LIST) {
5771         OP *o;
5772         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
5773             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
5774                 has_code = 1;
5775                 assert(!o->op_next);
5776                 if (UNLIKELY(!OpHAS_SIBLING(o))) {
5777                     assert(PL_parser && PL_parser->error_count);
5778                     /* This can happen with qr/ (?{(^{})/.  Just fake up
5779                        the op we were expecting to see, to avoid crashing
5780                        elsewhere.  */
5781                     op_sibling_splice(expr, o, 0,
5782                                       newSVOP(OP_CONST, 0, &PL_sv_no));
5783                 }
5784                 o->op_next = OpSIBLING(o);
5785             }
5786             else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
5787                 is_compiletime = 0;
5788         }
5789     }
5790     else if (expr->op_type != OP_CONST)
5791         is_compiletime = 0;
5792
5793     LINKLIST(expr);
5794
5795     /* fix up DO blocks; treat each one as a separate little sub;
5796      * also, mark any arrays as LIST/REF */
5797
5798     if (expr->op_type == OP_LIST) {
5799         OP *o;
5800         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
5801
5802             if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
5803                 assert( !(o->op_flags  & OPf_WANT));
5804                 /* push the array rather than its contents. The regex
5805                  * engine will retrieve and join the elements later */
5806                 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
5807                 continue;
5808             }
5809
5810             if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
5811                 continue;
5812             o->op_next = NULL; /* undo temporary hack from above */
5813             scalar(o);
5814             LINKLIST(o);
5815             if (cLISTOPo->op_first->op_type == OP_LEAVE) {
5816                 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
5817                 /* skip ENTER */
5818                 assert(leaveop->op_first->op_type == OP_ENTER);
5819                 assert(OpHAS_SIBLING(leaveop->op_first));
5820                 o->op_next = OpSIBLING(leaveop->op_first);
5821                 /* skip leave */
5822                 assert(leaveop->op_flags & OPf_KIDS);
5823                 assert(leaveop->op_last->op_next == (OP*)leaveop);
5824                 leaveop->op_next = NULL; /* stop on last op */
5825                 op_null((OP*)leaveop);
5826             }
5827             else {
5828                 /* skip SCOPE */
5829                 OP *scope = cLISTOPo->op_first;
5830                 assert(scope->op_type == OP_SCOPE);
5831                 assert(scope->op_flags & OPf_KIDS);
5832                 scope->op_next = NULL; /* stop on last op */
5833                 op_null(scope);
5834             }
5835             /* have to peep the DOs individually as we've removed it from
5836              * the op_next chain */
5837             CALL_PEEP(o);
5838             S_prune_chain_head(&(o->op_next));
5839             if (is_compiletime)
5840                 /* runtime finalizes as part of finalizing whole tree */
5841                 finalize_optree(o);
5842         }
5843     }
5844     else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
5845         assert( !(expr->op_flags  & OPf_WANT));
5846         /* push the array rather than its contents. The regex
5847          * engine will retrieve and join the elements later */
5848         expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
5849     }
5850
5851     PL_hints |= HINT_BLOCK_SCOPE;
5852     pm = (PMOP*)o;
5853     assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
5854
5855     if (is_compiletime) {
5856         U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
5857         regexp_engine const *eng = current_re_engine();
5858
5859         if (is_split) {
5860             /* make engine handle split ' ' specially */
5861             pm->op_pmflags |= PMf_SPLIT;
5862             rx_flags |= RXf_SPLIT;
5863         }
5864
5865         /* Skip compiling if parser found an error for this pattern */
5866         if (pm->op_pmflags & PMf_HAS_ERROR) {
5867             return o;
5868         }
5869
5870         if (!has_code || !eng->op_comp) {
5871             /* compile-time simple constant pattern */
5872
5873             if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
5874                 /* whoops! we guessed that a qr// had a code block, but we
5875                  * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
5876                  * that isn't required now. Note that we have to be pretty
5877                  * confident that nothing used that CV's pad while the
5878                  * regex was parsed, except maybe op targets for \Q etc.
5879                  * If there were any op targets, though, they should have
5880                  * been stolen by constant folding.
5881                  */
5882 #ifdef DEBUGGING
5883                 SSize_t i = 0;
5884                 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
5885                 while (++i <= AvFILLp(PL_comppad)) {
5886 #  ifdef USE_PAD_RESET
5887                     /* under USE_PAD_RESET, pad swipe replaces a swiped
5888                      * folded constant with a fresh padtmp */
5889                     assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i]));
5890 #  else
5891                     assert(!PL_curpad[i]);
5892 #  endif
5893                 }
5894 #endif
5895                 /* But we know that one op is using this CV's slab. */
5896                 cv_forget_slab(PL_compcv);
5897                 LEAVE_SCOPE(floor);
5898                 pm->op_pmflags &= ~PMf_HAS_CV;
5899             }
5900
5901             PM_SETRE(pm,
5902                 eng->op_comp
5903                     ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5904                                         rx_flags, pm->op_pmflags)
5905                     : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5906                                         rx_flags, pm->op_pmflags)
5907             );
5908             op_free(expr);
5909         }
5910         else {
5911             /* compile-time pattern that includes literal code blocks */
5912             REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5913                         rx_flags,
5914                         (pm->op_pmflags |
5915                             ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
5916                     );
5917             PM_SETRE(pm, re);
5918             if (pm->op_pmflags & PMf_HAS_CV) {
5919                 CV *cv;
5920                 /* this QR op (and the anon sub we embed it in) is never
5921                  * actually executed. It's just a placeholder where we can
5922                  * squirrel away expr in op_code_list without the peephole
5923                  * optimiser etc processing it for a second time */
5924                 OP *qr = newPMOP(OP_QR, 0);
5925                 ((PMOP*)qr)->op_code_list = expr;
5926
5927                 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
5928                 SvREFCNT_inc_simple_void(PL_compcv);
5929                 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
5930                 ReANY(re)->qr_anoncv = cv;
5931
5932                 /* attach the anon CV to the pad so that
5933                  * pad_fixup_inner_anons() can find it */
5934                 (void)pad_add_anon(cv, o->op_type);
5935                 SvREFCNT_inc_simple_void(cv);
5936             }
5937             else {
5938                 pm->op_code_list = expr;
5939             }
5940         }
5941     }
5942     else {
5943         /* runtime pattern: build chain of regcomp etc ops */
5944         bool reglist;
5945         PADOFFSET cv_targ = 0;
5946
5947         reglist = isreg && expr->op_type == OP_LIST;
5948         if (reglist)
5949             op_null(expr);
5950
5951         if (has_code) {
5952             pm->op_code_list = expr;
5953             /* don't free op_code_list; its ops are embedded elsewhere too */
5954             pm->op_pmflags |= PMf_CODELIST_PRIVATE;
5955         }
5956
5957         if (is_split)
5958             /* make engine handle split ' ' specially */
5959             pm->op_pmflags |= PMf_SPLIT;
5960
5961         /* the OP_REGCMAYBE is a placeholder in the non-threaded case
5962          * to allow its op_next to be pointed past the regcomp and
5963          * preceding stacking ops;
5964          * OP_REGCRESET is there to reset taint before executing the
5965          * stacking ops */
5966         if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
5967             expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
5968
5969         if (pm->op_pmflags & PMf_HAS_CV) {
5970             /* we have a runtime qr with literal code. This means
5971              * that the qr// has been wrapped in a new CV, which
5972              * means that runtime consts, vars etc will have been compiled
5973              * against a new pad. So... we need to execute those ops
5974              * within the environment of the new CV. So wrap them in a call
5975              * to a new anon sub. i.e. for
5976              *
5977              *     qr/a$b(?{...})/,
5978              *
5979              * we build an anon sub that looks like
5980              *
5981              *     sub { "a", $b, '(?{...})' }
5982              *
5983              * and call it, passing the returned list to regcomp.
5984              * Or to put it another way, the list of ops that get executed
5985              * are:
5986              *
5987              *     normal              PMf_HAS_CV
5988              *     ------              -------------------
5989              *                         pushmark (for regcomp)
5990              *                         pushmark (for entersub)
5991              *                         anoncode
5992              *                         srefgen
5993              *                         entersub
5994              *     regcreset                  regcreset
5995              *     pushmark                   pushmark
5996              *     const("a")                 const("a")
5997              *     gvsv(b)                    gvsv(b)
5998              *     const("(?{...})")          const("(?{...})")
5999              *                                leavesub
6000              *     regcomp             regcomp
6001              */
6002
6003             SvREFCNT_inc_simple_void(PL_compcv);
6004             CvLVALUE_on(PL_compcv);
6005             /* these lines are just an unrolled newANONATTRSUB */
6006             expr = newSVOP(OP_ANONCODE, 0,
6007                     MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
6008             cv_targ = expr->op_targ;
6009             expr = newUNOP(OP_REFGEN, 0, expr);
6010
6011             expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
6012         }
6013
6014         rcop = alloc_LOGOP(OP_REGCOMP, scalar(expr), o);
6015         rcop->op_flags |=  ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
6016                            | (reglist ? OPf_STACKED : 0);
6017         rcop->op_targ = cv_targ;
6018
6019         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
6020         if (PL_hints & HINT_RE_EVAL)
6021             S_set_haseval(aTHX);
6022
6023         /* establish postfix order */
6024         if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
6025             LINKLIST(expr);
6026             rcop->op_next = expr;
6027             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
6028         }
6029         else {
6030             rcop->op_next = LINKLIST(expr);
6031             expr->op_next = (OP*)rcop;
6032         }
6033
6034         op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
6035     }
6036
6037     if (repl) {
6038         OP *curop = repl;
6039         bool konst;
6040         /* If we are looking at s//.../e with a single statement, get past
6041            the implicit do{}. */
6042         if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
6043              && cUNOPx(curop)->op_first->op_type == OP_SCOPE
6044              && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
6045          {
6046             OP *sib;
6047             OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
6048             if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
6049              && !OpHAS_SIBLING(sib))
6050                 curop = sib;
6051         }
6052         if (curop->op_type == OP_CONST)
6053             konst = TRUE;
6054         else if (( (curop->op_type == OP_RV2SV ||
6055                     curop->op_type == OP_RV2AV ||
6056                     curop->op_type == OP_RV2HV ||
6057                     curop->op_type == OP_RV2GV)
6058                    && cUNOPx(curop)->op_first
6059                    && cUNOPx(curop)->op_first->op_type == OP_GV )
6060                 || curop->op_type == OP_PADSV
6061                 || curop->op_type == OP_PADAV
6062                 || curop->op_type == OP_PADHV
6063                 || curop->op_type == OP_PADANY) {
6064             repl_has_vars = 1;
6065             konst = TRUE;
6066         }
6067         else konst = FALSE;
6068         if (konst
6069             && !(repl_has_vars
6070                  && (!PM_GETRE(pm)
6071                      || !RX_PRELEN(PM_GETRE(pm))
6072                      || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
6073         {
6074             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
6075             op_prepend_elem(o->op_type, scalar(repl), o);
6076         }
6077         else {
6078             rcop = alloc_LOGOP(OP_SUBSTCONT, scalar(repl), o);
6079             rcop->op_private = 1;
6080
6081             /* establish postfix order */
6082             rcop->op_next = LINKLIST(repl);
6083             repl->op_next = (OP*)rcop;
6084
6085             pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
6086             assert(!(pm->op_pmflags & PMf_ONCE));
6087             pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
6088             rcop->op_next = 0;
6089         }
6090     }
6091
6092     return (OP*)pm;
6093 }
6094
6095 /*
6096 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
6097
6098 Constructs, checks, and returns an op of any type that involves an
6099 embedded SV.  C<type> is the opcode.  C<flags> gives the eight bits
6100 of C<op_flags>.  C<sv> gives the SV to embed in the op; this function
6101 takes ownership of one reference to it.
6102
6103 =cut
6104 */
6105
6106 OP *
6107 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
6108 {
6109     dVAR;
6110     SVOP *svop;
6111
6112     PERL_ARGS_ASSERT_NEWSVOP;
6113
6114     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
6115         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
6116         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6117         || type == OP_CUSTOM);
6118
6119     NewOp(1101, svop, 1, SVOP);
6120     OpTYPE_set(svop, type);
6121     svop->op_sv = sv;
6122     svop->op_next = (OP*)svop;
6123     svop->op_flags = (U8)flags;
6124     svop->op_private = (U8)(0 | (flags >> 8));
6125     if (PL_opargs[type] & OA_RETSCALAR)
6126         scalar((OP*)svop);
6127     if (PL_opargs[type] & OA_TARGET)
6128         svop->op_targ = pad_alloc(type, SVs_PADTMP);
6129     return CHECKOP(type, svop);
6130 }
6131
6132 /*
6133 =for apidoc Am|OP *|newDEFSVOP|
6134
6135 Constructs and returns an op to access C<$_>.
6136
6137 =cut
6138 */
6139
6140 OP *
6141 Perl_newDEFSVOP(pTHX)
6142 {
6143         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
6144 }
6145
6146 #ifdef USE_ITHREADS
6147
6148 /*
6149 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
6150
6151 Constructs, checks, and returns an op of any type that involves a
6152 reference to a pad element.  C<type> is the opcode.  C<flags> gives the
6153 eight bits of C<op_flags>.  A pad slot is automatically allocated, and
6154 is populated with C<sv>; this function takes ownership of one reference
6155 to it.
6156
6157 This function only exists if Perl has been compiled to use ithreads.
6158
6159 =cut
6160 */
6161
6162 OP *
6163 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
6164 {
6165     dVAR;
6166     PADOP *padop;
6167
6168     PERL_ARGS_ASSERT_NEWPADOP;
6169
6170     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
6171         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
6172         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6173         || type == OP_CUSTOM);
6174
6175     NewOp(1101, padop, 1, PADOP);
6176     OpTYPE_set(padop, type);
6177     padop->op_padix =
6178         pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
6179     SvREFCNT_dec(PAD_SVl(padop->op_padix));
6180     PAD_SETSV(padop->op_padix, sv);
6181     assert(sv);
6182     padop->op_next = (OP*)padop;
6183     padop->op_flags = (U8)flags;
6184     if (PL_opargs[type] & OA_RETSCALAR)
6185         scalar((OP*)padop);
6186     if (PL_opargs[type] & OA_TARGET)
6187         padop->op_targ = pad_alloc(type, SVs_PADTMP);
6188     return CHECKOP(type, padop);
6189 }
6190
6191 #endif /* USE_ITHREADS */
6192
6193 /*
6194 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
6195
6196 Constructs, checks, and returns an op of any type that involves an
6197 embedded reference to a GV.  C<type> is the opcode.  C<flags> gives the
6198 eight bits of C<op_flags>.  C<gv> identifies the GV that the op should
6199 reference; calling this function does not transfer ownership of any
6200 reference to it.
6201
6202 =cut
6203 */
6204
6205 OP *
6206 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
6207 {
6208     PERL_ARGS_ASSERT_NEWGVOP;
6209
6210 #ifdef USE_ITHREADS
6211     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
6212 #else
6213     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
6214 #endif
6215 }
6216
6217 /*
6218 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
6219
6220 Constructs, checks, and returns an op of any type that involves an
6221 embedded C-level pointer (PV).  C<type> is the opcode.  C<flags> gives
6222 the eight bits of C<op_flags>.  C<pv> supplies the C-level pointer, which
6223 must have been allocated using C<PerlMemShared_malloc>; the memory will
6224 be freed when the op is destroyed.
6225
6226 =cut
6227 */
6228
6229 OP *
6230 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
6231 {
6232     dVAR;
6233     const bool utf8 = cBOOL(flags & SVf_UTF8);
6234     PVOP *pvop;
6235
6236     flags &= ~SVf_UTF8;
6237
6238     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
6239         || type == OP_RUNCV || type == OP_CUSTOM
6240         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6241
6242     NewOp(1101, pvop, 1, PVOP);
6243     OpTYPE_set(pvop, type);
6244     pvop->op_pv = pv;
6245     pvop->op_next = (OP*)pvop;
6246     pvop->op_flags = (U8)flags;
6247     pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
6248     if (PL_opargs[type] & OA_RETSCALAR)
6249         scalar((OP*)pvop);
6250     if (PL_opargs[type] & OA_TARGET)
6251         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
6252     return CHECKOP(type, pvop);
6253 }
6254
6255 void
6256 Perl_package(pTHX_ OP *o)
6257 {
6258     SV *const sv = cSVOPo->op_sv;
6259
6260     PERL_ARGS_ASSERT_PACKAGE;
6261
6262     SAVEGENERICSV(PL_curstash);
6263     save_item(PL_curstname);
6264
6265     PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
6266
6267     sv_setsv(PL_curstname, sv);
6268
6269     PL_hints |= HINT_BLOCK_SCOPE;
6270     PL_parser->copline = NOLINE;
6271
6272     op_free(o);
6273 }
6274
6275 void
6276 Perl_package_version( pTHX_ OP *v )
6277 {
6278     U32 savehints = PL_hints;
6279     PERL_ARGS_ASSERT_PACKAGE_VERSION;
6280     PL_hints &= ~HINT_STRICT_VARS;
6281     sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
6282     PL_hints = savehints;
6283     op_free(v);
6284 }
6285
6286 void
6287 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
6288 {
6289     OP *pack;
6290     OP *imop;
6291     OP *veop;
6292     SV *use_version = NULL;
6293
6294     PERL_ARGS_ASSERT_UTILIZE;
6295
6296     if (idop->op_type != OP_CONST)
6297         Perl_croak(aTHX_ "Module name must be constant");
6298
6299     veop = NULL;
6300
6301     if (version) {
6302         SV * const vesv = ((SVOP*)version)->op_sv;
6303
6304         if (!arg && !SvNIOKp(vesv)) {
6305             arg = version;
6306         }
6307         else {
6308             OP *pack;
6309             SV *meth;
6310
6311             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
6312                 Perl_croak(aTHX_ "Version number must be a constant number");
6313
6314             /* Make copy of idop so we don't free it twice */
6315             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
6316
6317             /* Fake up a method call to VERSION */
6318             meth = newSVpvs_share("VERSION");
6319             veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
6320                             op_append_elem(OP_LIST,
6321                                         op_prepend_elem(OP_LIST, pack, version),
6322                                         newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
6323         }
6324     }
6325
6326     /* Fake up an import/unimport */
6327     if (arg && arg->op_type == OP_STUB) {
6328         imop = arg;             /* no import on explicit () */
6329     }
6330     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
6331         imop = NULL;            /* use 5.0; */
6332         if (aver)
6333             use_version = ((SVOP*)idop)->op_sv;
6334         else
6335             idop->op_private |= OPpCONST_NOVER;
6336     }
6337     else {
6338         SV *meth;
6339
6340         /* Make copy of idop so we don't free it twice */
6341         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
6342
6343         /* Fake up a method call to import/unimport */
6344         meth = aver
6345             ? newSVpvs_share("import") : newSVpvs_share("unimport");
6346         imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
6347                        op_append_elem(OP_LIST,
6348                                    op_prepend_elem(OP_LIST, pack, arg),
6349                                    newMETHOP_named(OP_METHOD_NAMED, 0, meth)
6350                        ));
6351     }
6352
6353     /* Fake up the BEGIN {}, which does its thing immediately. */
6354     newATTRSUB(floor,
6355         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
6356         NULL,
6357         NULL,
6358         op_append_elem(OP_LINESEQ,
6359             op_append_elem(OP_LINESEQ,
6360                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
6361                 newSTATEOP(0, NULL, veop)),
6362             newSTATEOP(0, NULL, imop) ));
6363
6364     if (use_version) {
6365         /* Enable the
6366          * feature bundle that corresponds to the required version. */
6367         use_version = sv_2mortal(new_version(use_version));
6368         S_enable_feature_bundle(aTHX_ use_version);
6369
6370         /* If a version >= 5.11.0 is requested, strictures are on by default! */
6371         if (vcmp(use_version,
6372                  sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
6373             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
6374                 PL_hints |= HINT_STRICT_REFS;
6375             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
6376                 PL_hints |= HINT_STRICT_SUBS;
6377             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
6378                 PL_hints |= HINT_STRICT_VARS;
6379         }
6380         /* otherwise they are off */
6381         else {
6382             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
6383                 PL_hints &= ~HINT_STRICT_REFS;
6384             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
6385                 PL_hints &= ~HINT_STRICT_SUBS;
6386             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
6387                 PL_hints &= ~HINT_STRICT_VARS;
6388         }
6389     }
6390
6391     /* The "did you use incorrect case?" warning used to be here.
6392      * The problem is that on case-insensitive filesystems one
6393      * might get false positives for "use" (and "require"):
6394      * "use Strict" or "require CARP" will work.  This causes
6395      * portability problems for the script: in case-strict
6396      * filesystems the script will stop working.
6397      *
6398      * The "incorrect case" warning checked whether "use Foo"
6399      * imported "Foo" to your namespace, but that is wrong, too:
6400      * there is no requirement nor promise in the language that
6401      * a Foo.pm should or would contain anything in package "Foo".
6402      *
6403      * There is very little Configure-wise that can be done, either:
6404      * the case-sensitivity of the build filesystem of Perl does not
6405      * help in guessing the case-sensitivity of the runtime environment.
6406      */
6407
6408     PL_hints |= HINT_BLOCK_SCOPE;
6409     PL_parser->copline = NOLINE;
6410     COP_SEQMAX_INC; /* Purely for B::*'s benefit */
6411 }
6412
6413 /*
6414 =head1 Embedding Functions
6415
6416 =for apidoc load_module
6417
6418 Loads the module whose name is pointed to by the string part of C<name>.
6419 Note that the actual module name, not its filename, should be given.
6420 Eg, "Foo::Bar" instead of "Foo/Bar.pm". ver, if specified and not NULL,
6421 provides version semantics similar to C<use Foo::Bar VERSION>. The optional
6422 trailing arguments can be used to specify arguments to the module's C<import()>
6423 method, similar to C<use Foo::Bar VERSION LIST>; their precise handling depends
6424 on the flags. The flags argument is a bitwise-ORed collection of any of
6425 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
6426 (or 0 for no flags).
6427
6428 If C<PERL_LOADMOD_NOIMPORT> is set, the module is loaded as if with an empty
6429 import list, as in C<use Foo::Bar ()>; this is the only circumstance in which
6430 the trailing optional arguments may be omitted entirely. Otherwise, if
6431 C<PERL_LOADMOD_IMPORT_OPS> is set, the trailing arguments must consist of
6432 exactly one C<OP*>, containing the op tree that produces the relevant import
6433 arguments. Otherwise, the trailing arguments must all be C<SV*> values that
6434 will be used as import arguments; and the list must be terminated with C<(SV*)
6435 NULL>. If neither C<PERL_LOADMOD_NOIMPORT> nor C<PERL_LOADMOD_IMPORT_OPS> is
6436 set, the trailing C<NULL> pointer is needed even if no import arguments are
6437 desired. The reference count for each specified C<SV*> argument is
6438 decremented. In addition, the C<name> argument is modified.
6439
6440 If C<PERL_LOADMOD_DENY> is set, the module is loaded as if with C<no> rather
6441 than C<use>.
6442
6443 =cut */
6444
6445 void
6446 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
6447 {
6448     va_list args;
6449
6450     PERL_ARGS_ASSERT_LOAD_MODULE;
6451
6452     va_start(args, ver);
6453     vload_module(flags, name, ver, &args);
6454     va_end(args);
6455 }
6456
6457 #ifdef PERL_IMPLICIT_CONTEXT
6458 void
6459 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
6460 {
6461     dTHX;
6462     va_list args;
6463     PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
6464     va_start(args, ver);
6465     vload_module(flags, name, ver, &args);
6466     va_end(args);
6467 }
6468 #endif
6469
6470 void
6471 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
6472 {
6473     OP *veop, *imop;
6474     OP * const modname = newSVOP(OP_CONST, 0, name);
6475
6476     PERL_ARGS_ASSERT_VLOAD_MODULE;
6477
6478     modname->op_private |= OPpCONST_BARE;
6479     if (ver) {
6480         veop = newSVOP(OP_CONST, 0, ver);
6481     }
6482     else
6483         veop = NULL;
6484     if (flags & PERL_LOADMOD_NOIMPORT) {
6485         imop = sawparens(newNULLLIST());
6486     }
6487     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
6488         imop = va_arg(*args, OP*);
6489     }
6490     else {
6491         SV *sv;
6492         imop = NULL;
6493         sv = va_arg(*args, SV*);
6494         while (sv) {
6495             imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
6496             sv = va_arg(*args, SV*);
6497         }
6498     }
6499
6500     /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
6501      * that it has a PL_parser to play with while doing that, and also
6502      * that it doesn't mess with any existing parser, by creating a tmp
6503      * new parser with lex_start(). This won't actually be used for much,
6504      * since pp_require() will create another parser for the real work.
6505      * The ENTER/LEAVE pair protect callers from any side effects of use.  */
6506
6507     ENTER;
6508     SAVEVPTR(PL_curcop);
6509     lex_start(NULL, NULL, LEX_START_SAME_FILTER);
6510     utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
6511             veop, modname, imop);
6512     LEAVE;
6513 }
6514
6515 PERL_STATIC_INLINE OP *
6516 S_new_entersubop(pTHX_ GV *gv, OP *arg)
6517 {
6518     return newUNOP(OP_ENTERSUB, OPf_STACKED,
6519                    newLISTOP(OP_LIST, 0, arg,
6520                              newUNOP(OP_RV2CV, 0,
6521                                      newGVOP(OP_GV, 0, gv))));
6522 }
6523
6524 OP *
6525 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
6526 {
6527     OP *doop;
6528     GV *gv;
6529
6530     PERL_ARGS_ASSERT_DOFILE;
6531
6532     if (!force_builtin && (gv = gv_override("do", 2))) {
6533         doop = S_new_entersubop(aTHX_ gv, term);
6534     }
6535     else {
6536         doop = newUNOP(OP_DOFILE, 0, scalar(term));
6537     }
6538     return doop;
6539 }
6540
6541 /*
6542 =head1 Optree construction
6543
6544 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
6545
6546 Constructs, checks, and returns an C<lslice> (list slice) op.  C<flags>
6547 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
6548 be set automatically, and, shifted up eight bits, the eight bits of
6549 C<op_private>, except that the bit with value 1 or 2 is automatically
6550 set as required.  C<listval> and C<subscript> supply the parameters of
6551 the slice; they are consumed by this function and become part of the
6552 constructed op tree.
6553
6554 =cut
6555 */
6556
6557 OP *
6558 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
6559 {
6560     return newBINOP(OP_LSLICE, flags,
6561             list(force_list(subscript, 1)),
6562             list(force_list(listval,   1)) );
6563 }
6564
6565 #define ASSIGN_LIST   1
6566 #define ASSIGN_REF    2
6567
6568 STATIC I32
6569 S_assignment_type(pTHX_ const OP *o)
6570 {
6571     unsigned type;
6572     U8 flags;
6573     U8 ret;
6574
6575     if (!o)
6576         return TRUE;
6577
6578     if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
6579         o = cUNOPo->op_first;
6580
6581     flags = o->op_flags;
6582     type = o->op_type;
6583     if (type == OP_COND_EXPR) {
6584         OP * const sib = OpSIBLING(cLOGOPo->op_first);
6585         const I32 t = assignment_type(sib);
6586         const I32 f = assignment_type(OpSIBLING(sib));
6587
6588         if (t == ASSIGN_LIST && f == ASSIGN_LIST)
6589             return ASSIGN_LIST;
6590         if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
6591             yyerror("Assignment to both a list and a scalar");
6592         return FALSE;
6593     }
6594
6595     if (type == OP_SREFGEN)
6596     {
6597         OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
6598         type = kid->op_type;
6599         flags |= kid->op_flags;
6600         if (!(flags & OPf_PARENS)
6601           && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
6602               kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
6603             return ASSIGN_REF;
6604         ret = ASSIGN_REF;
6605     }
6606     else ret = 0;
6607
6608     if (type == OP_LIST &&
6609         (flags & OPf_WANT) == OPf_WANT_SCALAR &&
6610         o->op_private & OPpLVAL_INTRO)
6611         return ret;
6612
6613     if (type == OP_LIST || flags & OPf_PARENS ||
6614         type == OP_RV2AV || type == OP_RV2HV ||
6615         type == OP_ASLICE || type == OP_HSLICE ||
6616         type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
6617         return TRUE;
6618
6619     if (type == OP_PADAV || type == OP_PADHV)
6620         return TRUE;
6621
6622     if (type == OP_RV2SV)
6623         return ret;
6624
6625     return ret;
6626 }
6627
6628
6629 /*
6630 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
6631
6632 Constructs, checks, and returns an assignment op.  C<left> and C<right>
6633 supply the parameters of the assignment; they are consumed by this
6634 function and become part of the constructed op tree.
6635
6636 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
6637 a suitable conditional optree is constructed.  If C<optype> is the opcode
6638 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
6639 performs the binary operation and assigns the result to the left argument.
6640 Either way, if C<optype> is non-zero then C<flags> has no effect.
6641
6642 If C<optype> is zero, then a plain scalar or list assignment is
6643 constructed.  Which type of assignment it is is automatically determined.
6644 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6645 will be set automatically, and, shifted up eight bits, the eight bits
6646 of C<op_private>, except that the bit with value 1 or 2 is automatically
6647 set as required.
6648
6649 =cut
6650 */
6651
6652 OP *
6653 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
6654 {
6655     OP *o;
6656     I32 assign_type;
6657
6658     if (optype) {
6659         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
6660             right = scalar(right);
6661             return newLOGOP(optype, 0,
6662                 op_lvalue(scalar(left), optype),
6663                 newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right));
6664         }
6665         else {
6666             return newBINOP(optype, OPf_STACKED,
6667                 op_lvalue(scalar(left), optype), scalar(right));
6668         }
6669     }
6670
6671     if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
6672         static const char no_list_state[] = "Initialization of state variables"
6673             " in list context currently forbidden";
6674         OP *curop;
6675
6676         if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
6677             left->op_private &= ~ OPpSLICEWARNING;
6678
6679         PL_modcount = 0;
6680         left = op_lvalue(left, OP_AASSIGN);
6681         curop = list(force_list(left, 1));
6682         o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
6683         o->op_private = (U8)(0 | (flags >> 8));
6684
6685         if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
6686         {
6687             OP* lop = ((LISTOP*)left)->op_first;
6688             while (lop) {
6689                 if ((lop->op_type == OP_PADSV ||
6690                      lop->op_type == OP_PADAV ||
6691                      lop->op_type == OP_PADHV ||
6692                      lop->op_type == OP_PADANY)
6693                   && (lop->op_private & OPpPAD_STATE)
6694                 )
6695                     yyerror(no_list_state);
6696                 lop = OpSIBLING(lop);
6697             }
6698         }
6699         else if (  (left->op_private & OPpLVAL_INTRO)
6700                 && (left->op_private & OPpPAD_STATE)
6701                 && (   left->op_type == OP_PADSV
6702                     || left->op_type == OP_PADAV
6703                     || left->op_type == OP_PADHV
6704                     || left->op_type == OP_PADANY)
6705         ) {
6706                 /* All single variable list context state assignments, hence
6707                    state ($a) = ...
6708                    (state $a) = ...
6709                    state @a = ...
6710                    state (@a) = ...
6711                    (state @a) = ...
6712                    state %a = ...
6713                    state (%a) = ...
6714                    (state %a) = ...
6715                 */
6716                 yyerror(no_list_state);
6717         }
6718
6719         /* optimise @a = split(...) into:
6720         * @{expr}:              split(..., @{expr}) (where @a is not flattened)
6721         * @a, my @a, local @a:  split(...)          (where @a is attached to
6722         *                                            the split op itself)
6723         */
6724
6725         if (   right
6726             && right->op_type == OP_SPLIT
6727             /* don't do twice, e.g. @b = (@a = split) */
6728             && !(right->op_private & OPpSPLIT_ASSIGN))
6729         {
6730             OP *gvop = NULL;
6731
6732             if (   (  left->op_type == OP_RV2AV
6733                    && (gvop=((UNOP*)left)->op_first)->op_type==OP_GV)
6734                 || left->op_type == OP_PADAV)
6735             {
6736                 /* @pkg or @lex or local @pkg' or 'my @lex' */
6737                 OP *tmpop;
6738                 if (gvop) {
6739 #ifdef USE_ITHREADS
6740                     ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff
6741                         = cPADOPx(gvop)->op_padix;
6742                     cPADOPx(gvop)->op_padix = 0;        /* steal it */
6743 #else
6744                     ((PMOP*)right)->op_pmreplrootu.op_pmtargetgv
6745                         = MUTABLE_GV(cSVOPx(gvop)->op_sv);
6746                     cSVOPx(gvop)->op_sv = NULL; /* steal it */
6747 #endif
6748                     right->op_private |=
6749                         left->op_private & OPpOUR_INTRO;
6750                 }
6751                 else {
6752                     ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff = left->op_targ;
6753                     left->op_targ = 0;  /* steal it */
6754                     right->op_private |= OPpSPLIT_LEX;
6755                 }
6756                 right->op_private |= left->op_private & OPpLVAL_INTRO;
6757
6758               detach_split:
6759                 tmpop = cUNOPo->op_first;       /* to list (nulled) */
6760                 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
6761                 assert(OpSIBLING(tmpop) == right);
6762                 assert(!OpHAS_SIBLING(right));
6763                 /* detach the split subtreee from the o tree,
6764                  * then free the residual o tree */
6765                 op_sibling_splice(cUNOPo->op_first, tmpop, 1, NULL);
6766                 op_free(o);                     /* blow off assign */
6767                 right->op_private |= OPpSPLIT_ASSIGN;
6768                 right->op_flags &= ~OPf_WANT;
6769                         /* "I don't know and I don't care." */
6770                 return right;
6771             }
6772             else if (left->op_type == OP_RV2AV) {
6773                 /* @{expr} */
6774
6775                 OP *pushop = cUNOPx(cBINOPo->op_last)->op_first;
6776                 assert(OpSIBLING(pushop) == left);
6777                 /* Detach the array ...  */
6778                 op_sibling_splice(cBINOPo->op_last, pushop, 1, NULL);
6779                 /* ... and attach it to the split.  */
6780                 op_sibling_splice(right, cLISTOPx(right)->op_last,
6781                                   0, left);
6782                 right->op_flags |= OPf_STACKED;
6783                 /* Detach split and expunge aassign as above.  */
6784                 goto detach_split;
6785             }
6786             else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
6787                     ((LISTOP*)right)->op_last->op_type == OP_CONST)
6788             {
6789                 /* convert split(...,0) to split(..., PL_modcount+1) */
6790                 SV ** const svp =
6791                     &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
6792                 SV * const sv = *svp;
6793                 if (SvIOK(sv) && SvIVX(sv) == 0)
6794                 {
6795                   if (right->op_private & OPpSPLIT_IMPLIM) {
6796                     /* our own SV, created in ck_split */
6797                     SvREADONLY_off(sv);
6798                     sv_setiv(sv, PL_modcount+1);
6799                   }
6800                   else {
6801                     /* SV may belong to someone else */
6802                     SvREFCNT_dec(sv);
6803                     *svp = newSViv(PL_modcount+1);
6804                   }
6805                 }
6806             }
6807         }
6808         return o;
6809     }
6810     if (assign_type == ASSIGN_REF)
6811         return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
6812     if (!right)
6813         right = newOP(OP_UNDEF, 0);
6814     if (right->op_type == OP_READLINE) {
6815         right->op_flags |= OPf_STACKED;
6816         return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
6817                 scalar(right));
6818     }
6819     else {
6820         o = newBINOP(OP_SASSIGN, flags,
6821             scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
6822     }
6823     return o;
6824 }
6825
6826 /*
6827 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
6828
6829 Constructs a state op (COP).  The state op is normally a C<nextstate> op,
6830 but will be a C<dbstate> op if debugging is enabled for currently-compiled
6831 code.  The state op is populated from C<PL_curcop> (or C<PL_compiling>).
6832 If C<label> is non-null, it supplies the name of a label to attach to
6833 the state op; this function takes ownership of the memory pointed at by
6834 C<label>, and will free it.  C<flags> gives the eight bits of C<op_flags>
6835 for the state op.
6836
6837 If C<o> is null, the state op is returned.  Otherwise the state op is
6838 combined with C<o> into a C<lineseq> list op, which is returned.  C<o>
6839 is consumed by this function and becomes part of the returned op tree.
6840
6841 =cut
6842 */
6843
6844 OP *
6845 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
6846 {
6847     dVAR;
6848     const U32 seq = intro_my();
6849     const U32 utf8 = flags & SVf_UTF8;
6850     COP *cop;
6851
6852     PL_parser->parsed_sub = 0;
6853
6854     flags &= ~SVf_UTF8;
6855
6856     NewOp(1101, cop, 1, COP);
6857     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
6858         OpTYPE_set(cop, OP_DBSTATE);
6859     }
6860     else {
6861         OpTYPE_set(cop, OP_NEXTSTATE);
6862     }
6863     cop->op_flags = (U8)flags;
6864     CopHINTS_set(cop, PL_hints);
6865 #ifdef VMS
6866     if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
6867 #endif
6868     cop->op_next = (OP*)cop;
6869
6870     cop->cop_seq = seq;
6871     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
6872     CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
6873     if (label) {
6874         Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
6875
6876         PL_hints |= HINT_BLOCK_SCOPE;
6877         /* It seems that we need to defer freeing this pointer, as other parts
6878            of the grammar end up wanting to copy it after this op has been
6879            created. */
6880         SAVEFREEPV(label);
6881     }
6882
6883     if (PL_parser->preambling != NOLINE) {
6884         CopLINE_set(cop, PL_parser->preambling);
6885         PL_parser->copline = NOLINE;
6886     }
6887     else if (PL_parser->copline == NOLINE)
6888         CopLINE_set(cop, CopLINE(PL_curcop));
6889     else {
6890         CopLINE_set(cop, PL_parser->copline);
6891         PL_parser->copline = NOLINE;
6892     }
6893 #ifdef USE_ITHREADS
6894     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
6895 #else
6896     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
6897 #endif
6898     CopSTASH_set(cop, PL_curstash);
6899
6900     if (cop->op_type == OP_DBSTATE) {
6901         /* this line can have a breakpoint - store the cop in IV */
6902         AV *av = CopFILEAVx(PL_curcop);
6903         if (av) {
6904             SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
6905             if (svp && *svp != &PL_sv_undef ) {
6906                 (void)SvIOK_on(*svp);
6907                 SvIV_set(*svp, PTR2IV(cop));
6908             }
6909         }
6910     }
6911
6912     if (flags & OPf_SPECIAL)
6913         op_null((OP*)cop);
6914     return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
6915 }
6916
6917 /*
6918 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
6919
6920 Constructs, checks, and returns a logical (flow control) op.  C<type>
6921 is the opcode.  C<flags> gives the eight bits of C<op_flags>, except
6922 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6923 the eight bits of C<op_private>, except that the bit with value 1 is
6924 automatically set.  C<first> supplies the expression controlling the
6925 flow, and C<other> supplies the side (alternate) chain of ops; they are
6926 consumed by this function and become part of the constructed op tree.
6927
6928 =cut
6929 */
6930
6931 OP *
6932 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
6933 {
6934     PERL_ARGS_ASSERT_NEWLOGOP;
6935
6936     return new_logop(type, flags, &first, &other);
6937 }
6938
6939 STATIC OP *
6940 S_search_const(pTHX_ OP *o)
6941 {
6942     PERL_ARGS_ASSERT_SEARCH_CONST;
6943
6944     switch (o->op_type) {
6945         case OP_CONST:
6946             return o;
6947         case OP_NULL:
6948             if (o->op_flags & OPf_KIDS)
6949                 return search_const(cUNOPo->op_first);
6950             break;
6951         case OP_LEAVE:
6952         case OP_SCOPE:
6953         case OP_LINESEQ:
6954         {
6955             OP *kid;
6956             if (!(o->op_flags & OPf_KIDS))
6957                 return NULL;
6958             kid = cLISTOPo->op_first;
6959             do {
6960                 switch (kid->op_type) {
6961                     case OP_ENTER:
6962                     case OP_NULL:
6963                     case OP_NEXTSTATE:
6964                         kid = OpSIBLING(kid);
6965                         break;
6966                     default:
6967                         if (kid != cLISTOPo->op_last)
6968                             return NULL;
6969                         goto last;
6970                 }
6971             } while (kid);
6972             if (!kid)
6973                 kid = cLISTOPo->op_last;
6974           last:
6975             return search_const(kid);
6976         }
6977     }
6978
6979     return NULL;
6980 }
6981
6982 STATIC OP *
6983 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
6984 {
6985     dVAR;
6986     LOGOP *logop;
6987     OP *o;
6988     OP *first;
6989     OP *other;
6990     OP *cstop = NULL;
6991     int prepend_not = 0;
6992
6993     PERL_ARGS_ASSERT_NEW_LOGOP;
6994
6995     first = *firstp;
6996     other = *otherp;
6997
6998     /* [perl #59802]: Warn about things like "return $a or $b", which
6999        is parsed as "(return $a) or $b" rather than "return ($a or
7000        $b)".  NB: This also applies to xor, which is why we do it
7001        here.
7002      */
7003     switch (first->op_type) {
7004     case OP_NEXT:
7005     case OP_LAST:
7006     case OP_REDO:
7007         /* XXX: Perhaps we should emit a stronger warning for these.
7008            Even with the high-precedence operator they don't seem to do
7009            anything sensible.
7010
7011            But until we do, fall through here.
7012          */
7013     case OP_RETURN:
7014     case OP_EXIT:
7015     case OP_DIE:
7016     case OP_GOTO:
7017         /* XXX: Currently we allow people to "shoot themselves in the
7018            foot" by explicitly writing "(return $a) or $b".
7019
7020            Warn unless we are looking at the result from folding or if
7021            the programmer explicitly grouped the operators like this.
7022            The former can occur with e.g.
7023
7024                 use constant FEATURE => ( $] >= ... );
7025                 sub { not FEATURE and return or do_stuff(); }
7026          */
7027         if (!first->op_folded && !(first->op_flags & OPf_PARENS))
7028             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
7029                            "Possible precedence issue with control flow operator");
7030         /* XXX: Should we optimze this to "return $a;" (i.e. remove
7031            the "or $b" part)?
7032         */
7033         break;
7034     }
7035
7036     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
7037         return newBINOP(type, flags, scalar(first), scalar(other));
7038
7039     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
7040         || type == OP_CUSTOM);
7041
7042     scalarboolean(first);
7043
7044     /* search for a constant op that could let us fold the test */
7045     if ((cstop = search_const(first))) {
7046         if (cstop->op_private & OPpCONST_STRICT)
7047             no_bareword_allowed(cstop);
7048         else if ((cstop->op_private & OPpCONST_BARE))
7049                 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
7050         if ((type == OP_AND &&  SvTRUE(((SVOP*)cstop)->op_sv)) ||
7051             (type == OP_OR  && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
7052             (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
7053             /* Elide the (constant) lhs, since it can't affect the outcome */
7054             *firstp = NULL;
7055             if (other->op_type == OP_CONST)
7056                 other->op_private |= OPpCONST_SHORTCIRCUIT;
7057             op_free(first);
7058             if (other->op_type == OP_LEAVE)
7059                 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
7060             else if (other->op_type == OP_MATCH
7061                   || other->op_type == OP_SUBST
7062                   || other->op_type == OP_TRANSR
7063                   || other->op_type == OP_TRANS)
7064                 /* Mark the op as being unbindable with =~ */
7065                 other->op_flags |= OPf_SPECIAL;
7066
7067             other->op_folded = 1;
7068             return other;
7069         }
7070         else {
7071             /* Elide the rhs, since the outcome is entirely determined by
7072              * the (constant) lhs */
7073
7074             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
7075             const OP *o2 = other;
7076             if ( ! (o2->op_type == OP_LIST
7077                     && (( o2 = cUNOPx(o2)->op_first))
7078                     && o2->op_type == OP_PUSHMARK
7079                     && (( o2 = OpSIBLING(o2))) )
7080             )
7081                 o2 = other;
7082             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
7083                         || o2->op_type == OP_PADHV)
7084                 && o2->op_private & OPpLVAL_INTRO
7085                 && !(o2->op_private & OPpPAD_STATE))
7086             {
7087                 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7088                                 "Deprecated use of my() in false conditional. "
7089                                 "This will be a fatal error in Perl 5.30");
7090             }
7091
7092             *otherp = NULL;
7093             if (cstop->op_type == OP_CONST)
7094                 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
7095             op_free(other);
7096             return first;
7097         }
7098     }
7099     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
7100         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
7101     {
7102         const OP * const k1 = ((UNOP*)first)->op_first;
7103         const OP * const k2 = OpSIBLING(k1);
7104         OPCODE warnop = 0;
7105         switch (first->op_type)
7106         {
7107         case OP_NULL:
7108             if (k2 && k2->op_type == OP_READLINE
7109                   && (k2->op_flags & OPf_STACKED)
7110                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7111             {
7112                 warnop = k2->op_type;
7113             }
7114             break;
7115
7116         case OP_SASSIGN:
7117             if (k1->op_type == OP_READDIR
7118                   || k1->op_type == OP_GLOB
7119                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7120                  || k1->op_type == OP_EACH
7121                  || k1->op_type == OP_AEACH)
7122             {
7123                 warnop = ((k1->op_type == OP_NULL)
7124                           ? (OPCODE)k1->op_targ : k1->op_type);
7125             }
7126             break;
7127         }
7128         if (warnop) {
7129             const line_t oldline = CopLINE(PL_curcop);
7130             /* This ensures that warnings are reported at the first line
7131                of the construction, not the last.  */
7132             CopLINE_set(PL_curcop, PL_parser->copline);
7133             Perl_warner(aTHX_ packWARN(WARN_MISC),
7134                  "Value of %s%s can be \"0\"; test with defined()",
7135                  PL_op_desc[warnop],
7136                  ((warnop == OP_READLINE || warnop == OP_GLOB)
7137                   ? " construct" : "() operator"));
7138             CopLINE_set(PL_curcop, oldline);
7139         }
7140     }
7141
7142     /* optimize AND and OR ops that have NOTs as children */
7143     if (first->op_type == OP_NOT
7144         && (first->op_flags & OPf_KIDS)
7145         && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
7146             || (other->op_type == OP_NOT))  /* if (!$x && !$y) { } */
7147         ) {
7148         if (type == OP_AND || type == OP_OR) {
7149             if (type == OP_AND)
7150                 type = OP_OR;
7151             else
7152                 type = OP_AND;
7153             op_null(first);
7154             if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
7155                 op_null(other);
7156                 prepend_not = 1; /* prepend a NOT op later */
7157             }
7158         }
7159     }
7160
7161     logop = alloc_LOGOP(type, first, LINKLIST(other));
7162     logop->op_flags |= (U8)flags;
7163     logop->op_private = (U8)(1 | (flags >> 8));
7164
7165     /* establish postfix order */
7166     logop->op_next = LINKLIST(first);
7167     first->op_next = (OP*)logop;
7168     assert(!OpHAS_SIBLING(first));
7169     op_sibling_splice((OP*)logop, first, 0, other);
7170
7171     CHECKOP(type,logop);
7172
7173     o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
7174                 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
7175                 (OP*)logop);
7176     other->op_next = o;
7177
7178     return o;
7179 }
7180
7181 /*
7182 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
7183
7184 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
7185 op.  C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
7186 will be set automatically, and, shifted up eight bits, the eight bits of
7187 C<op_private>, except that the bit with value 1 is automatically set.
7188 C<first> supplies the expression selecting between the two branches,
7189 and C<trueop> and C<falseop> supply the branches; they are consumed by
7190 this function and become part of the constructed op tree.
7191
7192 =cut
7193 */
7194
7195 OP *
7196 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
7197 {
7198     dVAR;
7199     LOGOP *logop;
7200     OP *start;
7201     OP *o;
7202     OP *cstop;
7203
7204     PERL_ARGS_ASSERT_NEWCONDOP;
7205
7206     if (!falseop)
7207         return newLOGOP(OP_AND, 0, first, trueop);
7208     if (!trueop)
7209         return newLOGOP(OP_OR, 0, first, falseop);
7210
7211     scalarboolean(first);
7212     if ((cstop = search_const(first))) {
7213         /* Left or right arm of the conditional?  */
7214         const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
7215         OP *live = left ? trueop : falseop;
7216         OP *const dead = left ? falseop : trueop;
7217         if (cstop->op_private & OPpCONST_BARE &&
7218             cstop->op_private & OPpCONST_STRICT) {
7219             no_bareword_allowed(cstop);
7220         }
7221         op_free(first);
7222         op_free(dead);
7223         if (live->op_type == OP_LEAVE)
7224             live = newUNOP(OP_NULL, OPf_SPECIAL, live);
7225         else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
7226               || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
7227             /* Mark the op as being unbindable with =~ */
7228             live->op_flags |= OPf_SPECIAL;
7229         live->op_folded = 1;
7230         return live;
7231     }
7232     logop = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop));
7233     logop->op_flags |= (U8)flags;
7234     logop->op_private = (U8)(1 | (flags >> 8));
7235     logop->op_next = LINKLIST(falseop);
7236
7237     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
7238             logop);
7239
7240     /* establish postfix order */
7241     start = LINKLIST(first);
7242     first->op_next = (OP*)logop;
7243
7244     /* make first, trueop, falseop siblings */
7245     op_sibling_splice((OP*)logop, first,  0, trueop);
7246     op_sibling_splice((OP*)logop, trueop, 0, falseop);
7247
7248     o = newUNOP(OP_NULL, 0, (OP*)logop);
7249
7250     trueop->op_next = falseop->op_next = o;
7251
7252     o->op_next = start;
7253     return o;
7254 }
7255
7256 /*
7257 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
7258
7259 Constructs and returns a C<range> op, with subordinate C<flip> and
7260 C<flop> ops.  C<flags> gives the eight bits of C<op_flags> for the
7261 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
7262 for both the C<flip> and C<range> ops, except that the bit with value
7263 1 is automatically set.  C<left> and C<right> supply the expressions
7264 controlling the endpoints of the range; they are consumed by this function
7265 and become part of the constructed op tree.
7266
7267 =cut
7268 */
7269
7270 OP *
7271 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
7272 {
7273     LOGOP *range;
7274     OP *flip;
7275     OP *flop;
7276     OP *leftstart;
7277     OP *o;
7278
7279     PERL_ARGS_ASSERT_NEWRANGE;
7280
7281     range = alloc_LOGOP(OP_RANGE, left, LINKLIST(right));
7282     range->op_flags = OPf_KIDS;
7283     leftstart = LINKLIST(left);
7284     range->op_private = (U8)(1 | (flags >> 8));
7285
7286     /* make left and right siblings */
7287     op_sibling_splice((OP*)range, left, 0, right);
7288
7289     range->op_next = (OP*)range;
7290     flip = newUNOP(OP_FLIP, flags, (OP*)range);
7291     flop = newUNOP(OP_FLOP, 0, flip);
7292     o = newUNOP(OP_NULL, 0, flop);
7293     LINKLIST(flop);
7294     range->op_next = leftstart;
7295
7296     left->op_next = flip;
7297     right->op_next = flop;
7298
7299     range->op_targ =
7300         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
7301     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
7302     flip->op_targ =
7303         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
7304     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
7305     SvPADTMP_on(PAD_SV(flip->op_targ));
7306
7307     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
7308     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
7309
7310     /* check barewords before they might be optimized aways */
7311     if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
7312         no_bareword_allowed(left);
7313     if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
7314         no_bareword_allowed(right);
7315
7316     flip->op_next = o;
7317     if (!flip->op_private || !flop->op_private)
7318         LINKLIST(o);            /* blow off optimizer unless constant */
7319
7320     return o;
7321 }
7322
7323 /*
7324 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
7325
7326 Constructs, checks, and returns an op tree expressing a loop.  This is
7327 only a loop in the control flow through the op tree; it does not have
7328 the heavyweight loop structure that allows exiting the loop by C<last>
7329 and suchlike.  C<flags> gives the eight bits of C<op_flags> for the
7330 top-level op, except that some bits will be set automatically as required.
7331 C<expr> supplies the expression controlling loop iteration, and C<block>
7332 supplies the body of the loop; they are consumed by this function and
7333 become part of the constructed op tree.  C<debuggable> is currently
7334 unused and should always be 1.
7335
7336 =cut
7337 */
7338
7339 OP *
7340 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
7341 {
7342     OP* listop;
7343     OP* o;
7344     const bool once = block && block->op_flags & OPf_SPECIAL &&
7345                       block->op_type == OP_NULL;
7346
7347     PERL_UNUSED_ARG(debuggable);
7348
7349     if (expr) {
7350         if (once && (
7351               (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
7352            || (  expr->op_type == OP_NOT
7353               && cUNOPx(expr)->op_first->op_type == OP_CONST
7354               && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
7355               )
7356            ))
7357             /* Return the block now, so that S_new_logop does not try to
7358                fold it away. */
7359             return block;       /* do {} while 0 does once */
7360         if (expr->op_type == OP_READLINE
7361             || expr->op_type == OP_READDIR
7362             || expr->op_type == OP_GLOB
7363             || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
7364             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
7365             expr = newUNOP(OP_DEFINED, 0,
7366                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
7367         } else if (expr->op_flags & OPf_KIDS) {
7368             const OP * const k1 = ((UNOP*)expr)->op_first;
7369             const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
7370             switch (expr->op_type) {
7371               case OP_NULL:
7372                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
7373                       && (k2->op_flags & OPf_STACKED)
7374                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7375                     expr = newUNOP(OP_DEFINED, 0, expr);
7376                 break;
7377
7378               case OP_SASSIGN:
7379                 if (k1 && (k1->op_type == OP_READDIR
7380                       || k1->op_type == OP_GLOB
7381                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7382                      || k1->op_type == OP_EACH
7383                      || k1->op_type == OP_AEACH))
7384                     expr = newUNOP(OP_DEFINED, 0, expr);
7385                 break;
7386             }
7387         }
7388     }
7389
7390     /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
7391      * op, in listop. This is wrong. [perl #27024] */
7392     if (!block)
7393         block = newOP(OP_NULL, 0);
7394     listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
7395     o = new_logop(OP_AND, 0, &expr, &listop);
7396
7397     if (once) {
7398         ASSUME(listop);
7399     }
7400
7401     if (listop)
7402         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
7403
7404     if (once && o != listop)
7405     {
7406         assert(cUNOPo->op_first->op_type == OP_AND
7407             || cUNOPo->op_first->op_type == OP_OR);
7408         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
7409     }
7410
7411     if (o == listop)
7412         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
7413
7414     o->op_flags |= flags;
7415     o = op_scope(o);
7416     o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
7417     return o;
7418 }
7419
7420 /*
7421 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
7422
7423 Constructs, checks, and returns an op tree expressing a C<while> loop.
7424 This is a heavyweight loop, with structure that allows exiting the loop
7425 by C<last> and suchlike.
7426
7427 C<loop> is an optional preconstructed C<enterloop> op to use in the
7428 loop; if it is null then a suitable op will be constructed automatically.
7429 C<expr> supplies the loop's controlling expression.  C<block> supplies the
7430 main body of the loop, and C<cont> optionally supplies a C<continue> block
7431 that operates as a second half of the body.  All of these optree inputs
7432 are consumed by this function and become part of the constructed op tree.
7433
7434 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7435 op and, shifted up eight bits, the eight bits of C<op_private> for
7436 the C<leaveloop> op, except that (in both cases) some bits will be set
7437 automatically.  C<debuggable> is currently unused and should always be 1.
7438 C<has_my> can be supplied as true to force the
7439 loop body to be enclosed in its own scope.
7440
7441 =cut
7442 */
7443
7444 OP *
7445 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
7446         OP *expr, OP *block, OP *cont, I32 has_my)
7447 {
7448     dVAR;
7449     OP *redo;
7450     OP *next = NULL;
7451     OP *listop;
7452     OP *o;
7453     U8 loopflags = 0;
7454
7455     PERL_UNUSED_ARG(debuggable);
7456
7457     if (expr) {
7458         if (expr->op_type == OP_READLINE
7459          || expr->op_type == OP_READDIR
7460          || expr->op_type == OP_GLOB
7461          || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
7462                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
7463             expr = newUNOP(OP_DEFINED, 0,
7464                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
7465         } else if (expr->op_flags & OPf_KIDS) {
7466             const OP * const k1 = ((UNOP*)expr)->op_first;
7467             const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
7468             switch (expr->op_type) {
7469               case OP_NULL:
7470                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
7471                       && (k2->op_flags & OPf_STACKED)
7472                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7473                     expr = newUNOP(OP_DEFINED, 0, expr);
7474                 break;
7475
7476               case OP_SASSIGN:
7477                 if (k1 && (k1->op_type == OP_READDIR
7478                       || k1->op_type == OP_GLOB
7479                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7480                      || k1->op_type == OP_EACH
7481                      || k1->op_type == OP_AEACH))
7482                     expr = newUNOP(OP_DEFINED, 0, expr);
7483                 break;
7484             }
7485         }
7486     }
7487
7488     if (!block)
7489         block = newOP(OP_NULL, 0);
7490     else if (cont || has_my) {
7491         block = op_scope(block);
7492     }
7493
7494     if (cont) {
7495         next = LINKLIST(cont);
7496     }
7497     if (expr) {
7498         OP * const unstack = newOP(OP_UNSTACK, 0);
7499         if (!next)
7500             next = unstack;
7501         cont = op_append_elem(OP_LINESEQ, cont, unstack);
7502     }
7503
7504     assert(block);
7505     listop = op_append_list(OP_LINESEQ, block, cont);
7506     assert(listop);
7507     redo = LINKLIST(listop);
7508
7509     if (expr) {
7510         scalar(listop);
7511         o = new_logop(OP_AND, 0, &expr, &listop);
7512         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
7513             op_free((OP*)loop);
7514             return expr;                /* listop already freed by new_logop */
7515         }
7516         if (listop)
7517             ((LISTOP*)listop)->op_last->op_next =
7518                 (o == listop ? redo : LINKLIST(o));
7519     }
7520     else
7521         o = listop;
7522
7523     if (!loop) {
7524         NewOp(1101,loop,1,LOOP);
7525         OpTYPE_set(loop, OP_ENTERLOOP);
7526         loop->op_private = 0;
7527         loop->op_next = (OP*)loop;
7528     }
7529
7530     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
7531
7532     loop->op_redoop = redo;
7533     loop->op_lastop = o;
7534     o->op_private |= loopflags;
7535
7536     if (next)
7537         loop->op_nextop = next;
7538     else
7539         loop->op_nextop = o;
7540
7541     o->op_flags |= flags;
7542     o->op_private |= (flags >> 8);
7543     return o;
7544 }
7545
7546 /*
7547 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
7548
7549 Constructs, checks, and returns an op tree expressing a C<foreach>
7550 loop (iteration through a list of values).  This is a heavyweight loop,
7551 with structure that allows exiting the loop by C<last> and suchlike.
7552
7553 C<sv> optionally supplies the variable that will be aliased to each
7554 item in turn; if null, it defaults to C<$_>.
7555 C<expr> supplies the list of values to iterate over.  C<block> supplies
7556 the main body of the loop, and C<cont> optionally supplies a C<continue>
7557 block that operates as a second half of the body.  All of these optree
7558 inputs are consumed by this function and become part of the constructed
7559 op tree.
7560
7561 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7562 op and, shifted up eight bits, the eight bits of C<op_private> for
7563 the C<leaveloop> op, except that (in both cases) some bits will be set
7564 automatically.
7565
7566 =cut
7567 */
7568
7569 OP *
7570 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
7571 {
7572     dVAR;
7573     LOOP *loop;
7574     OP *wop;
7575     PADOFFSET padoff = 0;
7576     I32 iterflags = 0;
7577     I32 iterpflags = 0;
7578
7579     PERL_ARGS_ASSERT_NEWFOROP;
7580
7581     if (sv) {
7582         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
7583             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
7584             OpTYPE_set(sv, OP_RV2GV);
7585
7586             /* The op_type check is needed to prevent a possible segfault
7587              * if the loop variable is undeclared and 'strict vars' is in
7588              * effect. This is illegal but is nonetheless parsed, so we
7589              * may reach this point with an OP_CONST where we're expecting
7590              * an OP_GV.
7591              */
7592             if (cUNOPx(sv)->op_first->op_type == OP_GV
7593              && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
7594                 iterpflags |= OPpITER_DEF;
7595         }
7596         else if (sv->op_type == OP_PADSV) { /* private variable */
7597             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
7598             padoff = sv->op_targ;
7599             sv->op_targ = 0;
7600             op_free(sv);
7601             sv = NULL;
7602             PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
7603         }
7604         else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
7605             NOOP;
7606         else
7607             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
7608         if (padoff) {
7609             PADNAME * const pn = PAD_COMPNAME(padoff);
7610             const char * const name = PadnamePV(pn);
7611
7612             if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
7613                 iterpflags |= OPpITER_DEF;
7614         }
7615     }
7616     else {
7617         sv = newGVOP(OP_GV, 0, PL_defgv);
7618         iterpflags |= OPpITER_DEF;
7619     }
7620
7621     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
7622         expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
7623         iterflags |= OPf_STACKED;
7624     }
7625     else if (expr->op_type == OP_NULL &&
7626              (expr->op_flags & OPf_KIDS) &&
7627              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
7628     {
7629         /* Basically turn for($x..$y) into the same as for($x,$y), but we
7630          * set the STACKED flag to indicate that these values are to be
7631          * treated as min/max values by 'pp_enteriter'.
7632          */
7633         const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
7634         LOGOP* const range = (LOGOP*) flip->op_first;
7635         OP* const left  = range->op_first;
7636         OP* const right = OpSIBLING(left);
7637         LISTOP* listop;
7638
7639         range->op_flags &= ~OPf_KIDS;
7640         /* detach range's children */
7641         op_sibling_splice((OP*)range, NULL, -1, NULL);
7642
7643         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
7644         listop->op_first->op_next = range->op_next;
7645         left->op_next = range->op_other;
7646         right->op_next = (OP*)listop;
7647         listop->op_next = listop->op_first;
7648
7649         op_free(expr);
7650         expr = (OP*)(listop);
7651         op_null(expr);
7652         iterflags |= OPf_STACKED;
7653     }
7654     else {
7655         expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
7656     }
7657
7658     loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
7659                                   op_append_elem(OP_LIST, list(expr),
7660                                                  scalar(sv)));
7661     assert(!loop->op_next);
7662     /* for my  $x () sets OPpLVAL_INTRO;
7663      * for our $x () sets OPpOUR_INTRO */
7664     loop->op_private = (U8)iterpflags;
7665     if (loop->op_slabbed
7666      && DIFF(loop, OpSLOT(loop)->opslot_next)
7667          < SIZE_TO_PSIZE(sizeof(LOOP)))
7668     {
7669         LOOP *tmp;
7670         NewOp(1234,tmp,1,LOOP);
7671         Copy(loop,tmp,1,LISTOP);
7672 #ifdef PERL_OP_PARENT
7673         assert(loop->op_last->op_sibparent == (OP*)loop);
7674         OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
7675 #endif
7676         S_op_destroy(aTHX_ (OP*)loop);
7677         loop = tmp;
7678     }
7679     else if (!loop->op_slabbed)
7680     {
7681         loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
7682 #ifdef PERL_OP_PARENT
7683         OpLASTSIB_set(loop->op_last, (OP*)loop);
7684 #endif
7685     }
7686     loop->op_targ = padoff;
7687     wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
7688     return wop;
7689 }
7690
7691 /*
7692 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
7693
7694 Constructs, checks, and returns a loop-exiting op (such as C<goto>
7695 or C<last>).  C<type> is the opcode.  C<label> supplies the parameter
7696 determining the target of the op; it is consumed by this function and
7697 becomes part of the constructed op tree.
7698
7699 =cut
7700 */
7701
7702 OP*
7703 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
7704 {
7705     OP *o = NULL;
7706
7707     PERL_ARGS_ASSERT_NEWLOOPEX;
7708
7709     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
7710         || type == OP_CUSTOM);
7711
7712     if (type != OP_GOTO) {
7713         /* "last()" means "last" */
7714         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
7715             o = newOP(type, OPf_SPECIAL);
7716         }
7717     }
7718     else {
7719         /* Check whether it's going to be a goto &function */
7720         if (label->op_type == OP_ENTERSUB
7721                 && !(label->op_flags & OPf_STACKED))
7722             label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
7723     }
7724
7725     /* Check for a constant argument */
7726     if (label->op_type == OP_CONST) {
7727             SV * const sv = ((SVOP *)label)->op_sv;
7728             STRLEN l;
7729             const char *s = SvPV_const(sv,l);
7730             if (l == strlen(s)) {
7731                 o = newPVOP(type,
7732                             SvUTF8(((SVOP*)label)->op_sv),
7733                             savesharedpv(
7734                                 SvPV_nolen_const(((SVOP*)label)->op_sv)));
7735             }
7736     }
7737
7738     /* If we have already created an op, we do not need the label. */
7739     if (o)
7740                 op_free(label);
7741     else o = newUNOP(type, OPf_STACKED, label);
7742
7743     PL_hints |= HINT_BLOCK_SCOPE;
7744     return o;
7745 }
7746
7747 /* if the condition is a literal array or hash
7748    (or @{ ... } etc), make a reference to it.
7749  */
7750 STATIC OP *
7751 S_ref_array_or_hash(pTHX_ OP *cond)
7752 {
7753     if (cond
7754     && (cond->op_type == OP_RV2AV
7755     ||  cond->op_type == OP_PADAV
7756     ||  cond->op_type == OP_RV2HV
7757     ||  cond->op_type == OP_PADHV))
7758
7759         return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
7760
7761     else if(cond
7762     && (cond->op_type == OP_ASLICE
7763     ||  cond->op_type == OP_KVASLICE
7764     ||  cond->op_type == OP_HSLICE
7765     ||  cond->op_type == OP_KVHSLICE)) {
7766
7767         /* anonlist now needs a list from this op, was previously used in
7768          * scalar context */
7769         cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
7770         cond->op_flags |= OPf_WANT_LIST;
7771
7772         return newANONLIST(op_lvalue(cond, OP_ANONLIST));
7773     }
7774
7775     else
7776         return cond;
7777 }
7778
7779 /* These construct the optree fragments representing given()
7780    and when() blocks.
7781
7782    entergiven and enterwhen are LOGOPs; the op_other pointer
7783    points up to the associated leave op. We need this so we
7784    can put it in the context and make break/continue work.
7785    (Also, of course, pp_enterwhen will jump straight to
7786    op_other if the match fails.)
7787  */
7788
7789 STATIC OP *
7790 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
7791                    I32 enter_opcode, I32 leave_opcode,
7792                    PADOFFSET entertarg)
7793 {
7794     dVAR;
7795     LOGOP *enterop;
7796     OP *o;
7797
7798     PERL_ARGS_ASSERT_NEWGIVWHENOP;
7799     PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
7800
7801     enterop = alloc_LOGOP(enter_opcode, block, NULL);
7802     enterop->op_targ = 0;
7803     enterop->op_private = 0;
7804
7805     o = newUNOP(leave_opcode, 0, (OP *) enterop);
7806
7807     if (cond) {
7808         /* prepend cond if we have one */
7809         op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
7810
7811         o->op_next = LINKLIST(cond);
7812         cond->op_next = (OP *) enterop;
7813     }
7814     else {
7815         /* This is a default {} block */
7816         enterop->op_flags |= OPf_SPECIAL;
7817         o      ->op_flags |= OPf_SPECIAL;
7818
7819         o->op_next = (OP *) enterop;
7820     }
7821
7822     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
7823                                        entergiven and enterwhen both
7824                                        use ck_null() */
7825
7826     enterop->op_next = LINKLIST(block);
7827     block->op_next = enterop->op_other = o;
7828
7829     return o;
7830 }
7831
7832 /* Does this look like a boolean operation? For these purposes
7833    a boolean operation is:
7834      - a subroutine call [*]
7835      - a logical connective
7836      - a comparison operator
7837      - a filetest operator, with the exception of -s -M -A -C
7838      - defined(), exists() or eof()
7839      - /$re/ or $foo =~ /$re/
7840
7841    [*] possibly surprising
7842  */
7843 STATIC bool
7844 S_looks_like_bool(pTHX_ const OP *o)
7845 {
7846     PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
7847
7848     switch(o->op_type) {
7849         case OP_OR:
7850         case OP_DOR:
7851             return looks_like_bool(cLOGOPo->op_first);
7852
7853         case OP_AND:
7854         {
7855             OP* sibl = OpSIBLING(cLOGOPo->op_first);
7856             ASSUME(sibl);
7857             return (
7858                 looks_like_bool(cLOGOPo->op_first)
7859              && looks_like_bool(sibl));
7860         }
7861
7862         case OP_NULL:
7863         case OP_SCALAR:
7864             return (
7865                 o->op_flags & OPf_KIDS
7866             && looks_like_bool(cUNOPo->op_first));
7867
7868         case OP_ENTERSUB:
7869
7870         case OP_NOT:    case OP_XOR:
7871
7872         case OP_EQ:     case OP_NE:     case OP_LT:
7873         case OP_GT:     case OP_LE:     case OP_GE:
7874
7875         case OP_I_EQ:   case OP_I_NE:   case OP_I_LT:
7876         case OP_I_GT:   case OP_I_LE:   case OP_I_GE:
7877
7878         case OP_SEQ:    case OP_SNE:    case OP_SLT:
7879         case OP_SGT:    case OP_SLE:    case OP_SGE:
7880
7881         case OP_SMARTMATCH:
7882
7883         case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
7884         case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
7885         case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
7886         case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
7887         case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
7888         case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
7889         case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
7890         case OP_FTTEXT:   case OP_FTBINARY:
7891
7892         case OP_DEFINED: case OP_EXISTS:
7893         case OP_MATCH:   case OP_EOF:
7894
7895         case OP_FLOP:
7896
7897             return TRUE;
7898
7899         case OP_CONST:
7900             /* Detect comparisons that have been optimized away */
7901             if (cSVOPo->op_sv == &PL_sv_yes
7902             ||  cSVOPo->op_sv == &PL_sv_no)
7903
7904                 return TRUE;
7905             else
7906                 return FALSE;
7907
7908         /* FALLTHROUGH */
7909         default:
7910             return FALSE;
7911     }
7912 }
7913
7914 /*
7915 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
7916
7917 Constructs, checks, and returns an op tree expressing a C<given> block.
7918 C<cond> supplies the expression that will be locally assigned to a lexical
7919 variable, and C<block> supplies the body of the C<given> construct; they
7920 are consumed by this function and become part of the constructed op tree.
7921 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
7922
7923 =cut
7924 */
7925
7926 OP *
7927 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
7928 {
7929     PERL_ARGS_ASSERT_NEWGIVENOP;
7930     PERL_UNUSED_ARG(defsv_off);
7931
7932     assert(!defsv_off);
7933     return newGIVWHENOP(
7934         ref_array_or_hash(cond),
7935         block,
7936         OP_ENTERGIVEN, OP_LEAVEGIVEN,
7937         0);
7938 }
7939
7940 /*
7941 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
7942
7943 Constructs, checks, and returns an op tree expressing a C<when> block.
7944 C<cond> supplies the test expression, and C<block> supplies the block
7945 that will be executed if the test evaluates to true; they are consumed
7946 by this function and become part of the constructed op tree.  C<cond>
7947 will be interpreted DWIMically, often as a comparison against C<$_>,
7948 and may be null to generate a C<default> block.
7949
7950 =cut
7951 */
7952
7953 OP *
7954 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
7955 {
7956     const bool cond_llb = (!cond || looks_like_bool(cond));
7957     OP *cond_op;
7958
7959     PERL_ARGS_ASSERT_NEWWHENOP;
7960
7961     if (cond_llb)
7962         cond_op = cond;
7963     else {
7964         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
7965                 newDEFSVOP(),
7966                 scalar(ref_array_or_hash(cond)));
7967     }
7968
7969     return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
7970 }
7971
7972 /* must not conflict with SVf_UTF8 */
7973 #define CV_CKPROTO_CURSTASH     0x1
7974
7975 void
7976 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
7977                     const STRLEN len, const U32 flags)
7978 {
7979     SV *name = NULL, *msg;
7980     const char * cvp = SvROK(cv)
7981                         ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
7982                            ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
7983                            : ""
7984                         : CvPROTO(cv);
7985     STRLEN clen = CvPROTOLEN(cv), plen = len;
7986
7987     PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
7988
7989     if (p == NULL && cvp == NULL)
7990         return;
7991
7992     if (!ckWARN_d(WARN_PROTOTYPE))
7993         return;
7994
7995     if (p && cvp) {
7996         p = S_strip_spaces(aTHX_ p, &plen);
7997         cvp = S_strip_spaces(aTHX_ cvp, &clen);
7998         if ((flags & SVf_UTF8) == SvUTF8(cv)) {
7999             if (plen == clen && memEQ(cvp, p, plen))
8000                 return;
8001         } else {
8002             if (flags & SVf_UTF8) {
8003                 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
8004                     return;
8005             }
8006             else {
8007                 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
8008                     return;
8009             }
8010         }
8011     }
8012
8013     msg = sv_newmortal();
8014
8015     if (gv)
8016     {
8017         if (isGV(gv))
8018             gv_efullname3(name = sv_newmortal(), gv, NULL);
8019         else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
8020             name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
8021         else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
8022             name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
8023             sv_catpvs(name, "::");
8024             if (SvROK(gv)) {
8025                 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
8026                 assert (CvNAMED(SvRV_const(gv)));
8027                 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
8028             }
8029             else sv_catsv(name, (SV *)gv);
8030         }
8031         else name = (SV *)gv;
8032     }
8033     sv_setpvs(msg, "Prototype mismatch:");
8034     if (name)
8035         Perl_sv_catpvf(aTHX_ msg, " sub %" SVf, SVfARG(name));
8036     if (cvp)
8037         Perl_sv_catpvf(aTHX_ msg, " (%" UTF8f ")",
8038             UTF8fARG(SvUTF8(cv),clen,cvp)
8039         );
8040     else
8041         sv_catpvs(msg, ": none");
8042     sv_catpvs(msg, " vs ");
8043     if (p)
8044         Perl_sv_catpvf(aTHX_ msg, "(%" UTF8f ")", UTF8fARG(flags & SVf_UTF8,len,p));
8045     else
8046         sv_catpvs(msg, "none");
8047     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%" SVf, SVfARG(msg));
8048 }
8049
8050 static void const_sv_xsub(pTHX_ CV* cv);
8051 static void const_av_xsub(pTHX_ CV* cv);
8052
8053 /*
8054
8055 =head1 Optree Manipulation Functions
8056
8057 =for apidoc cv_const_sv
8058
8059 If C<cv> is a constant sub eligible for inlining, returns the constant
8060 value returned by the sub.  Otherwise, returns C<NULL>.
8061
8062 Constant subs can be created with C<newCONSTSUB> or as described in
8063 L<perlsub/"Constant Functions">.
8064
8065 =cut
8066 */
8067 SV *
8068 Perl_cv_const_sv(const CV *const cv)
8069 {
8070     SV *sv;
8071     if (!cv)
8072         return NULL;
8073     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
8074         return NULL;
8075     sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
8076     if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
8077     return sv;
8078 }
8079
8080 SV *
8081 Perl_cv_const_sv_or_av(const CV * const cv)
8082 {
8083     if (!cv)
8084         return NULL;
8085     if (SvROK(cv)) return SvRV((SV *)cv);
8086     assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
8087     return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
8088 }
8089
8090 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
8091  * Can be called in 2 ways:
8092  *
8093  * !allow_lex
8094  *      look for a single OP_CONST with attached value: return the value
8095  *
8096  * allow_lex && !CvCONST(cv);
8097  *
8098  *      examine the clone prototype, and if contains only a single
8099  *      OP_CONST, return the value; or if it contains a single PADSV ref-
8100  *      erencing an outer lexical, turn on CvCONST to indicate the CV is
8101  *      a candidate for "constizing" at clone time, and return NULL.
8102  */
8103
8104 static SV *
8105 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
8106 {
8107     SV *sv = NULL;
8108     bool padsv = FALSE;
8109
8110     assert(o);
8111     assert(cv);
8112
8113     for (; o; o = o->op_next) {
8114         const OPCODE type = o->op_type;
8115
8116         if (type == OP_NEXTSTATE || type == OP_LINESEQ
8117              || type == OP_NULL
8118              || type == OP_PUSHMARK)
8119                 continue;
8120         if (type == OP_DBSTATE)
8121                 continue;
8122         if (type == OP_LEAVESUB)
8123             break;
8124         if (sv)
8125             return NULL;
8126         if (type == OP_CONST && cSVOPo->op_sv)
8127             sv = cSVOPo->op_sv;
8128         else if (type == OP_UNDEF && !o->op_private) {
8129             sv = newSV(0);
8130             SAVEFREESV(sv);
8131         }
8132         else if (allow_lex && type == OP_PADSV) {
8133                 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
8134                 {
8135                     sv = &PL_sv_undef; /* an arbitrary non-null value */
8136                     padsv = TRUE;
8137                 }
8138                 else
8139                     return NULL;
8140         }
8141         else {
8142             return NULL;
8143         }
8144     }
8145     if (padsv) {
8146         CvCONST_on(cv);
8147         return NULL;
8148     }
8149     return sv;
8150 }
8151
8152 static void
8153 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
8154                         PADNAME * const name, SV ** const const_svp)
8155 {
8156     assert (cv);
8157     assert (o || name);
8158     assert (const_svp);
8159     if (!block) {
8160         if (CvFLAGS(PL_compcv)) {
8161             /* might have had built-in attrs applied */
8162             const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
8163             if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
8164              && ckWARN(WARN_MISC))
8165             {
8166                 /* protect against fatal warnings leaking compcv */
8167                 SAVEFREESV(PL_compcv);
8168                 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
8169                 SvREFCNT_inc_simple_void_NN(PL_compcv);
8170             }
8171             CvFLAGS(cv) |=
8172                 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
8173                   & ~(CVf_LVALUE * pureperl));
8174         }
8175         return;
8176     }
8177
8178     /* redundant check for speed: */
8179     if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
8180         const line_t oldline = CopLINE(PL_curcop);
8181         SV *namesv = o
8182             ? cSVOPo->op_sv
8183             : sv_2mortal(newSVpvn_utf8(
8184                 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
8185               ));
8186         if (PL_parser && PL_parser->copline != NOLINE)
8187             /* This ensures that warnings are reported at the first
8188                line of a redefinition, not the last.  */
8189             CopLINE_set(PL_curcop, PL_parser->copline);
8190         /* protect against fatal warnings leaking compcv */
8191         SAVEFREESV(PL_compcv);
8192         report_redefined_cv(namesv, cv, const_svp);
8193         SvREFCNT_inc_simple_void_NN(PL_compcv);
8194         CopLINE_set(PL_curcop, oldline);
8195     }
8196     SAVEFREESV(cv);
8197     return;
8198 }
8199
8200 CV *
8201 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
8202 {
8203     CV **spot;
8204     SV **svspot;
8205     const char *ps;
8206     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
8207     U32 ps_utf8 = 0;
8208     CV *cv = NULL;
8209     CV *compcv = PL_compcv;
8210     SV *const_sv;
8211     PADNAME *name;
8212     PADOFFSET pax = o->op_targ;
8213     CV *outcv = CvOUTSIDE(PL_compcv);
8214     CV *clonee = NULL;
8215     HEK *hek = NULL;
8216     bool reusable = FALSE;
8217     OP *start = NULL;
8218 #ifdef PERL_DEBUG_READONLY_OPS
8219     OPSLAB *slab = NULL;
8220 #endif
8221
8222     PERL_ARGS_ASSERT_NEWMYSUB;
8223
8224     /* Find the pad slot for storing the new sub.
8225        We cannot use PL_comppad, as it is the pad owned by the new sub.  We
8226        need to look in CvOUTSIDE and find the pad belonging to the enclos-
8227        ing sub.  And then we need to dig deeper if this is a lexical from
8228        outside, as in:
8229            my sub foo; sub { sub foo { } }
8230      */
8231   redo:
8232     name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
8233     if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
8234         pax = PARENT_PAD_INDEX(name);
8235         outcv = CvOUTSIDE(outcv);
8236         assert(outcv);
8237         goto redo;
8238     }
8239     svspot =
8240         &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
8241                         [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
8242     spot = (CV **)svspot;
8243
8244     if (!(PL_parser && PL_parser->error_count))
8245         move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name), 0);
8246
8247     if (proto) {
8248         assert(proto->op_type == OP_CONST);
8249         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
8250         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
8251     }
8252     else
8253         ps = NULL;
8254
8255     if (proto)
8256         SAVEFREEOP(proto);
8257     if (attrs)
8258         SAVEFREEOP(attrs);
8259
8260     if (PL_parser && PL_parser->error_count) {
8261         op_free(block);
8262         SvREFCNT_dec(PL_compcv);
8263         PL_compcv = 0;
8264         goto done;
8265     }
8266
8267     if (CvDEPTH(outcv) && CvCLONE(compcv)) {
8268         cv = *spot;
8269         svspot = (SV **)(spot = &clonee);
8270     }
8271     else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
8272         cv = *spot;
8273     else {
8274         assert (SvTYPE(*spot) == SVt_PVCV);
8275         if (CvNAMED(*spot))
8276             hek = CvNAME_HEK(*spot);
8277         else {
8278             dVAR;
8279             U32 hash;
8280             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
8281             CvNAME_HEK_set(*spot, hek =
8282                 share_hek(
8283                     PadnamePV(name)+1,
8284                     (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
8285                     hash
8286                 )
8287             );
8288             CvLEXICAL_on(*spot);
8289         }
8290         cv = PadnamePROTOCV(name);
8291         svspot = (SV **)(spot = &PadnamePROTOCV(name));
8292     }
8293
8294     if (block) {
8295         /* This makes sub {}; work as expected.  */
8296         if (block->op_type == OP_STUB) {
8297             const line_t l = PL_parser->copline;
8298             op_free(block);
8299             block = newSTATEOP(0, NULL, 0);
8300             PL_parser->copline = l;
8301         }
8302         block = CvLVALUE(compcv)
8303              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
8304                    ? newUNOP(OP_LEAVESUBLV, 0,
8305                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
8306                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
8307         start = LINKLIST(block);
8308         block->op_next = 0;
8309         if (ps && !*ps && !attrs && !CvLVALUE(compcv))
8310             const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
8311         else
8312             const_sv = NULL;
8313     }
8314     else
8315         const_sv = NULL;
8316
8317     if (cv) {
8318         const bool exists = CvROOT(cv) || CvXSUB(cv);
8319
8320         /* if the subroutine doesn't exist and wasn't pre-declared
8321          * with a prototype, assume it will be AUTOLOADed,
8322          * skipping the prototype check
8323          */
8324         if (exists || SvPOK(cv))
8325             cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
8326                                  ps_utf8);
8327         /* already defined? */
8328         if (exists) {
8329             S_already_defined(aTHX_ cv, block, NULL, name, &const_sv);
8330             if (block)
8331                 cv = NULL;
8332             else {
8333                 if (attrs)
8334                     goto attrs;
8335                 /* just a "sub foo;" when &foo is already defined */
8336                 SAVEFREESV(compcv);
8337                 goto done;
8338             }
8339         }
8340         else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
8341             cv = NULL;
8342             reusable = TRUE;
8343         }
8344     }
8345
8346     if (const_sv) {
8347         SvREFCNT_inc_simple_void_NN(const_sv);
8348         SvFLAGS(const_sv) |= SVs_PADTMP;
8349         if (cv) {
8350             assert(!CvROOT(cv) && !CvCONST(cv));
8351             cv_forget_slab(cv);
8352         }
8353         else {
8354             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8355             CvFILE_set_from_cop(cv, PL_curcop);
8356             CvSTASH_set(cv, PL_curstash);
8357             *spot = cv;
8358         }
8359         SvPVCLEAR(MUTABLE_SV(cv));  /* prototype is "" */
8360         CvXSUBANY(cv).any_ptr = const_sv;
8361         CvXSUB(cv) = const_sv_xsub;
8362         CvCONST_on(cv);
8363         CvISXSUB_on(cv);
8364         PoisonPADLIST(cv);
8365         CvFLAGS(cv) |= CvMETHOD(compcv);
8366         op_free(block);
8367         SvREFCNT_dec(compcv);
8368         PL_compcv = NULL;
8369         goto setname;
8370     }
8371
8372     /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
8373        determine whether this sub definition is in the same scope as its
8374        declaration.  If this sub definition is inside an inner named pack-
8375        age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
8376        the package sub.  So check PadnameOUTER(name) too.
8377      */
8378     if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
8379         assert(!CvWEAKOUTSIDE(compcv));
8380         SvREFCNT_dec(CvOUTSIDE(compcv));
8381         CvWEAKOUTSIDE_on(compcv);
8382     }
8383     /* XXX else do we have a circular reference? */
8384
8385     if (cv) {   /* must reuse cv in case stub is referenced elsewhere */
8386         /* transfer PL_compcv to cv */
8387         if (block) {
8388             cv_flags_t preserved_flags =
8389                 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
8390             PADLIST *const temp_padl = CvPADLIST(cv);
8391             CV *const temp_cv = CvOUTSIDE(cv);
8392             const cv_flags_t other_flags =
8393                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8394             OP * const cvstart = CvSTART(cv);
8395
8396             SvPOK_off(cv);
8397             CvFLAGS(cv) =
8398                 CvFLAGS(compcv) | preserved_flags;
8399             CvOUTSIDE(cv) = CvOUTSIDE(compcv);
8400             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
8401             CvPADLIST_set(cv, CvPADLIST(compcv));
8402             CvOUTSIDE(compcv) = temp_cv;
8403             CvPADLIST_set(compcv, temp_padl);
8404             CvSTART(cv) = CvSTART(compcv);
8405             CvSTART(compcv) = cvstart;
8406             CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8407             CvFLAGS(compcv) |= other_flags;
8408
8409             if (CvFILE(cv) && CvDYNFILE(cv)) {
8410                 Safefree(CvFILE(cv));
8411             }
8412
8413             /* inner references to compcv must be fixed up ... */
8414             pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
8415             if (PERLDB_INTER)/* Advice debugger on the new sub. */
8416                 ++PL_sub_generation;
8417         }
8418         else {
8419             /* Might have had built-in attributes applied -- propagate them. */
8420             CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
8421         }
8422         /* ... before we throw it away */
8423         SvREFCNT_dec(compcv);
8424         PL_compcv = compcv = cv;
8425     }
8426     else {
8427         cv = compcv;
8428         *spot = cv;
8429     }
8430
8431   setname:
8432     CvLEXICAL_on(cv);
8433     if (!CvNAME_HEK(cv)) {
8434         if (hek) (void)share_hek_hek(hek);
8435         else {
8436             dVAR;
8437             U32 hash;
8438             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
8439             hek = share_hek(PadnamePV(name)+1,
8440                       (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
8441                       hash);
8442         }
8443         CvNAME_HEK_set(cv, hek);
8444     }
8445
8446     if (const_sv)
8447         goto clone;
8448
8449     CvFILE_set_from_cop(cv, PL_curcop);
8450     CvSTASH_set(cv, PL_curstash);
8451
8452     if (ps) {
8453         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8454         if (ps_utf8)
8455             SvUTF8_on(MUTABLE_SV(cv));
8456     }
8457
8458     if (block) {
8459         /* If we assign an optree to a PVCV, then we've defined a
8460          * subroutine that the debugger could be able to set a breakpoint
8461          * in, so signal to pp_entereval that it should not throw away any
8462          * saved lines at scope exit.  */
8463
8464         PL_breakable_sub_gen++;
8465         CvROOT(cv) = block;
8466         /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8467            itself has a refcount. */
8468         CvSLABBED_off(cv);
8469         OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8470 #ifdef PERL_DEBUG_READONLY_OPS
8471         slab = (OPSLAB *)CvSTART(cv);
8472 #endif
8473         S_process_optree(aTHX_ cv, block, start);
8474     }
8475
8476   attrs:
8477     if (attrs) {
8478         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8479         apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
8480     }
8481
8482     if (block) {
8483         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8484             SV * const tmpstr = sv_newmortal();
8485             GV * const db_postponed = gv_fetchpvs("DB::postponed",
8486                                                   GV_ADDMULTI, SVt_PVHV);
8487             HV *hv;
8488             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8489                                           CopFILE(PL_curcop),
8490                                           (long)PL_subline,
8491                                           (long)CopLINE(PL_curcop));
8492             if (HvNAME_HEK(PL_curstash)) {
8493                 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
8494                 sv_catpvs(tmpstr, "::");
8495             }
8496             else
8497                 sv_setpvs(tmpstr, "__ANON__::");
8498
8499             sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
8500                             PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
8501             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8502                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8503             hv = GvHVn(db_postponed);
8504             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8505                 CV * const pcv = GvCV(db_postponed);
8506                 if (pcv) {
8507                     dSP;
8508                     PUSHMARK(SP);
8509                     XPUSHs(tmpstr);
8510                     PUTBACK;
8511                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
8512                 }
8513             }
8514         }
8515     }
8516
8517   clone:
8518     if (clonee) {
8519         assert(CvDEPTH(outcv));
8520         spot = (CV **)
8521             &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
8522         if (reusable)
8523             cv_clone_into(clonee, *spot);
8524         else *spot = cv_clone(clonee);
8525         SvREFCNT_dec_NN(clonee);
8526         cv = *spot;
8527     }
8528
8529     if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
8530         PADOFFSET depth = CvDEPTH(outcv);
8531         while (--depth) {
8532             SV *oldcv;
8533             svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
8534             oldcv = *svspot;
8535             *svspot = SvREFCNT_inc_simple_NN(cv);
8536             SvREFCNT_dec(oldcv);
8537         }
8538     }
8539
8540   done:
8541     if (PL_parser)
8542         PL_parser->copline = NOLINE;
8543     LEAVE_SCOPE(floor);
8544 #ifdef PERL_DEBUG_READONLY_OPS
8545     if (slab)
8546         Slab_to_ro(slab);
8547 #endif
8548     op_free(o);
8549     return cv;
8550 }
8551
8552
8553 /* _x = extended */
8554 CV *
8555 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
8556                             OP *block, bool o_is_gv)
8557 {
8558     GV *gv;
8559     const char *ps;
8560     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
8561     U32 ps_utf8 = 0;
8562     CV *cv = NULL;     /* the previous CV with this name, if any */
8563     SV *const_sv;
8564     const bool ec = PL_parser && PL_parser->error_count;
8565     /* If the subroutine has no body, no attributes, and no builtin attributes
8566        then it's just a sub declaration, and we may be able to get away with
8567        storing with a placeholder scalar in the symbol table, rather than a
8568        full CV.  If anything is present then it will take a full CV to
8569        store it.  */
8570     const I32 gv_fetch_flags
8571         = ec ? GV_NOADD_NOINIT :
8572         (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
8573         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
8574     STRLEN namlen = 0;
8575     const char * const name =
8576          o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
8577     bool has_name;
8578     bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
8579     bool evanescent = FALSE;
8580     OP *start = NULL;
8581 #ifdef PERL_DEBUG_READONLY_OPS
8582     OPSLAB *slab = NULL;
8583 #endif
8584
8585     if (o_is_gv) {
8586         gv = (GV*)o;
8587         o = NULL;
8588         has_name = TRUE;
8589     } else if (name) {
8590         /* Try to optimise and avoid creating a GV.  Instead, the CV’s name
8591            hek and CvSTASH pointer together can imply the GV.  If the name
8592            contains a package name, then GvSTASH(CvGV(cv)) may differ from
8593            CvSTASH, so forego the optimisation if we find any.
8594            Also, we may be called from load_module at run time, so
8595            PL_curstash (which sets CvSTASH) may not point to the stash the
8596            sub is stored in.  */
8597         const I32 flags =
8598            ec ? GV_NOADD_NOINIT
8599               :   PL_curstash != CopSTASH(PL_curcop)
8600                || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
8601                     ? gv_fetch_flags
8602                     : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
8603         gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
8604         has_name = TRUE;
8605     } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
8606         SV * const sv = sv_newmortal();
8607         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%" IVdf "]",
8608                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
8609                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
8610         gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
8611         has_name = TRUE;
8612     } else if (PL_curstash) {
8613         gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
8614         has_name = FALSE;
8615     } else {
8616         gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
8617         has_name = FALSE;
8618     }
8619
8620     if (!ec) {
8621         if (isGV(gv)) {
8622             move_proto_attr(&proto, &attrs, gv, 0);
8623         } else {
8624             assert(cSVOPo);
8625             move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv, 1);
8626         }
8627     }
8628
8629     if (proto) {
8630         assert(proto->op_type == OP_CONST);
8631         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
8632         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
8633     }
8634     else
8635         ps = NULL;
8636
8637     if (o)
8638         SAVEFREEOP(o);
8639     if (proto)
8640         SAVEFREEOP(proto);
8641     if (attrs)
8642         SAVEFREEOP(attrs);
8643
8644     if (ec) {
8645         op_free(block);
8646
8647         if (name)
8648             SvREFCNT_dec(PL_compcv);
8649         else
8650             cv = PL_compcv;
8651
8652         PL_compcv = 0;
8653         if (name && block) {
8654             const char *s = strrchr(name, ':');
8655             s = s ? s+1 : name;
8656             if (strEQ(s, "BEGIN")) {
8657                 if (PL_in_eval & EVAL_KEEPERR)
8658                     Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
8659                 else {
8660                     SV * const errsv = ERRSV;
8661                     /* force display of errors found but not reported */
8662                     sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
8663                     Perl_croak_nocontext("%" SVf, SVfARG(errsv));
8664                 }
8665             }
8666         }
8667         goto done;
8668     }
8669
8670     if (!block && SvTYPE(gv) != SVt_PVGV) {
8671         /* If we are not defining a new sub and the existing one is not a
8672            full GV + CV... */
8673         if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
8674             /* We are applying attributes to an existing sub, so we need it
8675                upgraded if it is a constant.  */
8676             if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
8677                 gv_init_pvn(gv, PL_curstash, name, namlen,
8678                             SVf_UTF8 * name_is_utf8);
8679         }
8680         else {                  /* Maybe prototype now, and had at maximum
8681                                    a prototype or const/sub ref before.  */
8682             if (SvTYPE(gv) > SVt_NULL) {
8683                 cv_ckproto_len_flags((const CV *)gv,
8684                                     o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8685                                     ps_len, ps_utf8);
8686             }
8687
8688             if (!SvROK(gv)) {
8689                 if (ps) {
8690                     sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
8691                     if (ps_utf8)
8692                         SvUTF8_on(MUTABLE_SV(gv));
8693                 }
8694                 else
8695                     sv_setiv(MUTABLE_SV(gv), -1);
8696             }
8697
8698             SvREFCNT_dec(PL_compcv);
8699             cv = PL_compcv = NULL;
8700             goto done;
8701         }
8702     }
8703
8704     cv = (!name || (isGV(gv) && GvCVGEN(gv)))
8705         ? NULL
8706         : isGV(gv)
8707             ? GvCV(gv)
8708             : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
8709                 ? (CV *)SvRV(gv)
8710                 : NULL;
8711
8712     if (block) {
8713         assert(PL_parser);
8714         /* This makes sub {}; work as expected.  */
8715         if (block->op_type == OP_STUB) {
8716             const line_t l = PL_parser->copline;
8717             op_free(block);
8718             block = newSTATEOP(0, NULL, 0);
8719             PL_parser->copline = l;
8720         }
8721         block = CvLVALUE(PL_compcv)
8722              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
8723                     && (!isGV(gv) || !GvASSUMECV(gv)))
8724                    ? newUNOP(OP_LEAVESUBLV, 0,
8725                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
8726                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
8727         start = LINKLIST(block);
8728         block->op_next = 0;
8729         if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
8730             const_sv =
8731                 S_op_const_sv(aTHX_ start, PL_compcv,
8732                                         cBOOL(CvCLONE(PL_compcv)));
8733         else
8734             const_sv = NULL;
8735     }
8736     else
8737         const_sv = NULL;
8738
8739     if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
8740         cv_ckproto_len_flags((const CV *)gv,
8741                              o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8742                              ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
8743         if (SvROK(gv)) {
8744             /* All the other code for sub redefinition warnings expects the
8745                clobbered sub to be a CV.  Instead of making all those code
8746                paths more complex, just inline the RV version here.  */
8747             const line_t oldline = CopLINE(PL_curcop);
8748             assert(IN_PERL_COMPILETIME);
8749             if (PL_parser && PL_parser->copline != NOLINE)
8750                 /* This ensures that warnings are reported at the first
8751                    line of a redefinition, not the last.  */
8752                 CopLINE_set(PL_curcop, PL_parser->copline);
8753             /* protect against fatal warnings leaking compcv */
8754             SAVEFREESV(PL_compcv);
8755
8756             if (ckWARN(WARN_REDEFINE)
8757              || (  ckWARN_d(WARN_REDEFINE)
8758                 && (  !const_sv || SvRV(gv) == const_sv
8759                    || sv_cmp(SvRV(gv), const_sv)  ))) {
8760                 assert(cSVOPo);
8761                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8762                           "Constant subroutine %" SVf " redefined",
8763                           SVfARG(cSVOPo->op_sv));
8764             }
8765
8766             SvREFCNT_inc_simple_void_NN(PL_compcv);
8767             CopLINE_set(PL_curcop, oldline);
8768             SvREFCNT_dec(SvRV(gv));
8769         }
8770     }
8771
8772     if (cv) {
8773         const bool exists = CvROOT(cv) || CvXSUB(cv);
8774
8775         /* if the subroutine doesn't exist and wasn't pre-declared
8776          * with a prototype, assume it will be AUTOLOADed,
8777          * skipping the prototype check
8778          */
8779         if (exists || SvPOK(cv))
8780             cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
8781         /* already defined (or promised)? */
8782         if (exists || (isGV(gv) && GvASSUMECV(gv))) {
8783             S_already_defined(aTHX_ cv, block, o, NULL, &const_sv);
8784             if (block)
8785                 cv = NULL;
8786             else {
8787                 if (attrs)
8788                     goto attrs;
8789                 /* just a "sub foo;" when &foo is already defined */
8790                 SAVEFREESV(PL_compcv);
8791                 goto done;
8792             }
8793         }
8794     }
8795
8796     if (const_sv) {
8797         SvREFCNT_inc_simple_void_NN(const_sv);
8798         SvFLAGS(const_sv) |= SVs_PADTMP;
8799         if (cv) {
8800             assert(!CvROOT(cv) && !CvCONST(cv));
8801             cv_forget_slab(cv);
8802             SvPVCLEAR(MUTABLE_SV(cv));  /* prototype is "" */
8803             CvXSUBANY(cv).any_ptr = const_sv;
8804             CvXSUB(cv) = const_sv_xsub;
8805             CvCONST_on(cv);
8806             CvISXSUB_on(cv);
8807             PoisonPADLIST(cv);
8808             CvFLAGS(cv) |= CvMETHOD(PL_compcv);
8809         }
8810         else {
8811             if (isGV(gv) || CvMETHOD(PL_compcv)) {
8812                 if (name && isGV(gv))
8813                     GvCV_set(gv, NULL);
8814                 cv = newCONSTSUB_flags(
8815                     NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
8816                     const_sv
8817                 );
8818                 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
8819             }
8820             else {
8821                 if (!SvROK(gv)) {
8822                     SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8823                     prepare_SV_for_RV((SV *)gv);
8824                     SvOK_off((SV *)gv);
8825                     SvROK_on(gv);
8826                 }
8827                 SvRV_set(gv, const_sv);
8828             }
8829         }
8830         op_free(block);
8831         SvREFCNT_dec(PL_compcv);
8832         PL_compcv = NULL;
8833         goto done;
8834     }
8835
8836     /* don't copy new BEGIN CV to old BEGIN CV - RT #129099 */
8837     if (name && cv && *name == 'B' && strEQ(name, "BEGIN"))
8838         cv = NULL;
8839
8840     if (cv) {                           /* must reuse cv if autoloaded */
8841         /* transfer PL_compcv to cv */
8842         if (block) {
8843             cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
8844             PADLIST *const temp_av = CvPADLIST(cv);
8845             CV *const temp_cv = CvOUTSIDE(cv);
8846             const cv_flags_t other_flags =
8847                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8848             OP * const cvstart = CvSTART(cv);
8849
8850             if (isGV(gv)) {
8851                 CvGV_set(cv,gv);
8852                 assert(!CvCVGV_RC(cv));
8853                 assert(CvGV(cv) == gv);
8854             }
8855             else {
8856                 dVAR;
8857                 U32 hash;
8858                 PERL_HASH(hash, name, namlen);
8859                 CvNAME_HEK_set(cv,
8860                                share_hek(name,
8861                                          name_is_utf8
8862                                             ? -(SSize_t)namlen
8863                                             :  (SSize_t)namlen,
8864                                          hash));
8865             }
8866
8867             SvPOK_off(cv);
8868             CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
8869                                              | CvNAMED(cv);
8870             CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
8871             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
8872             CvPADLIST_set(cv,CvPADLIST(PL_compcv));
8873             CvOUTSIDE(PL_compcv) = temp_cv;
8874             CvPADLIST_set(PL_compcv, temp_av);
8875             CvSTART(cv) = CvSTART(PL_compcv);
8876             CvSTART(PL_compcv) = cvstart;
8877             CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8878             CvFLAGS(PL_compcv) |= other_flags;
8879
8880             if (CvFILE(cv) && CvDYNFILE(cv)) {
8881                 Safefree(CvFILE(cv));
8882             }
8883             CvFILE_set_from_cop(cv, PL_curcop);
8884             CvSTASH_set(cv, PL_curstash);
8885
8886             /* inner references to PL_compcv must be fixed up ... */
8887             pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
8888             if (PERLDB_INTER)/* Advice debugger on the new sub. */
8889                 ++PL_sub_generation;
8890         }
8891         else {
8892             /* Might have had built-in attributes applied -- propagate them. */
8893             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
8894         }
8895         /* ... before we throw it away */
8896         SvREFCNT_dec(PL_compcv);
8897         PL_compcv = cv;
8898     }
8899     else {
8900         cv = PL_compcv;
8901         if (name && isGV(gv)) {
8902             GvCV_set(gv, cv);
8903             GvCVGEN(gv) = 0;
8904             if (HvENAME_HEK(GvSTASH(gv)))
8905                 /* sub Foo::bar { (shift)+1 } */
8906                 gv_method_changed(gv);
8907         }
8908         else if (name) {
8909             if (!SvROK(gv)) {
8910                 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8911                 prepare_SV_for_RV((SV *)gv);
8912                 SvOK_off((SV *)gv);
8913                 SvROK_on(gv);
8914             }
8915             SvRV_set(gv, (SV *)cv);
8916             if (HvENAME_HEK(PL_curstash))
8917                 mro_method_changed_in(PL_curstash);
8918         }
8919     }
8920
8921     if (!CvHASGV(cv)) {
8922         if (isGV(gv))
8923             CvGV_set(cv, gv);
8924         else {
8925             dVAR;
8926             U32 hash;
8927             PERL_HASH(hash, name, namlen);
8928             CvNAME_HEK_set(cv, share_hek(name,
8929                                          name_is_utf8
8930                                             ? -(SSize_t)namlen
8931                                             :  (SSize_t)namlen,
8932                                          hash));
8933         }
8934         CvFILE_set_from_cop(cv, PL_curcop);
8935         CvSTASH_set(cv, PL_curstash);
8936     }
8937
8938     if (ps) {
8939         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8940         if ( ps_utf8 )
8941             SvUTF8_on(MUTABLE_SV(cv));
8942     }
8943
8944     if (block) {
8945         /* If we assign an optree to a PVCV, then we've defined a
8946          * subroutine that the debugger could be able to set a breakpoint
8947          * in, so signal to pp_entereval that it should not throw away any
8948          * saved lines at scope exit.  */
8949
8950         PL_breakable_sub_gen++;
8951         CvROOT(cv) = block;
8952         /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8953            itself has a refcount. */
8954         CvSLABBED_off(cv);
8955         OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8956 #ifdef PERL_DEBUG_READONLY_OPS
8957         slab = (OPSLAB *)CvSTART(cv);
8958 #endif
8959         S_process_optree(aTHX_ cv, block, start);
8960     }
8961
8962   attrs:
8963     if (attrs) {
8964         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8965         HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
8966                         ? GvSTASH(CvGV(cv))
8967                         : PL_curstash;
8968         if (!name)
8969             SAVEFREESV(cv);
8970         apply_attrs(stash, MUTABLE_SV(cv), attrs);
8971         if (!name)
8972             SvREFCNT_inc_simple_void_NN(cv);
8973     }
8974
8975     if (block && has_name) {
8976         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8977             SV * const tmpstr = cv_name(cv,NULL,0);
8978             GV * const db_postponed = gv_fetchpvs("DB::postponed",
8979                                                   GV_ADDMULTI, SVt_PVHV);
8980             HV *hv;
8981             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8982                                           CopFILE(PL_curcop),
8983                                           (long)PL_subline,
8984                                           (long)CopLINE(PL_curcop));
8985             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8986                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8987             hv = GvHVn(db_postponed);
8988             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8989                 CV * const pcv = GvCV(db_postponed);
8990                 if (pcv) {
8991                     dSP;
8992                     PUSHMARK(SP);
8993                     XPUSHs(tmpstr);
8994                     PUTBACK;
8995                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
8996                 }
8997             }
8998         }
8999
9000         if (name) {
9001             if (PL_parser && PL_parser->error_count)
9002                 clear_special_blocks(name, gv, cv);
9003             else
9004                 evanescent =
9005                     process_special_blocks(floor, name, gv, cv);
9006         }
9007     }
9008
9009   done:
9010     if (PL_parser)
9011         PL_parser->copline = NOLINE;
9012     LEAVE_SCOPE(floor);
9013
9014     if (!evanescent) {
9015 #ifdef PERL_DEBUG_READONLY_OPS
9016     if (slab)
9017         Slab_to_ro(slab);
9018 #endif
9019     if (cv && name && block && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
9020         pad_add_weakref(cv);
9021     }
9022     return cv;
9023 }
9024
9025 STATIC void
9026 S_clear_special_blocks(pTHX_ const char *const fullname,
9027                        GV *const gv, CV *const cv) {
9028     const char *colon;
9029     const char *name;
9030
9031     PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
9032
9033     colon = strrchr(fullname,':');
9034     name = colon ? colon + 1 : fullname;
9035
9036     if ((*name == 'B' && strEQ(name, "BEGIN"))
9037         || (*name == 'E' && strEQ(name, "END"))
9038         || (*name == 'U' && strEQ(name, "UNITCHECK"))
9039         || (*name == 'C' && strEQ(name, "CHECK"))
9040         || (*name == 'I' && strEQ(name, "INIT"))) {
9041         if (!isGV(gv)) {
9042             (void)CvGV(cv);
9043             assert(isGV(gv));
9044         }
9045         GvCV_set(gv, NULL);
9046         SvREFCNT_dec_NN(MUTABLE_SV(cv));
9047     }
9048 }
9049
9050 /* Returns true if the sub has been freed.  */
9051 STATIC bool
9052 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
9053                          GV *const gv,
9054                          CV *const cv)
9055 {
9056     const char *const colon = strrchr(fullname,':');
9057     const char *const name = colon ? colon + 1 : fullname;
9058
9059     PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
9060
9061     if (*name == 'B') {
9062         if (strEQ(name, "BEGIN")) {
9063             const I32 oldscope = PL_scopestack_ix;
9064             dSP;
9065             (void)CvGV(cv);
9066             if (floor) LEAVE_SCOPE(floor);
9067             ENTER;
9068             PUSHSTACKi(PERLSI_REQUIRE);
9069             SAVECOPFILE(&PL_compiling);
9070             SAVECOPLINE(&PL_compiling);
9071             SAVEVPTR(PL_curcop);
9072
9073             DEBUG_x( dump_sub(gv) );
9074             Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
9075             GvCV_set(gv,0);             /* cv has been hijacked */
9076             call_list(oldscope, PL_beginav);
9077
9078             POPSTACK;
9079             LEAVE;
9080             return !PL_savebegin;
9081         }
9082         else
9083             return FALSE;
9084     } else {
9085         if (*name == 'E') {
9086             if strEQ(name, "END") {
9087                 DEBUG_x( dump_sub(gv) );
9088                 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
9089             } else
9090                 return FALSE;
9091         } else if (*name == 'U') {
9092             if (strEQ(name, "UNITCHECK")) {
9093                 /* It's never too late to run a unitcheck block */
9094                 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
9095             }
9096             else
9097                 return FALSE;
9098         } else if (*name == 'C') {
9099             if (strEQ(name, "CHECK")) {
9100                 if (PL_main_start)
9101                     /* diag_listed_as: Too late to run %s block */
9102                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
9103                                    "Too late to run CHECK block");
9104                 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
9105             }
9106             else
9107                 return FALSE;
9108         } else if (*name == 'I') {
9109             if (strEQ(name, "INIT")) {
9110                 if (PL_main_start)
9111                     /* diag_listed_as: Too late to run %s block */
9112                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
9113                                    "Too late to run INIT block");
9114                 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
9115             }
9116             else
9117                 return FALSE;
9118         } else
9119             return FALSE;
9120         DEBUG_x( dump_sub(gv) );
9121         (void)CvGV(cv);
9122         GvCV_set(gv,0);         /* cv has been hijacked */
9123         return FALSE;
9124     }
9125 }
9126
9127 /*
9128 =for apidoc newCONSTSUB
9129
9130 See L</newCONSTSUB_flags>.
9131
9132 =cut
9133 */
9134
9135 CV *
9136 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
9137 {
9138     return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
9139 }
9140
9141 /*
9142 =for apidoc newCONSTSUB_flags
9143
9144 Creates a constant sub equivalent to Perl S<C<sub FOO () { 123 }>> which is
9145 eligible for inlining at compile-time.
9146
9147 Currently, the only useful value for C<flags> is C<SVf_UTF8>.
9148
9149 The newly created subroutine takes ownership of a reference to the passed in
9150 SV.
9151
9152 Passing C<NULL> for SV creates a constant sub equivalent to S<C<sub BAR () {}>>,
9153 which won't be called if used as a destructor, but will suppress the overhead
9154 of a call to C<AUTOLOAD>.  (This form, however, isn't eligible for inlining at
9155 compile time.)
9156
9157 =cut
9158 */
9159
9160 CV *
9161 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
9162                              U32 flags, SV *sv)
9163 {
9164     CV* cv;
9165     const char *const file = CopFILE(PL_curcop);
9166
9167     ENTER;
9168
9169     if (IN_PERL_RUNTIME) {
9170         /* at runtime, it's not safe to manipulate PL_curcop: it may be
9171          * an op shared between threads. Use a non-shared COP for our
9172          * dirty work */
9173          SAVEVPTR(PL_curcop);
9174          SAVECOMPILEWARNINGS();
9175          PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
9176          PL_curcop = &PL_compiling;
9177     }
9178     SAVECOPLINE(PL_curcop);
9179     CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
9180
9181     SAVEHINTS();
9182     PL_hints &= ~HINT_BLOCK_SCOPE;
9183
9184     if (stash) {
9185         SAVEGENERICSV(PL_curstash);
9186         PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
9187     }
9188
9189     /* Protect sv against leakage caused by fatal warnings. */
9190     if (sv) SAVEFREESV(sv);
9191
9192     /* file becomes the CvFILE. For an XS, it's usually static storage,
9193        and so doesn't get free()d.  (It's expected to be from the C pre-
9194        processor __FILE__ directive). But we need a dynamically allocated one,
9195        and we need it to get freed.  */
9196     cv = newXS_len_flags(name, len,
9197                          sv && SvTYPE(sv) == SVt_PVAV
9198                              ? const_av_xsub
9199                              : const_sv_xsub,
9200                          file ? file : "", "",
9201                          &sv, XS_DYNAMIC_FILENAME | flags);
9202     CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
9203     CvCONST_on(cv);
9204
9205     LEAVE;
9206
9207     return cv;
9208 }
9209
9210 /*
9211 =for apidoc U||newXS
9212
9213 Used by C<xsubpp> to hook up XSUBs as Perl subs.  C<filename> needs to be
9214 static storage, as it is used directly as CvFILE(), without a copy being made.
9215
9216 =cut
9217 */
9218
9219 CV *
9220 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
9221 {
9222     PERL_ARGS_ASSERT_NEWXS;
9223     return newXS_len_flags(
9224         name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
9225     );
9226 }
9227
9228 CV *
9229 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
9230                  const char *const filename, const char *const proto,
9231                  U32 flags)
9232 {
9233     PERL_ARGS_ASSERT_NEWXS_FLAGS;
9234     return newXS_len_flags(
9235        name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
9236     );
9237 }
9238
9239 CV *
9240 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
9241 {
9242     PERL_ARGS_ASSERT_NEWXS_DEFFILE;
9243     return newXS_len_flags(
9244         name, strlen(name), subaddr, NULL, NULL, NULL, 0
9245     );
9246 }
9247
9248 CV *
9249 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
9250                            XSUBADDR_t subaddr, const char *const filename,
9251                            const char *const proto, SV **const_svp,
9252                            U32 flags)
9253 {
9254     CV *cv;
9255     bool interleave = FALSE;
9256
9257     PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
9258
9259     {
9260         GV * const gv = gv_fetchpvn(
9261                             name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
9262                             name ? len : PL_curstash ? sizeof("__ANON__") - 1:
9263                                 sizeof("__ANON__::__ANON__") - 1,
9264                             GV_ADDMULTI | flags, SVt_PVCV);
9265
9266         if ((cv = (name ? GvCV(gv) : NULL))) {
9267             if (GvCVGEN(gv)) {
9268                 /* just a cached method */
9269                 SvREFCNT_dec(cv);
9270                 cv = NULL;
9271             }
9272             else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
9273                 /* already defined (or promised) */
9274                 /* Redundant check that allows us to avoid creating an SV
9275                    most of the time: */
9276                 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
9277                     report_redefined_cv(newSVpvn_flags(
9278                                          name,len,(flags&SVf_UTF8)|SVs_TEMP
9279                                         ),
9280                                         cv, const_svp);
9281                 }
9282                 interleave = TRUE;
9283                 ENTER;
9284                 SAVEFREESV(cv);
9285                 cv = NULL;
9286             }
9287         }
9288
9289         if (cv)                         /* must reuse cv if autoloaded */
9290             cv_undef(cv);
9291         else {
9292             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9293             if (name) {
9294                 GvCV_set(gv,cv);
9295                 GvCVGEN(gv) = 0;
9296                 if (HvENAME_HEK(GvSTASH(gv)))
9297                     gv_method_changed(gv); /* newXS */
9298             }
9299         }
9300
9301         CvGV_set(cv, gv);
9302         if(filename) {
9303             /* XSUBs can't be perl lang/perl5db.pl debugged
9304             if (PERLDB_LINE_OR_SAVESRC)
9305                 (void)gv_fetchfile(filename); */
9306             assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
9307             if (flags & XS_DYNAMIC_FILENAME) {
9308                 CvDYNFILE_on(cv);
9309                 CvFILE(cv) = savepv(filename);
9310             } else {
9311             /* NOTE: not copied, as it is expected to be an external constant string */
9312                 CvFILE(cv) = (char *)filename;
9313             }
9314         } else {
9315             assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
9316             CvFILE(cv) = (char*)PL_xsubfilename;
9317         }
9318         CvISXSUB_on(cv);
9319         CvXSUB(cv) = subaddr;
9320 #ifndef PERL_IMPLICIT_CONTEXT
9321         CvHSCXT(cv) = &PL_stack_sp;
9322 #else
9323         PoisonPADLIST(cv);
9324 #endif
9325
9326         if (name)
9327             process_special_blocks(0, name, gv, cv);
9328         else
9329             CvANON_on(cv);
9330     } /* <- not a conditional branch */
9331
9332
9333     sv_setpv(MUTABLE_SV(cv), proto);
9334     if (interleave) LEAVE;
9335     return cv;
9336 }
9337
9338 CV *
9339 Perl_newSTUB(pTHX_ GV *gv, bool fake)
9340 {
9341     CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9342     GV *cvgv;
9343     PERL_ARGS_ASSERT_NEWSTUB;
9344     assert(!GvCVu(gv));
9345     GvCV_set(gv, cv);
9346     GvCVGEN(gv) = 0;
9347     if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
9348         gv_method_changed(gv);
9349     if (SvFAKE(gv)) {
9350         cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
9351         SvFAKE_off(cvgv);
9352     }
9353     else cvgv = gv;
9354     CvGV_set(cv, cvgv);
9355     CvFILE_set_from_cop(cv, PL_curcop);
9356     CvSTASH_set(cv, PL_curstash);
9357     GvMULTI_on(gv);
9358     return cv;
9359 }
9360
9361 void
9362 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
9363 {
9364     CV *cv;
9365     GV *gv;
9366     OP *root;
9367     OP *start;
9368
9369     if (PL_parser && PL_parser->error_count) {
9370         op_free(block);
9371         goto finish;
9372     }
9373
9374     gv = o
9375         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
9376         : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
9377
9378     GvMULTI_on(gv);
9379     if ((cv = GvFORM(gv))) {
9380         if (ckWARN(WARN_REDEFINE)) {
9381             const line_t oldline = CopLINE(PL_curcop);
9382             if (PL_parser && PL_parser->copline != NOLINE)
9383                 CopLINE_set(PL_curcop, PL_parser->copline);
9384             if (o) {
9385                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9386                             "Format %" SVf " redefined", SVfARG(cSVOPo->op_sv));
9387             } else {
9388                 /* diag_listed_as: Format %s redefined */
9389                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9390                             "Format STDOUT redefined");
9391             }
9392             CopLINE_set(PL_curcop, oldline);
9393         }
9394         SvREFCNT_dec(cv);
9395     }
9396     cv = PL_compcv;
9397     GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
9398     CvGV_set(cv, gv);
9399     CvFILE_set_from_cop(cv, PL_curcop);
9400
9401
9402     root = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
9403     CvROOT(cv) = root;
9404     start = LINKLIST(root);
9405     root->op_next = 0;
9406     S_process_optree(aTHX_ cv, root, start);
9407     cv_forget_slab(cv);
9408
9409   finish:
9410     op_free(o);
9411     if (PL_parser)
9412         PL_parser->copline = NOLINE;
9413     LEAVE_SCOPE(floor);
9414     PL_compiling.cop_seq = 0;
9415 }
9416
9417 OP *
9418 Perl_newANONLIST(pTHX_ OP *o)
9419 {
9420     return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
9421 }
9422
9423 OP *
9424 Perl_newANONHASH(pTHX_ OP *o)
9425 {
9426     return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
9427 }
9428
9429 OP *
9430 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
9431 {
9432     return newANONATTRSUB(floor, proto, NULL, block);
9433 }
9434
9435 OP *
9436 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
9437 {
9438     SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
9439     OP * anoncode =
9440         newSVOP(OP_ANONCODE, 0,
9441                 cv);
9442     if (CvANONCONST(cv))
9443         anoncode = newUNOP(OP_ANONCONST, 0,
9444                            op_convert_list(OP_ENTERSUB,
9445                                            OPf_STACKED|OPf_WANT_SCALAR,
9446                                            anoncode));
9447     return newUNOP(OP_REFGEN, 0, anoncode);
9448 }
9449
9450 OP *
9451 Perl_oopsAV(pTHX_ OP *o)
9452 {
9453     dVAR;
9454
9455     PERL_ARGS_ASSERT_OOPSAV;
9456
9457     switch (o->op_type) {
9458     case OP_PADSV:
9459     case OP_PADHV:
9460         OpTYPE_set(o, OP_PADAV);
9461         return ref(o, OP_RV2AV);
9462
9463     case OP_RV2SV:
9464     case OP_RV2HV:
9465         OpTYPE_set(o, OP_RV2AV);
9466         ref(o, OP_RV2AV);
9467         break;
9468
9469     default:
9470         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
9471         break;
9472     }
9473     return o;
9474 }
9475
9476 OP *
9477 Perl_oopsHV(pTHX_ OP *o)
9478 {
9479     dVAR;
9480
9481     PERL_ARGS_ASSERT_OOPSHV;
9482
9483     switch (o->op_type) {
9484     case OP_PADSV:
9485     case OP_PADAV:
9486         OpTYPE_set(o, OP_PADHV);
9487         return ref(o, OP_RV2HV);
9488
9489     case OP_RV2SV:
9490     case OP_RV2AV:
9491         OpTYPE_set(o, OP_RV2HV);
9492         /* rv2hv steals the bottom bit for its own uses */
9493         o->op_private &= ~OPpARG1_MASK;
9494         ref(o, OP_RV2HV);
9495         break;
9496
9497     default:
9498         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
9499         break;
9500     }
9501     return o;
9502 }
9503
9504 OP *
9505 Perl_newAVREF(pTHX_ OP *o)
9506 {
9507     dVAR;
9508
9509     PERL_ARGS_ASSERT_NEWAVREF;
9510
9511     if (o->op_type == OP_PADANY) {
9512         OpTYPE_set(o, OP_PADAV);
9513         return o;
9514     }
9515     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
9516         Perl_croak(aTHX_ "Can't use an array as a reference");
9517     }
9518     return newUNOP(OP_RV2AV, 0, scalar(o));
9519 }
9520
9521 OP *
9522 Perl_newGVREF(pTHX_ I32 type, OP *o)
9523 {
9524     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
9525         return newUNOP(OP_NULL, 0, o);
9526     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
9527 }
9528
9529 OP *
9530 Perl_newHVREF(pTHX_ OP *o)
9531 {
9532     dVAR;
9533
9534     PERL_ARGS_ASSERT_NEWHVREF;
9535
9536     if (o->op_type == OP_PADANY) {
9537         OpTYPE_set(o, OP_PADHV);
9538         return o;
9539     }
9540     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
9541         Perl_croak(aTHX_ "Can't use a hash as a reference");
9542     }
9543     return newUNOP(OP_RV2HV, 0, scalar(o));
9544 }
9545
9546 OP *
9547 Perl_newCVREF(pTHX_ I32 flags, OP *o)
9548 {
9549     if (o->op_type == OP_PADANY) {
9550         dVAR;
9551         OpTYPE_set(o, OP_PADCV);
9552     }
9553     return newUNOP(OP_RV2CV, flags, scalar(o));
9554 }
9555
9556 OP *
9557 Perl_newSVREF(pTHX_ OP *o)
9558 {
9559     dVAR;
9560
9561     PERL_ARGS_ASSERT_NEWSVREF;
9562
9563     if (o->op_type == OP_PADANY) {
9564         OpTYPE_set(o, OP_PADSV);
9565         scalar(o);
9566         return o;
9567     }
9568     return newUNOP(OP_RV2SV, 0, scalar(o));
9569 }
9570
9571 /* Check routines. See the comments at the top of this file for details
9572  * on when these are called */
9573
9574 OP *
9575 Perl_ck_anoncode(pTHX_ OP *o)
9576 {
9577     PERL_ARGS_ASSERT_CK_ANONCODE;
9578
9579     cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
9580     cSVOPo->op_sv = NULL;
9581     return o;
9582 }
9583
9584 static void
9585 S_io_hints(pTHX_ OP *o)
9586 {
9587 #if O_BINARY != 0 || O_TEXT != 0
9588     HV * const table =
9589         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
9590     if (table) {
9591         SV **svp = hv_fetchs(table, "open_IN", FALSE);
9592         if (svp && *svp) {
9593             STRLEN len = 0;
9594             const char *d = SvPV_const(*svp, len);
9595             const I32 mode = mode_from_discipline(d, len);
9596             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9597 #  if O_BINARY != 0
9598             if (mode & O_BINARY)
9599                 o->op_private |= OPpOPEN_IN_RAW;
9600 #  endif
9601 #  if O_TEXT != 0
9602             if (mode & O_TEXT)
9603                 o->op_private |= OPpOPEN_IN_CRLF;
9604 #  endif
9605         }
9606
9607         svp = hv_fetchs(table, "open_OUT", FALSE);
9608         if (svp && *svp) {
9609             STRLEN len = 0;
9610             const char *d = SvPV_const(*svp, len);
9611             const I32 mode = mode_from_discipline(d, len);
9612             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9613 #  if O_BINARY != 0
9614             if (mode & O_BINARY)
9615                 o->op_private |= OPpOPEN_OUT_RAW;
9616 #  endif
9617 #  if O_TEXT != 0
9618             if (mode & O_TEXT)
9619                 o->op_private |= OPpOPEN_OUT_CRLF;
9620 #  endif
9621         }
9622     }
9623 #else
9624     PERL_UNUSED_CONTEXT;
9625     PERL_UNUSED_ARG(o);
9626 #endif
9627 }
9628
9629 OP *
9630 Perl_ck_backtick(pTHX_ OP *o)
9631 {
9632     GV *gv;
9633     OP *newop = NULL;
9634     OP *sibl;
9635     PERL_ARGS_ASSERT_CK_BACKTICK;
9636     /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
9637     if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
9638      && (gv = gv_override("readpipe",8)))
9639     {
9640         /* detach rest of siblings from o and its first child */
9641         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
9642         newop = S_new_entersubop(aTHX_ gv, sibl);
9643     }
9644     else if (!(o->op_flags & OPf_KIDS))
9645         newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
9646     if (newop) {
9647         op_free(o);
9648         return newop;
9649     }
9650     S_io_hints(aTHX_ o);
9651     return o;
9652 }
9653
9654 OP *
9655 Perl_ck_bitop(pTHX_ OP *o)
9656 {
9657     PERL_ARGS_ASSERT_CK_BITOP;
9658
9659     o->op_private = (U8)(PL_hints & HINT_INTEGER);
9660
9661     if (o->op_type == OP_NBIT_OR     || o->op_type == OP_SBIT_OR
9662      || o->op_type == OP_NBIT_XOR    || o->op_type == OP_SBIT_XOR
9663      || o->op_type == OP_NBIT_AND    || o->op_type == OP_SBIT_AND
9664      || o->op_type == OP_NCOMPLEMENT || o->op_type == OP_SCOMPLEMENT)
9665         Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__BITWISE),
9666                               "The bitwise feature is experimental");
9667     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
9668             && OP_IS_INFIX_BIT(o->op_type))
9669     {
9670         const OP * const left = cBINOPo->op_first;
9671         const OP * const right = OpSIBLING(left);
9672         if ((OP_IS_NUMCOMPARE(left->op_type) &&
9673                 (left->op_flags & OPf_PARENS) == 0) ||
9674             (OP_IS_NUMCOMPARE(right->op_type) &&
9675                 (right->op_flags & OPf_PARENS) == 0))
9676             Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
9677                           "Possible precedence problem on bitwise %s operator",
9678                            o->op_type ==  OP_BIT_OR
9679                          ||o->op_type == OP_NBIT_OR  ? "|"
9680                         :  o->op_type ==  OP_BIT_AND
9681                          ||o->op_type == OP_NBIT_AND ? "&"
9682                         :  o->op_type ==  OP_BIT_XOR
9683                          ||o->op_type == OP_NBIT_XOR ? "^"
9684                         :  o->op_type == OP_SBIT_OR  ? "|."
9685                         :  o->op_type == OP_SBIT_AND ? "&." : "^."
9686                            );
9687     }
9688     return o;
9689 }
9690
9691 PERL_STATIC_INLINE bool
9692 is_dollar_bracket(pTHX_ const OP * const o)
9693 {
9694     const OP *kid;
9695     PERL_UNUSED_CONTEXT;
9696     return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
9697         && (kid = cUNOPx(o)->op_first)
9698         && kid->op_type == OP_GV
9699         && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
9700 }
9701
9702 /* for lt, gt, le, ge, eq, ne and their i_ variants */
9703
9704 OP *
9705 Perl_ck_cmp(pTHX_ OP *o)
9706 {
9707     bool is_eq;
9708     bool neg;
9709     bool reverse;
9710     bool iv0;
9711     OP *indexop, *constop, *start;
9712     SV *sv;
9713     IV iv;
9714
9715     PERL_ARGS_ASSERT_CK_CMP;
9716
9717     is_eq = (   o->op_type == OP_EQ
9718              || o->op_type == OP_NE
9719              || o->op_type == OP_I_EQ
9720              || o->op_type == OP_I_NE);
9721
9722     if (!is_eq && ckWARN(WARN_SYNTAX)) {
9723         const OP *kid = cUNOPo->op_first;
9724         if (kid &&
9725             (
9726                 (   is_dollar_bracket(aTHX_ kid)
9727                  && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
9728                 )
9729              || (   kid->op_type == OP_CONST
9730                  && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
9731                 )
9732            )
9733         )
9734             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9735                         "$[ used in %s (did you mean $] ?)", OP_DESC(o));
9736     }
9737
9738     /* convert (index(...) == -1) and variations into
9739      *   (r)index/BOOL(,NEG)
9740      */
9741
9742     reverse = FALSE;
9743
9744     indexop = cUNOPo->op_first;
9745     constop = OpSIBLING(indexop);
9746     start = NULL;
9747     if (indexop->op_type == OP_CONST) {
9748         constop = indexop;
9749         indexop = OpSIBLING(constop);
9750         start = constop;
9751         reverse = TRUE;
9752     }
9753
9754     if (indexop->op_type != OP_INDEX && indexop->op_type != OP_RINDEX)
9755         return o;
9756
9757     /* ($lex = index(....)) == -1 */
9758     if (indexop->op_private & OPpTARGET_MY)
9759         return o;
9760
9761     if (constop->op_type != OP_CONST)
9762         return o;
9763
9764     sv = cSVOPx_sv(constop);
9765     if (!(sv && SvIOK_notUV(sv)))
9766         return o;
9767
9768     iv = SvIVX(sv);
9769     if (iv != -1 && iv != 0)
9770         return o;
9771     iv0 = (iv == 0);
9772
9773     if (o->op_type == OP_LT || o->op_type == OP_I_LT) {
9774         if (!(iv0 ^ reverse))
9775             return o;
9776         neg = iv0;
9777     }
9778     else if (o->op_type == OP_LE || o->op_type == OP_I_LE) {
9779         if (iv0 ^ reverse)
9780             return o;
9781         neg = !iv0;
9782     }
9783     else if (o->op_type == OP_GE || o->op_type == OP_I_GE) {
9784         if (!(iv0 ^ reverse))
9785             return o;
9786         neg = !iv0;
9787     }
9788     else if (o->op_type == OP_GT || o->op_type == OP_I_GT) {
9789         if (iv0 ^ reverse)
9790             return o;
9791         neg = iv0;
9792     }
9793     else if (o->op_type == OP_EQ || o->op_type == OP_I_EQ) {
9794         if (iv0)
9795             return o;
9796         neg = TRUE;
9797     }
9798     else {
9799         assert(o->op_type == OP_NE || o->op_type == OP_I_NE);
9800         if (iv0)
9801             return o;
9802         neg = FALSE;
9803     }
9804
9805     indexop->op_flags &= ~OPf_PARENS;
9806     indexop->op_flags |= (o->op_flags & OPf_PARENS);
9807     indexop->op_private |= OPpTRUEBOOL;
9808     if (neg)
9809         indexop->op_private |= OPpINDEX_BOOLNEG;
9810     /* cut out the index op and free the eq,const ops */
9811     (void)op_sibling_splice(o, start, 1, NULL);
9812     op_free(o);
9813
9814     return indexop;
9815 }
9816
9817
9818 OP *
9819 Perl_ck_concat(pTHX_ OP *o)
9820 {
9821     const OP * const kid = cUNOPo->op_first;
9822
9823     PERL_ARGS_ASSERT_CK_CONCAT;
9824     PERL_UNUSED_CONTEXT;
9825
9826     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
9827             !(kUNOP->op_first->op_flags & OPf_MOD))
9828         o->op_flags |= OPf_STACKED;
9829     return o;
9830 }
9831
9832 OP *
9833 Perl_ck_spair(pTHX_ OP *o)
9834 {
9835     dVAR;
9836
9837     PERL_ARGS_ASSERT_CK_SPAIR;
9838
9839     if (o->op_flags & OPf_KIDS) {
9840         OP* newop;
9841         OP* kid;
9842         OP* kidkid;
9843         const OPCODE type = o->op_type;
9844         o = modkids(ck_fun(o), type);
9845         kid    = cUNOPo->op_first;
9846         kidkid = kUNOP->op_first;
9847         newop = OpSIBLING(kidkid);
9848         if (newop) {
9849             const OPCODE type = newop->op_type;
9850             if (OpHAS_SIBLING(newop))
9851                 return o;
9852             if (o->op_type == OP_REFGEN
9853              && (  type == OP_RV2CV
9854                 || (  !(newop->op_flags & OPf_PARENS)
9855                    && (  type == OP_RV2AV || type == OP_PADAV
9856                       || type == OP_RV2HV || type == OP_PADHV))))
9857                 NOOP; /* OK (allow srefgen for \@a and \%h) */
9858             else if (OP_GIMME(newop,0) != G_SCALAR)
9859                 return o;
9860         }
9861         /* excise first sibling */
9862         op_sibling_splice(kid, NULL, 1, NULL);
9863         op_free(kidkid);
9864     }
9865     /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
9866      * and OP_CHOMP into OP_SCHOMP */
9867     o->op_ppaddr = PL_ppaddr[++o->op_type];
9868     return ck_fun(o);
9869 }
9870
9871 OP *
9872 Perl_ck_delete(pTHX_ OP *o)
9873 {
9874     PERL_ARGS_ASSERT_CK_DELETE;
9875
9876     o = ck_fun(o);
9877     o->op_private = 0;
9878     if (o->op_flags & OPf_KIDS) {
9879         OP * const kid = cUNOPo->op_first;
9880         switch (kid->op_type) {
9881         case OP_ASLICE:
9882             o->op_flags |= OPf_SPECIAL;
9883             /* FALLTHROUGH */
9884         case OP_HSLICE:
9885             o->op_private |= OPpSLICE;
9886             break;
9887         case OP_AELEM:
9888             o->op_flags |= OPf_SPECIAL;
9889             /* FALLTHROUGH */
9890         case OP_HELEM:
9891             break;
9892         case OP_KVASLICE:
9893             o->op_flags |= OPf_SPECIAL;
9894             /* FALLTHROUGH */
9895         case OP_KVHSLICE:
9896             o->op_private |= OPpKVSLICE;
9897             break;
9898         default:
9899             Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
9900                              "element or slice");
9901         }
9902         if (kid->op_private & OPpLVAL_INTRO)
9903             o->op_private |= OPpLVAL_INTRO;
9904         op_null(kid);
9905     }
9906     return o;
9907 }
9908
9909 OP *
9910 Perl_ck_eof(pTHX_ OP *o)
9911 {
9912     PERL_ARGS_ASSERT_CK_EOF;
9913
9914     if (o->op_flags & OPf_KIDS) {
9915         OP *kid;
9916         if (cLISTOPo->op_first->op_type == OP_STUB) {
9917             OP * const newop
9918                 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
9919             op_free(o);
9920             o = newop;
9921         }
9922         o = ck_fun(o);
9923         kid = cLISTOPo->op_first;
9924         if (kid->op_type == OP_RV2GV)
9925             kid->op_private |= OPpALLOW_FAKE;
9926     }
9927     return o;
9928 }
9929
9930
9931 OP *
9932 Perl_ck_eval(pTHX_ OP *o)
9933 {
9934     dVAR;
9935
9936     PERL_ARGS_ASSERT_CK_EVAL;
9937
9938     PL_hints |= HINT_BLOCK_SCOPE;
9939     if (o->op_flags & OPf_KIDS) {
9940         SVOP * const kid = (SVOP*)cUNOPo->op_first;
9941         assert(kid);
9942
9943         if (o->op_type == OP_ENTERTRY) {
9944             LOGOP *enter;
9945
9946             /* cut whole sibling chain free from o */
9947             op_sibling_splice(o, NULL, -1, NULL);
9948             op_free(o);
9949
9950             enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL);
9951
9952             /* establish postfix order */
9953             enter->op_next = (OP*)enter;
9954
9955             o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
9956             OpTYPE_set(o, OP_LEAVETRY);
9957             enter->op_other = o;
9958             return o;
9959         }
9960         else {
9961             scalar((OP*)kid);
9962             S_set_haseval(aTHX);
9963         }
9964     }
9965     else {
9966         const U8 priv = o->op_private;
9967         op_free(o);
9968         /* the newUNOP will recursively call ck_eval(), which will handle
9969          * all the stuff at the end of this function, like adding
9970          * OP_HINTSEVAL
9971          */
9972         return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
9973     }
9974     o->op_targ = (PADOFFSET)PL_hints;
9975     if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
9976     if ((PL_hints & HINT_LOCALIZE_HH) != 0
9977      && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
9978         /* Store a copy of %^H that pp_entereval can pick up. */
9979         OP *hhop = newSVOP(OP_HINTSEVAL, 0,
9980                            MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
9981         /* append hhop to only child  */
9982         op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
9983
9984         o->op_private |= OPpEVAL_HAS_HH;
9985     }
9986     if (!(o->op_private & OPpEVAL_BYTES)
9987          && FEATURE_UNIEVAL_IS_ENABLED)
9988             o->op_private |= OPpEVAL_UNICODE;
9989     return o;
9990 }
9991
9992 OP *
9993 Perl_ck_exec(pTHX_ OP *o)
9994 {
9995     PERL_ARGS_ASSERT_CK_EXEC;
9996
9997     if (o->op_flags & OPf_STACKED) {
9998         OP *kid;
9999         o = ck_fun(o);
10000         kid = OpSIBLING(cUNOPo->op_first);
10001         if (kid->op_type == OP_RV2GV)
10002             op_null(kid);
10003     }
10004     else
10005         o = listkids(o);
10006     return o;
10007 }
10008
10009 OP *
10010 Perl_ck_exists(pTHX_ OP *o)
10011 {
10012     PERL_ARGS_ASSERT_CK_EXISTS;
10013
10014     o = ck_fun(o);
10015     if (o->op_flags & OPf_KIDS) {
10016         OP * const kid = cUNOPo->op_first;
10017         if (kid->op_type == OP_ENTERSUB) {
10018             (void) ref(kid, o->op_type);
10019             if (kid->op_type != OP_RV2CV
10020                         && !(PL_parser && PL_parser->error_count))
10021                 Perl_croak(aTHX_
10022                           "exists argument is not a subroutine name");
10023             o->op_private |= OPpEXISTS_SUB;
10024         }
10025         else if (kid->op_type == OP_AELEM)
10026             o->op_flags |= OPf_SPECIAL;
10027         else if (kid->op_type != OP_HELEM)
10028             Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
10029                              "element or a subroutine");
10030         op_null(kid);
10031     }
10032     return o;
10033 }
10034
10035 OP *
10036 Perl_ck_rvconst(pTHX_ OP *o)
10037 {
10038     dVAR;
10039     SVOP * const kid = (SVOP*)cUNOPo->op_first;
10040
10041     PERL_ARGS_ASSERT_CK_RVCONST;
10042
10043     if (o->op_type == OP_RV2HV)
10044         /* rv2hv steals the bottom bit for its own uses */
10045         o->op_private &= ~OPpARG1_MASK;
10046
10047     o->op_private |= (PL_hints & HINT_STRICT_REFS);
10048
10049     if (kid->op_type == OP_CONST) {
10050         int iscv;
10051         GV *gv;
10052         SV * const kidsv = kid->op_sv;
10053
10054         /* Is it a constant from cv_const_sv()? */
10055         if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
10056             return o;
10057         }
10058         if (SvTYPE(kidsv) == SVt_PVAV) return o;
10059         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
10060             const char *badthing;
10061             switch (o->op_type) {
10062             case OP_RV2SV:
10063                 badthing = "a SCALAR";
10064                 break;
10065             case OP_RV2AV:
10066                 badthing = "an ARRAY";
10067                 break;
10068             case OP_RV2HV:
10069                 badthing = "a HASH";
10070                 break;
10071             default:
10072                 badthing = NULL;
10073                 break;
10074             }
10075             if (badthing)
10076                 Perl_croak(aTHX_
10077                            "Can't use bareword (\"%" SVf "\") as %s ref while \"strict refs\" in use",
10078                            SVfARG(kidsv), badthing);
10079         }
10080         /*
10081          * This is a little tricky.  We only want to add the symbol if we
10082          * didn't add it in the lexer.  Otherwise we get duplicate strict
10083          * warnings.  But if we didn't add it in the lexer, we must at
10084          * least pretend like we wanted to add it even if it existed before,
10085          * or we get possible typo warnings.  OPpCONST_ENTERED says
10086          * whether the lexer already added THIS instance of this symbol.
10087          */
10088         iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
10089         gv = gv_fetchsv(kidsv,
10090                 o->op_type == OP_RV2CV
10091                         && o->op_private & OPpMAY_RETURN_CONSTANT
10092                     ? GV_NOEXPAND
10093                     : iscv | !(kid->op_private & OPpCONST_ENTERED),
10094                 iscv
10095                     ? SVt_PVCV
10096                     : o->op_type == OP_RV2SV
10097                         ? SVt_PV
10098                         : o->op_type == OP_RV2AV
10099                             ? SVt_PVAV
10100                             : o->op_type == OP_RV2HV
10101                                 ? SVt_PVHV
10102                                 : SVt_PVGV);
10103         if (gv) {
10104             if (!isGV(gv)) {
10105                 assert(iscv);
10106                 assert(SvROK(gv));
10107                 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
10108                   && SvTYPE(SvRV(gv)) != SVt_PVCV)
10109                     gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
10110             }
10111             OpTYPE_set(kid, OP_GV);
10112             SvREFCNT_dec(kid->op_sv);
10113 #ifdef USE_ITHREADS
10114             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
10115             STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
10116             kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
10117             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
10118             PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
10119 #else
10120             kid->op_sv = SvREFCNT_inc_simple_NN(gv);
10121 #endif
10122             kid->op_private = 0;
10123             /* FAKE globs in the symbol table cause weird bugs (#77810) */
10124             SvFAKE_off(gv);
10125         }
10126     }
10127     return o;
10128 }
10129
10130 OP *
10131 Perl_ck_ftst(pTHX_ OP *o)
10132 {
10133     dVAR;
10134     const I32 type = o->op_type;
10135
10136     PERL_ARGS_ASSERT_CK_FTST;
10137
10138     if (o->op_flags & OPf_REF) {
10139         NOOP;
10140     }
10141     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
10142         SVOP * const kid = (SVOP*)cUNOPo->op_first;
10143         const OPCODE kidtype = kid->op_type;
10144
10145         if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
10146          && !kid->op_folded) {
10147             OP * const newop = newGVOP(type, OPf_REF,
10148                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
10149             op_free(o);
10150             return newop;
10151         }
10152
10153         if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
10154             SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
10155             if (name) {
10156                 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
10157                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
10158                             array_passed_to_stat, name);
10159             }
10160             else {
10161                 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
10162                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
10163             }
10164        }
10165         scalar((OP *) kid);
10166         if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
10167             o->op_private |= OPpFT_ACCESS;
10168         if (type != OP_STAT && type != OP_LSTAT
10169             && PL_check[kidtype] == Perl_ck_ftst
10170             && kidtype != OP_STAT && kidtype != OP_LSTAT
10171         ) {
10172             o->op_private |= OPpFT_STACKED;
10173             kid->op_private |= OPpFT_STACKING;
10174             if (kidtype == OP_FTTTY && (
10175                    !(kid->op_private & OPpFT_STACKED)
10176                 || kid->op_private & OPpFT_AFTER_t
10177                ))
10178                 o->op_private |= OPpFT_AFTER_t;
10179         }
10180     }
10181     else {
10182         op_free(o);
10183         if (type == OP_FTTTY)
10184             o = newGVOP(type, OPf_REF, PL_stdingv);
10185         else
10186             o = newUNOP(type, 0, newDEFSVOP());
10187     }
10188     return o;
10189 }
10190
10191 OP *
10192 Perl_ck_fun(pTHX_ OP *o)
10193 {
10194     const int type = o->op_type;
10195     I32 oa = PL_opargs[type] >> OASHIFT;
10196
10197     PERL_ARGS_ASSERT_CK_FUN;
10198
10199     if (o->op_flags & OPf_STACKED) {
10200         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
10201             oa &= ~OA_OPTIONAL;
10202         else
10203             return no_fh_allowed(o);
10204     }
10205
10206     if (o->op_flags & OPf_KIDS) {
10207         OP *prev_kid = NULL;
10208         OP *kid = cLISTOPo->op_first;
10209         I32 numargs = 0;
10210         bool seen_optional = FALSE;
10211
10212         if (kid->op_type == OP_PUSHMARK ||
10213             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
10214         {
10215             prev_kid = kid;
10216             kid = OpSIBLING(kid);
10217         }
10218         if (kid && kid->op_type == OP_COREARGS) {
10219             bool optional = FALSE;
10220             while (oa) {
10221                 numargs++;
10222                 if (oa & OA_OPTIONAL) optional = TRUE;
10223                 oa = oa >> 4;
10224             }
10225             if (optional) o->op_private |= numargs;
10226             return o;
10227         }
10228
10229         while (oa) {
10230             if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
10231                 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
10232                     kid = newDEFSVOP();
10233                     /* append kid to chain */
10234                     op_sibling_splice(o, prev_kid, 0, kid);
10235                 }
10236                 seen_optional = TRUE;
10237             }
10238             if (!kid) break;
10239
10240             numargs++;
10241             switch (oa & 7) {
10242             case OA_SCALAR:
10243                 /* list seen where single (scalar) arg expected? */
10244                 if (numargs == 1 && !(oa >> 4)
10245                     && kid->op_type == OP_LIST && type != OP_SCALAR)
10246                 {
10247                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
10248                 }
10249                 if (type != OP_DELETE) scalar(kid);
10250                 break;
10251             case OA_LIST:
10252                 if (oa < 16) {
10253                     kid = 0;
10254                     continue;
10255                 }
10256                 else
10257                     list(kid);
10258                 break;
10259             case OA_AVREF:
10260                 if ((type == OP_PUSH || type == OP_UNSHIFT)
10261                     && !OpHAS_SIBLING(kid))
10262                     Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10263                                    "Useless use of %s with no values",
10264                                    PL_op_desc[type]);
10265
10266                 if (kid->op_type == OP_CONST
10267                       && (  !SvROK(cSVOPx_sv(kid))
10268                          || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV  )
10269                         )
10270                     bad_type_pv(numargs, "array", o, kid);
10271                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
10272                     yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
10273                                          PL_op_desc[type]), 0);
10274                 }
10275                 else {
10276                     op_lvalue(kid, type);
10277                 }
10278                 break;
10279             case OA_HVREF:
10280                 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
10281                     bad_type_pv(numargs, "hash", o, kid);
10282                 op_lvalue(kid, type);
10283                 break;
10284             case OA_CVREF:
10285                 {
10286                     /* replace kid with newop in chain */
10287                     OP * const newop =
10288                         S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
10289                     newop->op_next = newop;
10290                     kid = newop;
10291                 }
10292                 break;
10293             case OA_FILEREF:
10294                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
10295                     if (kid->op_type == OP_CONST &&
10296                         (kid->op_private & OPpCONST_BARE))
10297                     {
10298                         OP * const newop = newGVOP(OP_GV, 0,
10299                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
10300                         /* replace kid with newop in chain */
10301                         op_sibling_splice(o, prev_kid, 1, newop);
10302                         op_free(kid);
10303                         kid = newop;
10304                     }
10305                     else if (kid->op_type == OP_READLINE) {
10306                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
10307                         bad_type_pv(numargs, "HANDLE", o, kid);
10308                     }
10309                     else {
10310                         I32 flags = OPf_SPECIAL;
10311                         I32 priv = 0;
10312                         PADOFFSET targ = 0;
10313
10314                         /* is this op a FH constructor? */
10315                         if (is_handle_constructor(o,numargs)) {
10316                             const char *name = NULL;
10317                             STRLEN len = 0;
10318                             U32 name_utf8 = 0;
10319                             bool want_dollar = TRUE;
10320
10321                             flags = 0;
10322                             /* Set a flag to tell rv2gv to vivify
10323                              * need to "prove" flag does not mean something
10324                              * else already - NI-S 1999/05/07
10325                              */
10326                             priv = OPpDEREF;
10327                             if (kid->op_type == OP_PADSV) {
10328                                 PADNAME * const pn
10329                                     = PAD_COMPNAME_SV(kid->op_targ);
10330                                 name = PadnamePV (pn);
10331                                 len  = PadnameLEN(pn);
10332                                 name_utf8 = PadnameUTF8(pn);
10333                             }
10334                             else if (kid->op_type == OP_RV2SV
10335                                      && kUNOP->op_first->op_type == OP_GV)
10336                             {
10337                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
10338                                 name = GvNAME(gv);
10339                                 len = GvNAMELEN(gv);
10340                                 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
10341                             }
10342                             else if (kid->op_type == OP_AELEM
10343                                      || kid->op_type == OP_HELEM)
10344                             {
10345                                  OP *firstop;
10346                                  OP *op = ((BINOP*)kid)->op_first;
10347                                  name = NULL;
10348                                  if (op) {
10349                                       SV *tmpstr = NULL;
10350                                       const char * const a =
10351                                            kid->op_type == OP_AELEM ?
10352                                            "[]" : "{}";
10353                                       if (((op->op_type == OP_RV2AV) ||
10354                                            (op->op_type == OP_RV2HV)) &&
10355                                           (firstop = ((UNOP*)op)->op_first) &&
10356                                           (firstop->op_type == OP_GV)) {
10357                                            /* packagevar $a[] or $h{} */
10358                                            GV * const gv = cGVOPx_gv(firstop);
10359                                            if (gv)
10360                                                 tmpstr =
10361                                                      Perl_newSVpvf(aTHX_
10362                                                                    "%s%c...%c",
10363                                                                    GvNAME(gv),
10364                                                                    a[0], a[1]);
10365                                       }
10366                                       else if (op->op_type == OP_PADAV
10367                                                || op->op_type == OP_PADHV) {
10368                                            /* lexicalvar $a[] or $h{} */
10369                                            const char * const padname =
10370                                                 PAD_COMPNAME_PV(op->op_targ);
10371                                            if (padname)
10372                                                 tmpstr =
10373                                                      Perl_newSVpvf(aTHX_
10374                                                                    "%s%c...%c",
10375                                                                    padname + 1,
10376                                                                    a[0], a[1]);
10377                                       }
10378                                       if (tmpstr) {
10379                                            name = SvPV_const(tmpstr, len);
10380                                            name_utf8 = SvUTF8(tmpstr);
10381                                            sv_2mortal(tmpstr);
10382                                       }
10383                                  }
10384                                  if (!name) {
10385                                       name = "__ANONIO__";
10386                                       len = 10;
10387                                       want_dollar = FALSE;
10388                                  }
10389                                  op_lvalue(kid, type);
10390                             }
10391                             if (name) {
10392                                 SV *namesv;
10393                                 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
10394                                 namesv = PAD_SVl(targ);
10395                                 if (want_dollar && *name != '$')
10396                                     sv_setpvs(namesv, "$");
10397                                 else
10398                                     SvPVCLEAR(namesv);
10399                                 sv_catpvn(namesv, name, len);
10400                                 if ( name_utf8 ) SvUTF8_on(namesv);
10401                             }
10402                         }
10403                         scalar(kid);
10404                         kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
10405                                     OP_RV2GV, flags);
10406                         kid->op_targ = targ;
10407                         kid->op_private |= priv;
10408                     }
10409                 }
10410                 scalar(kid);
10411                 break;
10412             case OA_SCALARREF:
10413                 if ((type == OP_UNDEF || type == OP_POS)
10414                     && numargs == 1 && !(oa >> 4)
10415                     && kid->op_type == OP_LIST)
10416                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
10417                 op_lvalue(scalar(kid), type);
10418                 break;
10419             }
10420             oa >>= 4;
10421             prev_kid = kid;
10422             kid = OpSIBLING(kid);
10423         }
10424         /* FIXME - should the numargs or-ing move after the too many
10425          * arguments check? */
10426         o->op_private |= numargs;
10427         if (kid)
10428             return too_many_arguments_pv(o,OP_DESC(o), 0);
10429         listkids(o);
10430     }
10431     else if (PL_opargs[type] & OA_DEFGV) {
10432         /* Ordering of these two is important to keep f_map.t passing.  */
10433         op_free(o);
10434         return newUNOP(type, 0, newDEFSVOP());
10435     }
10436
10437     if (oa) {
10438         while (oa & OA_OPTIONAL)
10439             oa >>= 4;
10440         if (oa && oa != OA_LIST)
10441             return too_few_arguments_pv(o,OP_DESC(o), 0);
10442     }
10443     return o;
10444 }
10445
10446 OP *
10447 Perl_ck_glob(pTHX_ OP *o)
10448 {
10449     GV *gv;
10450
10451     PERL_ARGS_ASSERT_CK_GLOB;
10452
10453     o = ck_fun(o);
10454     if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
10455         op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
10456
10457     if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
10458     {
10459         /* convert
10460          *     glob
10461          *       \ null - const(wildcard)
10462          * into
10463          *     null
10464          *       \ enter
10465          *            \ list
10466          *                 \ mark - glob - rv2cv
10467          *                             |        \ gv(CORE::GLOBAL::glob)
10468          *                             |
10469          *                              \ null - const(wildcard)
10470          */
10471         o->op_flags |= OPf_SPECIAL;
10472         o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
10473         o = S_new_entersubop(aTHX_ gv, o);
10474         o = newUNOP(OP_NULL, 0, o);
10475         o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
10476         return o;
10477     }
10478     else o->op_flags &= ~OPf_SPECIAL;
10479 #if !defined(PERL_EXTERNAL_GLOB)
10480     if (!PL_globhook) {
10481         ENTER;
10482         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
10483                                newSVpvs("File::Glob"), NULL, NULL, NULL);
10484         LEAVE;
10485     }
10486 #endif /* !PERL_EXTERNAL_GLOB */
10487     gv = (GV *)newSV(0);
10488     gv_init(gv, 0, "", 0, 0);
10489     gv_IOadd(gv);
10490     op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
10491     SvREFCNT_dec_NN(gv); /* newGVOP increased it */
10492     scalarkids(o);
10493     return o;
10494 }
10495
10496 OP *
10497 Perl_ck_grep(pTHX_ OP *o)
10498 {
10499     LOGOP *gwop;
10500     OP *kid;
10501     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
10502
10503     PERL_ARGS_ASSERT_CK_GREP;
10504
10505     /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
10506
10507     if (o->op_flags & OPf_STACKED) {
10508         kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
10509         if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
10510             return no_fh_allowed(o);
10511         o->op_flags &= ~OPf_STACKED;
10512     }
10513     kid = OpSIBLING(cLISTOPo->op_first);
10514     if (type == OP_MAPWHILE)
10515         list(kid);
10516     else
10517         scalar(kid);
10518     o = ck_fun(o);
10519     if (PL_parser && PL_parser->error_count)
10520         return o;
10521     kid = OpSIBLING(cLISTOPo->op_first);
10522     if (kid->op_type != OP_NULL)
10523         Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
10524     kid = kUNOP->op_first;
10525
10526     gwop = alloc_LOGOP(type, o, LINKLIST(kid));
10527     kid->op_next = (OP*)gwop;
10528     o->op_private = gwop->op_private = 0;
10529     gwop->op_targ = pad_alloc(type, SVs_PADTMP);
10530
10531     kid = OpSIBLING(cLISTOPo->op_first);
10532     for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
10533         op_lvalue(kid, OP_GREPSTART);
10534
10535     return (OP*)gwop;
10536 }
10537
10538 OP *
10539 Perl_ck_index(pTHX_ OP *o)
10540 {
10541     PERL_ARGS_ASSERT_CK_INDEX;
10542
10543     if (o->op_flags & OPf_KIDS) {
10544         OP *kid = OpSIBLING(cLISTOPo->op_first);        /* get past pushmark */
10545         if (kid)
10546             kid = OpSIBLING(kid);                       /* get past "big" */
10547         if (kid && kid->op_type == OP_CONST) {
10548             const bool save_taint = TAINT_get;
10549             SV *sv = kSVOP->op_sv;
10550             if (   (!SvPOK(sv) || SvNIOKp(sv) || isREGEXP(sv))
10551                 && SvOK(sv) && !SvROK(sv))
10552             {
10553                 sv = newSV(0);
10554                 sv_copypv(sv, kSVOP->op_sv);
10555                 SvREFCNT_dec_NN(kSVOP->op_sv);
10556                 kSVOP->op_sv = sv;
10557             }
10558             if (SvOK(sv)) fbm_compile(sv, 0);
10559             TAINT_set(save_taint);
10560 #ifdef NO_TAINT_SUPPORT
10561             PERL_UNUSED_VAR(save_taint);
10562 #endif
10563         }
10564     }
10565     return ck_fun(o);
10566 }
10567
10568 OP *
10569 Perl_ck_lfun(pTHX_ OP *o)
10570 {
10571     const OPCODE type = o->op_type;
10572
10573     PERL_ARGS_ASSERT_CK_LFUN;
10574
10575     return modkids(ck_fun(o), type);
10576 }
10577
10578 OP *
10579 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
10580 {
10581     PERL_ARGS_ASSERT_CK_DEFINED;
10582
10583     if ((o->op_flags & OPf_KIDS)) {
10584         switch (cUNOPo->op_first->op_type) {
10585         case OP_RV2AV:
10586         case OP_PADAV:
10587             Perl_croak(aTHX_ "Can't use 'defined(@array)'"
10588                              " (Maybe you should just omit the defined()?)");
10589             NOT_REACHED; /* NOTREACHED */
10590             break;
10591         case OP_RV2HV:
10592         case OP_PADHV:
10593             Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
10594                              " (Maybe you should just omit the defined()?)");
10595             NOT_REACHED; /* NOTREACHED */
10596             break;
10597         default:
10598             /* no warning */
10599             break;
10600         }
10601     }
10602     return ck_rfun(o);
10603 }
10604
10605 OP *
10606 Perl_ck_readline(pTHX_ OP *o)
10607 {
10608     PERL_ARGS_ASSERT_CK_READLINE;
10609
10610     if (o->op_flags & OPf_KIDS) {
10611          OP *kid = cLISTOPo->op_first;
10612          if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
10613     }
10614     else {
10615         OP * const newop
10616             = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
10617         op_free(o);
10618         return newop;
10619     }
10620     return o;
10621 }
10622
10623 OP *
10624 Perl_ck_rfun(pTHX_ OP *o)
10625 {
10626     const OPCODE type = o->op_type;
10627
10628     PERL_ARGS_ASSERT_CK_RFUN;
10629
10630     return refkids(ck_fun(o), type);
10631 }
10632
10633 OP *
10634 Perl_ck_listiob(pTHX_ OP *o)
10635 {
10636     OP *kid;
10637
10638     PERL_ARGS_ASSERT_CK_LISTIOB;
10639
10640     kid = cLISTOPo->op_first;
10641     if (!kid) {
10642         o = force_list(o, 1);
10643         kid = cLISTOPo->op_first;
10644     }
10645     if (kid->op_type == OP_PUSHMARK)
10646         kid = OpSIBLING(kid);
10647     if (kid && o->op_flags & OPf_STACKED)
10648         kid = OpSIBLING(kid);
10649     else if (kid && !OpHAS_SIBLING(kid)) {              /* print HANDLE; */
10650         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
10651          && !kid->op_folded) {
10652             o->op_flags |= OPf_STACKED; /* make it a filehandle */
10653             scalar(kid);
10654             /* replace old const op with new OP_RV2GV parent */
10655             kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
10656                                         OP_RV2GV, OPf_REF);
10657             kid = OpSIBLING(kid);
10658         }
10659     }
10660
10661     if (!kid)
10662         op_append_elem(o->op_type, o, newDEFSVOP());
10663
10664     if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
10665     return listkids(o);
10666 }
10667
10668 OP *
10669 Perl_ck_smartmatch(pTHX_ OP *o)
10670 {
10671     dVAR;
10672     PERL_ARGS_ASSERT_CK_SMARTMATCH;
10673     if (0 == (o->op_flags & OPf_SPECIAL)) {
10674         OP *first  = cBINOPo->op_first;
10675         OP *second = OpSIBLING(first);
10676
10677         /* Implicitly take a reference to an array or hash */
10678
10679         /* remove the original two siblings, then add back the
10680          * (possibly different) first and second sibs.
10681          */
10682         op_sibling_splice(o, NULL, 1, NULL);
10683         op_sibling_splice(o, NULL, 1, NULL);
10684         first  = ref_array_or_hash(first);
10685         second = ref_array_or_hash(second);
10686         op_sibling_splice(o, NULL, 0, second);
10687         op_sibling_splice(o, NULL, 0, first);
10688
10689         /* Implicitly take a reference to a regular expression */
10690         if (first->op_type == OP_MATCH && !(first->op_flags & OPf_STACKED)) {
10691             OpTYPE_set(first, OP_QR);
10692         }
10693         if (second->op_type == OP_MATCH && !(second->op_flags & OPf_STACKED)) {
10694             OpTYPE_set(second, OP_QR);
10695         }
10696     }
10697
10698     return o;
10699 }
10700
10701
10702 static OP *
10703 S_maybe_targlex(pTHX_ OP *o)
10704 {
10705     OP * const kid = cLISTOPo->op_first;
10706     /* has a disposable target? */
10707     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
10708         && !(kid->op_flags & OPf_STACKED)
10709         /* Cannot steal the second time! */
10710         && !(kid->op_private & OPpTARGET_MY)
10711         )
10712     {
10713         OP * const kkid = OpSIBLING(kid);
10714
10715         /* Can just relocate the target. */
10716         if (kkid && kkid->op_type == OP_PADSV
10717             && (!(kkid->op_private & OPpLVAL_INTRO)
10718                || kkid->op_private & OPpPAD_STATE))
10719         {
10720             kid->op_targ = kkid->op_targ;
10721             kkid->op_targ = 0;
10722             /* Now we do not need PADSV and SASSIGN.
10723              * Detach kid and free the rest. */
10724             op_sibling_splice(o, NULL, 1, NULL);
10725             op_free(o);
10726             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
10727             return kid;
10728         }
10729     }
10730     return o;
10731 }
10732
10733 OP *
10734 Perl_ck_sassign(pTHX_ OP *o)
10735 {
10736     dVAR;
10737     OP * const kid = cBINOPo->op_first;
10738
10739     PERL_ARGS_ASSERT_CK_SASSIGN;
10740
10741     if (OpHAS_SIBLING(kid)) {
10742         OP *kkid = OpSIBLING(kid);
10743         /* For state variable assignment with attributes, kkid is a list op
10744            whose op_last is a padsv. */
10745         if ((kkid->op_type == OP_PADSV ||
10746              (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
10747               (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
10748              )
10749             )
10750                 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
10751                     == (OPpLVAL_INTRO|OPpPAD_STATE)) {
10752             const PADOFFSET target = kkid->op_targ;
10753             OP *const other = newOP(OP_PADSV,
10754                                     kkid->op_flags
10755                                     | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
10756             OP *const first = newOP(OP_NULL, 0);
10757             OP *const nullop =
10758                 newCONDOP(0, first, o, other);
10759             /* XXX targlex disabled for now; see ticket #124160
10760                 newCONDOP(0, first, S_maybe_targlex(aTHX_ o), other);
10761              */
10762             OP *const condop = first->op_next;
10763
10764             OpTYPE_set(condop, OP_ONCE);
10765             other->op_targ = target;
10766             nullop->op_flags |= OPf_WANT_SCALAR;
10767
10768             /* Store the initializedness of state vars in a separate
10769                pad entry.  */
10770             condop->op_targ =
10771               pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
10772             /* hijacking PADSTALE for uninitialized state variables */
10773             SvPADSTALE_on(PAD_SVl(condop->op_targ));
10774
10775             return nullop;
10776         }
10777     }
10778     return S_maybe_targlex(aTHX_ o);
10779 }
10780
10781 OP *
10782 Perl_ck_match(pTHX_ OP *o)
10783 {
10784     PERL_UNUSED_CONTEXT;
10785     PERL_ARGS_ASSERT_CK_MATCH;
10786
10787     return o;
10788 }
10789
10790 OP *
10791 Perl_ck_method(pTHX_ OP *o)
10792 {
10793     SV *sv, *methsv, *rclass;
10794     const char* method;
10795     char* compatptr;
10796     int utf8;
10797     STRLEN len, nsplit = 0, i;
10798     OP* new_op;
10799     OP * const kid = cUNOPo->op_first;
10800
10801     PERL_ARGS_ASSERT_CK_METHOD;
10802     if (kid->op_type != OP_CONST) return o;
10803
10804     sv = kSVOP->op_sv;
10805
10806     /* replace ' with :: */
10807     while ((compatptr = strchr(SvPVX(sv), '\''))) {
10808         *compatptr = ':';
10809         sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
10810     }
10811
10812     method = SvPVX_const(sv);
10813     len = SvCUR(sv);
10814     utf8 = SvUTF8(sv) ? -1 : 1;
10815
10816     for (i = len - 1; i > 0; --i) if (method[i] == ':') {
10817         nsplit = i+1;
10818         break;
10819     }
10820
10821     methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
10822
10823     if (!nsplit) { /* $proto->method() */
10824         op_free(o);
10825         return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
10826     }
10827
10828     if (nsplit == 7 && memEQ(method, "SUPER::", nsplit)) { /* $proto->SUPER::method() */
10829         op_free(o);
10830         return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
10831     }
10832
10833     /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
10834     if (nsplit >= 9 && strnEQ(method+nsplit-9, "::SUPER::", 9)) {
10835         rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
10836         new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
10837     } else {
10838         rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
10839         new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
10840     }
10841 #ifdef USE_ITHREADS
10842     op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
10843 #else
10844     cMETHOPx(new_op)->op_rclass_sv = rclass;
10845 #endif
10846     op_free(o);
10847     return new_op;
10848 }
10849
10850 OP *
10851 Perl_ck_null(pTHX_ OP *o)
10852 {
10853     PERL_ARGS_ASSERT_CK_NULL;
10854     PERL_UNUSED_CONTEXT;
10855     return o;
10856 }
10857
10858 OP *
10859 Perl_ck_open(pTHX_ OP *o)
10860 {
10861     PERL_ARGS_ASSERT_CK_OPEN;
10862
10863     S_io_hints(aTHX_ o);
10864     {
10865          /* In case of three-arg dup open remove strictness
10866           * from the last arg if it is a bareword. */
10867          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
10868          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
10869          OP *oa;
10870          const char *mode;
10871
10872          if ((last->op_type == OP_CONST) &&             /* The bareword. */
10873              (last->op_private & OPpCONST_BARE) &&
10874              (last->op_private & OPpCONST_STRICT) &&
10875              (oa = OpSIBLING(first)) &&         /* The fh. */
10876              (oa = OpSIBLING(oa)) &&                    /* The mode. */
10877              (oa->op_type == OP_CONST) &&
10878              SvPOK(((SVOP*)oa)->op_sv) &&
10879              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
10880              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
10881              (last == OpSIBLING(oa)))                   /* The bareword. */
10882               last->op_private &= ~OPpCONST_STRICT;
10883     }
10884     return ck_fun(o);
10885 }
10886
10887 OP *
10888 Perl_ck_prototype(pTHX_ OP *o)
10889 {
10890     PERL_ARGS_ASSERT_CK_PROTOTYPE;
10891     if (!(o->op_flags & OPf_KIDS)) {
10892         op_free(o);
10893         return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
10894     }
10895     return o;
10896 }
10897
10898 OP *
10899 Perl_ck_refassign(pTHX_ OP *o)
10900 {
10901     OP * const right = cLISTOPo->op_first;
10902     OP * const left = OpSIBLING(right);
10903     OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
10904     bool stacked = 0;
10905
10906     PERL_ARGS_ASSERT_CK_REFASSIGN;
10907     assert (left);
10908     assert (left->op_type == OP_SREFGEN);
10909
10910     o->op_private = 0;
10911     /* we use OPpPAD_STATE in refassign to mean either of those things,
10912      * and the code assumes the two flags occupy the same bit position
10913      * in the various ops below */
10914     assert(OPpPAD_STATE == OPpOUR_INTRO);
10915
10916     switch (varop->op_type) {
10917     case OP_PADAV:
10918         o->op_private |= OPpLVREF_AV;
10919         goto settarg;
10920     case OP_PADHV:
10921         o->op_private |= OPpLVREF_HV;
10922         /* FALLTHROUGH */
10923     case OP_PADSV:
10924       settarg:
10925         o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
10926         o->op_targ = varop->op_targ;
10927         varop->op_targ = 0;
10928         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
10929         break;
10930
10931     case OP_RV2AV:
10932         o->op_private |= OPpLVREF_AV;
10933         goto checkgv;
10934         NOT_REACHED; /* NOTREACHED */
10935     case OP_RV2HV:
10936         o->op_private |= OPpLVREF_HV;
10937         /* FALLTHROUGH */
10938     case OP_RV2SV:
10939       checkgv:
10940         o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
10941         if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
10942       detach_and_stack:
10943         /* Point varop to its GV kid, detached.  */
10944         varop = op_sibling_splice(varop, NULL, -1, NULL);
10945         stacked = TRUE;
10946         break;
10947     case OP_RV2CV: {
10948         OP * const kidparent =
10949             OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
10950         OP * const kid = cUNOPx(kidparent)->op_first;
10951         o->op_private |= OPpLVREF_CV;
10952         if (kid->op_type == OP_GV) {
10953             varop = kidparent;
10954             goto detach_and_stack;
10955         }
10956         if (kid->op_type != OP_PADCV)   goto bad;
10957         o->op_targ = kid->op_targ;
10958         kid->op_targ = 0;
10959         break;
10960     }
10961     case OP_AELEM:
10962     case OP_HELEM:
10963         o->op_private |= (varop->op_private & OPpLVAL_INTRO);
10964         o->op_private |= OPpLVREF_ELEM;
10965         op_null(varop);
10966         stacked = TRUE;
10967         /* Detach varop.  */
10968         op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
10969         break;
10970     default:
10971       bad:
10972         /* diag_listed_as: Can't modify reference to %s in %s assignment */
10973         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
10974                                 "assignment",
10975                                  OP_DESC(varop)));
10976         return o;
10977     }
10978     if (!FEATURE_REFALIASING_IS_ENABLED)
10979         Perl_croak(aTHX_
10980                   "Experimental aliasing via reference not enabled");
10981     Perl_ck_warner_d(aTHX_
10982                      packWARN(WARN_EXPERIMENTAL__REFALIASING),
10983                     "Aliasing via reference is experimental");
10984     if (stacked) {
10985         o->op_flags |= OPf_STACKED;
10986         op_sibling_splice(o, right, 1, varop);
10987     }
10988     else {
10989         o->op_flags &=~ OPf_STACKED;
10990         op_sibling_splice(o, right, 1, NULL);
10991     }
10992     op_free(left);
10993     return o;
10994 }
10995
10996 OP *
10997 Perl_ck_repeat(pTHX_ OP *o)
10998 {
10999     PERL_ARGS_ASSERT_CK_REPEAT;
11000
11001     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
11002         OP* kids;
11003         o->op_private |= OPpREPEAT_DOLIST;
11004         kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
11005         kids = force_list(kids, 1); /* promote it to a list */
11006         op_sibling_splice(o, NULL, 0, kids); /* and add back */
11007     }
11008     else
11009         scalar(o);
11010     return o;
11011 }
11012
11013 OP *
11014 Perl_ck_require(pTHX_ OP *o)
11015 {
11016     GV* gv;
11017
11018     PERL_ARGS_ASSERT_CK_REQUIRE;
11019
11020     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
11021         SVOP * const kid = (SVOP*)cUNOPo->op_first;
11022         U32 hash;
11023         char *s;
11024         STRLEN len;
11025         if (kid->op_type == OP_CONST) {
11026           SV * const sv = kid->op_sv;
11027           U32 const was_readonly = SvREADONLY(sv);
11028           if (kid->op_private & OPpCONST_BARE) {
11029             dVAR;
11030             const char *end;
11031             HEK *hek;
11032
11033             if (was_readonly) {
11034                     SvREADONLY_off(sv);
11035             }
11036             if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
11037
11038             s = SvPVX(sv);
11039             len = SvCUR(sv);
11040             end = s + len;
11041             /* treat ::foo::bar as foo::bar */
11042             if (len >= 2 && s[0] == ':' && s[1] == ':')
11043                 DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
11044             if (s == end)
11045                 DIE(aTHX_ "Bareword in require maps to empty filename");
11046
11047             for (; s < end; s++) {
11048                 if (*s == ':' && s[1] == ':') {
11049                     *s = '/';
11050                     Move(s+2, s+1, end - s - 1, char);
11051                     --end;
11052                 }
11053             }
11054             SvEND_set(sv, end);
11055             sv_catpvs(sv, ".pm");
11056             PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
11057             hek = share_hek(SvPVX(sv),
11058                             (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
11059                             hash);
11060             sv_sethek(sv, hek);
11061             unshare_hek(hek);
11062             SvFLAGS(sv) |= was_readonly;
11063           }
11064           else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
11065                 && !SvVOK(sv)) {
11066             s = SvPV(sv, len);
11067             if (SvREFCNT(sv) > 1) {
11068                 kid->op_sv = newSVpvn_share(
11069                     s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
11070                 SvREFCNT_dec_NN(sv);
11071             }
11072             else {
11073                 dVAR;
11074                 HEK *hek;
11075                 if (was_readonly) SvREADONLY_off(sv);
11076                 PERL_HASH(hash, s, len);
11077                 hek = share_hek(s,
11078                                 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
11079                                 hash);
11080                 sv_sethek(sv, hek);
11081                 unshare_hek(hek);
11082                 SvFLAGS(sv) |= was_readonly;
11083             }
11084           }
11085         }
11086     }
11087
11088     if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
11089         /* handle override, if any */
11090      && (gv = gv_override("require", 7))) {
11091         OP *kid, *newop;
11092         if (o->op_flags & OPf_KIDS) {
11093             kid = cUNOPo->op_first;
11094             op_sibling_splice(o, NULL, -1, NULL);
11095         }
11096         else {
11097             kid = newDEFSVOP();
11098         }
11099         op_free(o);
11100         newop = S_new_entersubop(aTHX_ gv, kid);
11101         return newop;
11102     }
11103
11104     return ck_fun(o);
11105 }
11106
11107 OP *
11108 Perl_ck_return(pTHX_ OP *o)
11109 {
11110     OP *kid;
11111
11112     PERL_ARGS_ASSERT_CK_RETURN;
11113
11114     kid = OpSIBLING(cLISTOPo->op_first);
11115     if (PL_compcv && CvLVALUE(PL_compcv)) {
11116         for (; kid; kid = OpSIBLING(kid))
11117             op_lvalue(kid, OP_LEAVESUBLV);
11118     }
11119
11120     return o;
11121 }
11122
11123 OP *
11124 Perl_ck_select(pTHX_ OP *o)
11125 {
11126     dVAR;
11127     OP* kid;
11128
11129     PERL_ARGS_ASSERT_CK_SELECT;
11130
11131     if (o->op_flags & OPf_KIDS) {
11132         kid = OpSIBLING(cLISTOPo->op_first);     /* get past pushmark */
11133         if (kid && OpHAS_SIBLING(kid)) {
11134             OpTYPE_set(o, OP_SSELECT);
11135             o = ck_fun(o);
11136             return fold_constants(op_integerize(op_std_init(o)));
11137         }
11138     }
11139     o = ck_fun(o);
11140     kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
11141     if (kid && kid->op_type == OP_RV2GV)
11142         kid->op_private &= ~HINT_STRICT_REFS;
11143     return o;
11144 }
11145
11146 OP *
11147 Perl_ck_shift(pTHX_ OP *o)
11148 {
11149     const I32 type = o->op_type;
11150
11151     PERL_ARGS_ASSERT_CK_SHIFT;
11152
11153     if (!(o->op_flags & OPf_KIDS)) {
11154         OP *argop;
11155
11156         if (!CvUNIQUE(PL_compcv)) {
11157             o->op_flags |= OPf_SPECIAL;
11158             return o;
11159         }
11160
11161         argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
11162         op_free(o);
11163         return newUNOP(type, 0, scalar(argop));
11164     }
11165     return scalar(ck_fun(o));
11166 }
11167
11168 OP *
11169 Perl_ck_sort(pTHX_ OP *o)
11170 {
11171     OP *firstkid;
11172     OP *kid;
11173     HV * const hinthv =
11174         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
11175     U8 stacked;
11176
11177     PERL_ARGS_ASSERT_CK_SORT;
11178
11179     if (hinthv) {
11180             SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
11181             if (svp) {
11182                 const I32 sorthints = (I32)SvIV(*svp);
11183                 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
11184                     o->op_private |= OPpSORT_QSORT;
11185                 if ((sorthints & HINT_SORT_STABLE) != 0)
11186                     o->op_private |= OPpSORT_STABLE;
11187                 if ((sorthints & HINT_SORT_UNSTABLE) != 0)
11188                     o->op_private |= OPpSORT_UNSTABLE;
11189             }
11190     }
11191
11192     if (o->op_flags & OPf_STACKED)
11193         simplify_sort(o);
11194     firstkid = OpSIBLING(cLISTOPo->op_first);           /* get past pushmark */
11195
11196     if ((stacked = o->op_flags & OPf_STACKED)) {        /* may have been cleared */
11197         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
11198
11199         /* if the first arg is a code block, process it and mark sort as
11200          * OPf_SPECIAL */
11201         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
11202             LINKLIST(kid);
11203             if (kid->op_type == OP_LEAVE)
11204                     op_null(kid);                       /* wipe out leave */
11205             /* Prevent execution from escaping out of the sort block. */
11206             kid->op_next = 0;
11207
11208             /* provide scalar context for comparison function/block */
11209             kid = scalar(firstkid);
11210             kid->op_next = kid;
11211             o->op_flags |= OPf_SPECIAL;
11212         }
11213         else if (kid->op_type == OP_CONST
11214               && kid->op_private & OPpCONST_BARE) {
11215             char tmpbuf[256];
11216             STRLEN len;
11217             PADOFFSET off;
11218             const char * const name = SvPV(kSVOP_sv, len);
11219             *tmpbuf = '&';
11220             assert (len < 256);
11221             Copy(name, tmpbuf+1, len, char);
11222             off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv));
11223             if (off != NOT_IN_PAD) {
11224                 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
11225                     SV * const fq =
11226                         newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
11227                     sv_catpvs(fq, "::");
11228                     sv_catsv(fq, kSVOP_sv);
11229                     SvREFCNT_dec_NN(kSVOP_sv);
11230                     kSVOP->op_sv = fq;
11231                 }
11232                 else {
11233                     OP * const padop = newOP(OP_PADCV, 0);
11234                     padop->op_targ = off;
11235                     /* replace the const op with the pad op */
11236                     op_sibling_splice(firstkid, NULL, 1, padop);
11237                     op_free(kid);
11238                 }
11239             }
11240         }
11241
11242         firstkid = OpSIBLING(firstkid);
11243     }
11244
11245     for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
11246         /* provide list context for arguments */
11247         list(kid);
11248         if (stacked)
11249             op_lvalue(kid, OP_GREPSTART);
11250     }
11251
11252     return o;
11253 }
11254
11255 /* for sort { X } ..., where X is one of
11256  *   $a <=> $b, $b <=> $a, $a cmp $b, $b cmp $a
11257  * elide the second child of the sort (the one containing X),
11258  * and set these flags as appropriate
11259         OPpSORT_NUMERIC;
11260         OPpSORT_INTEGER;
11261         OPpSORT_DESCEND;
11262  * Also, check and warn on lexical $a, $b.
11263  */
11264
11265 STATIC void
11266 S_simplify_sort(pTHX_ OP *o)
11267 {
11268     OP *kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
11269     OP *k;
11270     int descending;
11271     GV *gv;
11272     const char *gvname;
11273     bool have_scopeop;
11274
11275     PERL_ARGS_ASSERT_SIMPLIFY_SORT;
11276
11277     kid = kUNOP->op_first;                              /* get past null */
11278     if (!(have_scopeop = kid->op_type == OP_SCOPE)
11279      && kid->op_type != OP_LEAVE)
11280         return;
11281     kid = kLISTOP->op_last;                             /* get past scope */
11282     switch(kid->op_type) {
11283         case OP_NCMP:
11284         case OP_I_NCMP:
11285         case OP_SCMP:
11286             if (!have_scopeop) goto padkids;
11287             break;
11288         default:
11289             return;
11290     }
11291     k = kid;                                            /* remember this node*/
11292     if (kBINOP->op_first->op_type != OP_RV2SV
11293      || kBINOP->op_last ->op_type != OP_RV2SV)
11294     {
11295         /*
11296            Warn about my($a) or my($b) in a sort block, *if* $a or $b is
11297            then used in a comparison.  This catches most, but not
11298            all cases.  For instance, it catches
11299                sort { my($a); $a <=> $b }
11300            but not
11301                sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
11302            (although why you'd do that is anyone's guess).
11303         */
11304
11305        padkids:
11306         if (!ckWARN(WARN_SYNTAX)) return;
11307         kid = kBINOP->op_first;
11308         do {
11309             if (kid->op_type == OP_PADSV) {
11310                 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
11311                 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
11312                  && (  PadnamePV(name)[1] == 'a'
11313                     || PadnamePV(name)[1] == 'b'  ))
11314                     /* diag_listed_as: "my %s" used in sort comparison */
11315                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11316                                      "\"%s %s\" used in sort comparison",
11317                                       PadnameIsSTATE(name)
11318                                         ? "state"
11319                                         : "my",
11320                                       PadnamePV(name));
11321             }
11322         } while ((kid = OpSIBLING(kid)));
11323         return;
11324     }
11325     kid = kBINOP->op_first;                             /* get past cmp */
11326     if (kUNOP->op_first->op_type != OP_GV)
11327         return;
11328     kid = kUNOP->op_first;                              /* get past rv2sv */
11329     gv = kGVOP_gv;
11330     if (GvSTASH(gv) != PL_curstash)
11331         return;
11332     gvname = GvNAME(gv);
11333     if (*gvname == 'a' && gvname[1] == '\0')
11334         descending = 0;
11335     else if (*gvname == 'b' && gvname[1] == '\0')
11336         descending = 1;
11337     else
11338         return;
11339
11340     kid = k;                                            /* back to cmp */
11341     /* already checked above that it is rv2sv */
11342     kid = kBINOP->op_last;                              /* down to 2nd arg */
11343     if (kUNOP->op_first->op_type != OP_GV)
11344         return;
11345     kid = kUNOP->op_first;                              /* get past rv2sv */
11346     gv = kGVOP_gv;
11347     if (GvSTASH(gv) != PL_curstash)
11348         return;
11349     gvname = GvNAME(gv);
11350     if ( descending
11351          ? !(*gvname == 'a' && gvname[1] == '\0')
11352          : !(*gvname == 'b' && gvname[1] == '\0'))
11353         return;
11354     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
11355     if (descending)
11356         o->op_private |= OPpSORT_DESCEND;
11357     if (k->op_type == OP_NCMP)
11358         o->op_private |= OPpSORT_NUMERIC;
11359     if (k->op_type == OP_I_NCMP)
11360         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
11361     kid = OpSIBLING(cLISTOPo->op_first);
11362     /* cut out and delete old block (second sibling) */
11363     op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
11364     op_free(kid);
11365 }
11366
11367 OP *
11368 Perl_ck_split(pTHX_ OP *o)
11369 {
11370     dVAR;
11371     OP *kid;
11372     OP *sibs;
11373
11374     PERL_ARGS_ASSERT_CK_SPLIT;
11375
11376     assert(o->op_type == OP_LIST);
11377
11378     if (o->op_flags & OPf_STACKED)
11379         return no_fh_allowed(o);
11380
11381     kid = cLISTOPo->op_first;
11382     /* delete leading NULL node, then add a CONST if no other nodes */
11383     assert(kid->op_type == OP_NULL);
11384     op_sibling_splice(o, NULL, 1,
11385         OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
11386     op_free(kid);
11387     kid = cLISTOPo->op_first;
11388
11389     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
11390         /* remove match expression, and replace with new optree with
11391          * a match op at its head */
11392         op_sibling_splice(o, NULL, 1, NULL);
11393         /* pmruntime will handle split " " behavior with flag==2 */
11394         kid = pmruntime(newPMOP(OP_MATCH, 0), kid, NULL, 2, 0);
11395         op_sibling_splice(o, NULL, 0, kid);
11396     }
11397
11398     assert(kid->op_type == OP_MATCH || kid->op_type == OP_SPLIT);
11399
11400     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
11401       Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
11402                      "Use of /g modifier is meaningless in split");
11403     }
11404
11405     /* eliminate the split op, and move the match op (plus any children)
11406      * into its place, then convert the match op into a split op. i.e.
11407      *
11408      *  SPLIT                    MATCH                 SPLIT(ex-MATCH)
11409      *    |                        |                     |
11410      *  MATCH - A - B - C   =>     R - A - B - C   =>    R - A - B - C
11411      *    |                        |                     |
11412      *    R                        X - Y                 X - Y
11413      *    |
11414      *    X - Y
11415      *
11416      * (R, if it exists, will be a regcomp op)
11417      */
11418
11419     op_sibling_splice(o, NULL, 1, NULL); /* detach match op from o */
11420     sibs = op_sibling_splice(o, NULL, -1, NULL); /* detach any other sibs */
11421     op_sibling_splice(kid, cLISTOPx(kid)->op_last, 0, sibs); /* and reattach */
11422     OpTYPE_set(kid, OP_SPLIT);
11423     kid->op_flags   = (o->op_flags | (kid->op_flags & OPf_KIDS));
11424     kid->op_private = o->op_private;
11425     op_free(o);
11426     o = kid;
11427     kid = sibs; /* kid is now the string arg of the split */
11428
11429     if (!kid) {
11430         kid = newDEFSVOP();
11431         op_append_elem(OP_SPLIT, o, kid);
11432     }
11433     scalar(kid);
11434
11435     kid = OpSIBLING(kid);
11436     if (!kid) {
11437         kid = newSVOP(OP_CONST, 0, newSViv(0));
11438         op_append_elem(OP_SPLIT, o, kid);
11439         o->op_private |= OPpSPLIT_IMPLIM;
11440     }
11441     scalar(kid);
11442
11443     if (OpHAS_SIBLING(kid))
11444         return too_many_arguments_pv(o,OP_DESC(o), 0);
11445
11446     return o;
11447 }
11448
11449 OP *
11450 Perl_ck_stringify(pTHX_ OP *o)
11451 {
11452     OP * const kid = OpSIBLING(cUNOPo->op_first);
11453     PERL_ARGS_ASSERT_CK_STRINGIFY;
11454     if ((   kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
11455          || kid->op_type == OP_LC   || kid->op_type == OP_LCFIRST
11456          || kid->op_type == OP_UC   || kid->op_type == OP_UCFIRST)
11457         && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
11458     {
11459         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
11460         op_free(o);
11461         return kid;
11462     }
11463     return ck_fun(o);
11464 }
11465
11466 OP *
11467 Perl_ck_join(pTHX_ OP *o)
11468 {
11469     OP * const kid = OpSIBLING(cLISTOPo->op_first);
11470
11471     PERL_ARGS_ASSERT_CK_JOIN;
11472
11473     if (kid && kid->op_type == OP_MATCH) {
11474         if (ckWARN(WARN_SYNTAX)) {
11475             const REGEXP *re = PM_GETRE(kPMOP);
11476             const SV *msg = re
11477                     ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
11478                                             SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
11479                     : newSVpvs_flags( "STRING", SVs_TEMP );
11480             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11481                         "/%" SVf "/ should probably be written as \"%" SVf "\"",
11482                         SVfARG(msg), SVfARG(msg));
11483         }
11484     }
11485     if (kid
11486      && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
11487         || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
11488         || (  kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
11489            && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
11490     {
11491         const OP * const bairn = OpSIBLING(kid); /* the list */
11492         if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
11493          && OP_GIMME(bairn,0) == G_SCALAR)
11494         {
11495             OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
11496                                      op_sibling_splice(o, kid, 1, NULL));
11497             op_free(o);
11498             return ret;
11499         }
11500     }
11501
11502     return ck_fun(o);
11503 }
11504
11505 /*
11506 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
11507
11508 Examines an op, which is expected to identify a subroutine at runtime,
11509 and attempts to determine at compile time which subroutine it identifies.
11510 This is normally used during Perl compilation to determine whether
11511 a prototype can be applied to a function call.  C<cvop> is the op
11512 being considered, normally an C<rv2cv> op.  A pointer to the identified
11513 subroutine is returned, if it could be determined statically, and a null
11514 pointer is returned if it was not possible to determine statically.
11515
11516 Currently, the subroutine can be identified statically if the RV that the
11517 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
11518 A C<gv> op is suitable if the GV's CV slot is populated.  A C<const> op is
11519 suitable if the constant value must be an RV pointing to a CV.  Details of
11520 this process may change in future versions of Perl.  If the C<rv2cv> op
11521 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
11522 the subroutine statically: this flag is used to suppress compile-time
11523 magic on a subroutine call, forcing it to use default runtime behaviour.
11524
11525 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
11526 of a GV reference is modified.  If a GV was examined and its CV slot was
11527 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
11528 If the op is not optimised away, and the CV slot is later populated with
11529 a subroutine having a prototype, that flag eventually triggers the warning
11530 "called too early to check prototype".
11531
11532 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
11533 of returning a pointer to the subroutine it returns a pointer to the
11534 GV giving the most appropriate name for the subroutine in this context.
11535 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
11536 (C<CvANON>) subroutine that is referenced through a GV it will be the
11537 referencing GV.  The resulting C<GV*> is cast to C<CV*> to be returned.
11538 A null pointer is returned as usual if there is no statically-determinable
11539 subroutine.
11540
11541 =cut
11542 */
11543
11544 /* shared by toke.c:yylex */
11545 CV *
11546 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
11547 {
11548     PADNAME *name = PAD_COMPNAME(off);
11549     CV *compcv = PL_compcv;
11550     while (PadnameOUTER(name)) {
11551         assert(PARENT_PAD_INDEX(name));
11552         compcv = CvOUTSIDE(compcv);
11553         name = PadlistNAMESARRAY(CvPADLIST(compcv))
11554                 [off = PARENT_PAD_INDEX(name)];
11555     }
11556     assert(!PadnameIsOUR(name));
11557     if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
11558         return PadnamePROTOCV(name);
11559     }
11560     return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
11561 }
11562
11563 CV *
11564 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
11565 {
11566     OP *rvop;
11567     CV *cv;
11568     GV *gv;
11569     PERL_ARGS_ASSERT_RV2CV_OP_CV;
11570     if (flags & ~RV2CVOPCV_FLAG_MASK)
11571         Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
11572     if (cvop->op_type != OP_RV2CV)
11573         return NULL;
11574     if (cvop->op_private & OPpENTERSUB_AMPER)
11575         return NULL;
11576     if (!(cvop->op_flags & OPf_KIDS))
11577         return NULL;
11578     rvop = cUNOPx(cvop)->op_first;
11579     switch (rvop->op_type) {
11580         case OP_GV: {
11581             gv = cGVOPx_gv(rvop);
11582             if (!isGV(gv)) {
11583                 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
11584                     cv = MUTABLE_CV(SvRV(gv));
11585                     gv = NULL;
11586                     break;
11587                 }
11588                 if (flags & RV2CVOPCV_RETURN_STUB)
11589                     return (CV *)gv;
11590                 else return NULL;
11591             }
11592             cv = GvCVu(gv);
11593             if (!cv) {
11594                 if (flags & RV2CVOPCV_MARK_EARLY)
11595                     rvop->op_private |= OPpEARLY_CV;
11596                 return NULL;
11597             }
11598         } break;
11599         case OP_CONST: {
11600             SV *rv = cSVOPx_sv(rvop);
11601             if (!SvROK(rv))
11602                 return NULL;
11603             cv = (CV*)SvRV(rv);
11604             gv = NULL;
11605         } break;
11606         case OP_PADCV: {
11607             cv = find_lexical_cv(rvop->op_targ);
11608             gv = NULL;
11609         } break;
11610         default: {
11611             return NULL;
11612         } NOT_REACHED; /* NOTREACHED */
11613     }
11614     if (SvTYPE((SV*)cv) != SVt_PVCV)
11615         return NULL;
11616     if (flags & RV2CVOPCV_RETURN_NAME_GV) {
11617         if ((!CvANON(cv) && !CvLEXICAL(cv)) || !gv)
11618             gv = CvGV(cv);
11619         return (CV*)gv;
11620     }
11621     else if (flags & RV2CVOPCV_MAYBE_NAME_GV) {
11622         if (CvLEXICAL(cv) || CvNAMED(cv))
11623             return NULL;
11624         if (!CvANON(cv) || !gv)
11625             gv = CvGV(cv);
11626         return (CV*)gv;
11627
11628     } else {
11629         return cv;
11630     }
11631 }
11632
11633 /*
11634 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
11635
11636 Performs the default fixup of the arguments part of an C<entersub>
11637 op tree.  This consists of applying list context to each of the
11638 argument ops.  This is the standard treatment used on a call marked
11639 with C<&>, or a method call, or a call through a subroutine reference,
11640 or any other call where the callee can't be identified at compile time,
11641 or a call where the callee has no prototype.
11642
11643 =cut
11644 */
11645
11646 OP *
11647 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
11648 {
11649     OP *aop;
11650
11651     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
11652
11653     aop = cUNOPx(entersubop)->op_first;
11654     if (!OpHAS_SIBLING(aop))
11655         aop = cUNOPx(aop)->op_first;
11656     for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
11657         /* skip the extra attributes->import() call implicitly added in
11658          * something like foo(my $x : bar)
11659          */
11660         if (   aop->op_type == OP_ENTERSUB
11661             && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
11662         )
11663             continue;
11664         list(aop);
11665         op_lvalue(aop, OP_ENTERSUB);
11666     }
11667     return entersubop;
11668 }
11669
11670 /*
11671 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
11672
11673 Performs the fixup of the arguments part of an C<entersub> op tree
11674 based on a subroutine prototype.  This makes various modifications to
11675 the argument ops, from applying context up to inserting C<refgen> ops,
11676 and checking the number and syntactic types of arguments, as directed by
11677 the prototype.  This is the standard treatment used on a subroutine call,
11678 not marked with C<&>, where the callee can be identified at compile time
11679 and has a prototype.
11680
11681 C<protosv> supplies the subroutine prototype to be applied to the call.
11682 It may be a normal defined scalar, of which the string value will be used.
11683 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11684 that has been cast to C<SV*>) which has a prototype.  The prototype
11685 supplied, in whichever form, does not need to match the actual callee
11686 referenced by the op tree.
11687
11688 If the argument ops disagree with the prototype, for example by having
11689 an unacceptable number of arguments, a valid op tree is returned anyway.
11690 The error is reflected in the parser state, normally resulting in a single
11691 exception at the top level of parsing which covers all the compilation
11692 errors that occurred.  In the error message, the callee is referred to
11693 by the name defined by the C<namegv> parameter.
11694
11695 =cut
11696 */
11697
11698 OP *
11699 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11700 {
11701     STRLEN proto_len;
11702     const char *proto, *proto_end;
11703     OP *aop, *prev, *cvop, *parent;
11704     int optional = 0;
11705     I32 arg = 0;
11706     I32 contextclass = 0;
11707     const char *e = NULL;
11708     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
11709     if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
11710         Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
11711                    "flags=%lx", (unsigned long) SvFLAGS(protosv));
11712     if (SvTYPE(protosv) == SVt_PVCV)
11713          proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
11714     else proto = SvPV(protosv, proto_len);
11715     proto = S_strip_spaces(aTHX_ proto, &proto_len);
11716     proto_end = proto + proto_len;
11717     parent = entersubop;
11718     aop = cUNOPx(entersubop)->op_first;
11719     if (!OpHAS_SIBLING(aop)) {
11720         parent = aop;
11721         aop = cUNOPx(aop)->op_first;
11722     }
11723     prev = aop;
11724     aop = OpSIBLING(aop);
11725     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11726     while (aop != cvop) {
11727         OP* o3 = aop;
11728
11729         if (proto >= proto_end)
11730         {
11731             SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11732             yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
11733                                         SVfARG(namesv)), SvUTF8(namesv));
11734             return entersubop;
11735         }
11736
11737         switch (*proto) {
11738             case ';':
11739                 optional = 1;
11740                 proto++;
11741                 continue;
11742             case '_':
11743                 /* _ must be at the end */
11744                 if (proto[1] && !strchr(";@%", proto[1]))
11745                     goto oops;
11746                 /* FALLTHROUGH */
11747             case '$':
11748                 proto++;
11749                 arg++;
11750                 scalar(aop);
11751                 break;
11752             case '%':
11753             case '@':
11754                 list(aop);
11755                 arg++;
11756                 break;
11757             case '&':
11758                 proto++;
11759                 arg++;
11760                 if (    o3->op_type != OP_UNDEF
11761                     && (o3->op_type != OP_SREFGEN
11762                         || (  cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
11763                                 != OP_ANONCODE
11764                             && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
11765                                 != OP_RV2CV)))
11766                     bad_type_gv(arg, namegv, o3,
11767                             arg == 1 ? "block or sub {}" : "sub {}");
11768                 break;
11769             case '*':
11770                 /* '*' allows any scalar type, including bareword */
11771                 proto++;
11772                 arg++;
11773                 if (o3->op_type == OP_RV2GV)
11774                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
11775                 else if (o3->op_type == OP_CONST)
11776                     o3->op_private &= ~OPpCONST_STRICT;
11777                 scalar(aop);
11778                 break;
11779             case '+':
11780                 proto++;
11781                 arg++;
11782                 if (o3->op_type == OP_RV2AV ||
11783                     o3->op_type == OP_PADAV ||
11784                     o3->op_type == OP_RV2HV ||
11785                     o3->op_type == OP_PADHV
11786                 ) {
11787                     goto wrapref;
11788                 }
11789                 scalar(aop);
11790                 break;
11791             case '[': case ']':
11792                 goto oops;
11793
11794             case '\\':
11795                 proto++;
11796                 arg++;
11797             again:
11798                 switch (*proto++) {
11799                     case '[':
11800                         if (contextclass++ == 0) {
11801                             e = strchr(proto, ']');
11802                             if (!e || e == proto)
11803                                 goto oops;
11804                         }
11805                         else
11806                             goto oops;
11807                         goto again;
11808
11809                     case ']':
11810                         if (contextclass) {
11811                             const char *p = proto;
11812                             const char *const end = proto;
11813                             contextclass = 0;
11814                             while (*--p != '[')
11815                                 /* \[$] accepts any scalar lvalue */
11816                                 if (*p == '$'
11817                                  && Perl_op_lvalue_flags(aTHX_
11818                                      scalar(o3),
11819                                      OP_READ, /* not entersub */
11820                                      OP_LVALUE_NO_CROAK
11821                                     )) goto wrapref;
11822                             bad_type_gv(arg, namegv, o3,
11823                                     Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
11824                         } else
11825                             goto oops;
11826                         break;
11827                     case '*':
11828                         if (o3->op_type == OP_RV2GV)
11829                             goto wrapref;
11830                         if (!contextclass)
11831                             bad_type_gv(arg, namegv, o3, "symbol");
11832                         break;
11833                     case '&':
11834                         if (o3->op_type == OP_ENTERSUB
11835                          && !(o3->op_flags & OPf_STACKED))
11836                             goto wrapref;
11837                         if (!contextclass)
11838                             bad_type_gv(arg, namegv, o3, "subroutine");
11839                         break;
11840                     case '$':
11841                         if (o3->op_type == OP_RV2SV ||
11842                                 o3->op_type == OP_PADSV ||
11843                                 o3->op_type == OP_HELEM ||
11844                                 o3->op_type == OP_AELEM)
11845                             goto wrapref;
11846                         if (!contextclass) {
11847                             /* \$ accepts any scalar lvalue */
11848                             if (Perl_op_lvalue_flags(aTHX_
11849                                     scalar(o3),
11850                                     OP_READ,  /* not entersub */
11851                                     OP_LVALUE_NO_CROAK
11852                                )) goto wrapref;
11853                             bad_type_gv(arg, namegv, o3, "scalar");
11854                         }
11855                         break;
11856                     case '@':
11857                         if (o3->op_type == OP_RV2AV ||
11858                                 o3->op_type == OP_PADAV)
11859                         {
11860                             o3->op_flags &=~ OPf_PARENS;
11861                             goto wrapref;
11862                         }
11863                         if (!contextclass)
11864                             bad_type_gv(arg, namegv, o3, "array");
11865                         break;
11866                     case '%':
11867                         if (o3->op_type == OP_RV2HV ||
11868                                 o3->op_type == OP_PADHV)
11869                         {
11870                             o3->op_flags &=~ OPf_PARENS;
11871                             goto wrapref;
11872                         }
11873                         if (!contextclass)
11874                             bad_type_gv(arg, namegv, o3, "hash");
11875                         break;
11876                     wrapref:
11877                             aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
11878                                                 OP_REFGEN, 0);
11879                         if (contextclass && e) {
11880                             proto = e + 1;
11881                             contextclass = 0;
11882                         }
11883                         break;
11884                     default: goto oops;
11885                 }
11886                 if (contextclass)
11887                     goto again;
11888                 break;
11889             case ' ':
11890                 proto++;
11891                 continue;
11892             default:
11893             oops: {
11894                 Perl_croak(aTHX_ "Malformed prototype for %" SVf ": %" SVf,
11895                                   SVfARG(cv_name((CV *)namegv, NULL, 0)),
11896                                   SVfARG(protosv));
11897             }
11898         }
11899
11900         op_lvalue(aop, OP_ENTERSUB);
11901         prev = aop;
11902         aop = OpSIBLING(aop);
11903     }
11904     if (aop == cvop && *proto == '_') {
11905         /* generate an access to $_ */
11906         op_sibling_splice(parent, prev, 0, newDEFSVOP());
11907     }
11908     if (!optional && proto_end > proto &&
11909         (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
11910     {
11911         SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11912         yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %" SVf,
11913                                     SVfARG(namesv)), SvUTF8(namesv));
11914     }
11915     return entersubop;
11916 }
11917
11918 /*
11919 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
11920
11921 Performs the fixup of the arguments part of an C<entersub> op tree either
11922 based on a subroutine prototype or using default list-context processing.
11923 This is the standard treatment used on a subroutine call, not marked
11924 with C<&>, where the callee can be identified at compile time.
11925
11926 C<protosv> supplies the subroutine prototype to be applied to the call,
11927 or indicates that there is no prototype.  It may be a normal scalar,
11928 in which case if it is defined then the string value will be used
11929 as a prototype, and if it is undefined then there is no prototype.
11930 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11931 that has been cast to C<SV*>), of which the prototype will be used if it
11932 has one.  The prototype (or lack thereof) supplied, in whichever form,
11933 does not need to match the actual callee referenced by the op tree.
11934
11935 If the argument ops disagree with the prototype, for example by having
11936 an unacceptable number of arguments, a valid op tree is returned anyway.
11937 The error is reflected in the parser state, normally resulting in a single
11938 exception at the top level of parsing which covers all the compilation
11939 errors that occurred.  In the error message, the callee is referred to
11940 by the name defined by the C<namegv> parameter.
11941
11942 =cut
11943 */
11944
11945 OP *
11946 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
11947         GV *namegv, SV *protosv)
11948 {
11949     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
11950     if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
11951         return ck_entersub_args_proto(entersubop, namegv, protosv);
11952     else
11953         return ck_entersub_args_list(entersubop);
11954 }
11955
11956 OP *
11957 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11958 {
11959     IV cvflags = SvIVX(protosv);
11960     int opnum = cvflags & 0xffff;
11961     OP *aop = cUNOPx(entersubop)->op_first;
11962
11963     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
11964
11965     if (!opnum) {
11966         OP *cvop;
11967         if (!OpHAS_SIBLING(aop))
11968             aop = cUNOPx(aop)->op_first;
11969         aop = OpSIBLING(aop);
11970         for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11971         if (aop != cvop) {
11972             SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
11973             yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
11974                 SVfARG(namesv)), SvUTF8(namesv));
11975         }
11976
11977         op_free(entersubop);
11978         switch(cvflags >> 16) {
11979         case 'F': return newSVOP(OP_CONST, 0,
11980                                         newSVpv(CopFILE(PL_curcop),0));
11981         case 'L': return newSVOP(
11982                            OP_CONST, 0,
11983                            Perl_newSVpvf(aTHX_
11984                              "%" IVdf, (IV)CopLINE(PL_curcop)
11985                            )
11986                          );
11987         case 'P': return newSVOP(OP_CONST, 0,
11988                                    (PL_curstash
11989                                      ? newSVhek(HvNAME_HEK(PL_curstash))
11990                                      : &PL_sv_undef
11991                                    )
11992                                 );
11993         }
11994         NOT_REACHED; /* NOTREACHED */
11995     }
11996     else {
11997         OP *prev, *cvop, *first, *parent;
11998         U32 flags = 0;
11999
12000         parent = entersubop;
12001         if (!OpHAS_SIBLING(aop)) {
12002             parent = aop;
12003             aop = cUNOPx(aop)->op_first;
12004         }
12005
12006         first = prev = aop;
12007         aop = OpSIBLING(aop);
12008         /* find last sibling */
12009         for (cvop = aop;
12010              OpHAS_SIBLING(cvop);
12011              prev = cvop, cvop = OpSIBLING(cvop))
12012             ;
12013         if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
12014             /* Usually, OPf_SPECIAL on an op with no args means that it had
12015              * parens, but these have their own meaning for that flag: */
12016             && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
12017             && opnum != OP_DELETE && opnum != OP_EXISTS)
12018                 flags |= OPf_SPECIAL;
12019         /* excise cvop from end of sibling chain */
12020         op_sibling_splice(parent, prev, 1, NULL);
12021         op_free(cvop);
12022         if (aop == cvop) aop = NULL;
12023
12024         /* detach remaining siblings from the first sibling, then
12025          * dispose of original optree */
12026
12027         if (aop)
12028             op_sibling_splice(parent, first, -1, NULL);
12029         op_free(entersubop);
12030
12031         if (cvflags == (OP_ENTEREVAL | (1<<16)))
12032             flags |= OPpEVAL_BYTES <<8;
12033
12034         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
12035         case OA_UNOP:
12036         case OA_BASEOP_OR_UNOP:
12037         case OA_FILESTATOP:
12038             return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
12039         case OA_BASEOP:
12040             if (aop) {
12041                 SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
12042                 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
12043                     SVfARG(namesv)), SvUTF8(namesv));
12044                 op_free(aop);
12045             }
12046             return opnum == OP_RUNCV
12047                 ? newPVOP(OP_RUNCV,0,NULL)
12048                 : newOP(opnum,0);
12049         default:
12050             return op_convert_list(opnum,0,aop);
12051         }
12052     }
12053     NOT_REACHED; /* NOTREACHED */
12054     return entersubop;
12055 }
12056
12057 /*
12058 =for apidoc Am|void|cv_get_call_checker_flags|CV *cv|U32 gflags|Perl_call_checker *ckfun_p|SV **ckobj_p|U32 *ckflags_p
12059
12060 Retrieves the function that will be used to fix up a call to C<cv>.
12061 Specifically, the function is applied to an C<entersub> op tree for a
12062 subroutine call, not marked with C<&>, where the callee can be identified
12063 at compile time as C<cv>.
12064
12065 The C-level function pointer is returned in C<*ckfun_p>, an SV argument
12066 for it is returned in C<*ckobj_p>, and control flags are returned in
12067 C<*ckflags_p>.  The function is intended to be called in this manner:
12068
12069  entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
12070
12071 In this call, C<entersubop> is a pointer to the C<entersub> op,
12072 which may be replaced by the check function, and C<namegv> supplies
12073 the name that should be used by the check function to refer
12074 to the callee of the C<entersub> op if it needs to emit any diagnostics.
12075 It is permitted to apply the check function in non-standard situations,
12076 such as to a call to a different subroutine or to a method call.
12077
12078 C<namegv> may not actually be a GV.  If the C<CALL_CHECKER_REQUIRE_GV>
12079 bit is clear in C<*ckflags_p>, it is permitted to pass a CV or other SV
12080 instead, anything that can be used as the first argument to L</cv_name>.
12081 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<*ckflags_p> then the
12082 check function requires C<namegv> to be a genuine GV.
12083
12084 By default, the check function is
12085 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
12086 the SV parameter is C<cv> itself, and the C<CALL_CHECKER_REQUIRE_GV>
12087 flag is clear.  This implements standard prototype processing.  It can
12088 be changed, for a particular subroutine, by L</cv_set_call_checker_flags>.
12089
12090 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<gflags> then it
12091 indicates that the caller only knows about the genuine GV version of
12092 C<namegv>, and accordingly the corresponding bit will always be set in
12093 C<*ckflags_p>, regardless of the check function's recorded requirements.
12094 If the C<CALL_CHECKER_REQUIRE_GV> bit is clear in C<gflags> then it
12095 indicates the caller knows about the possibility of passing something
12096 other than a GV as C<namegv>, and accordingly the corresponding bit may
12097 be either set or clear in C<*ckflags_p>, indicating the check function's
12098 recorded requirements.
12099
12100 C<gflags> is a bitset passed into C<cv_get_call_checker_flags>, in which
12101 only the C<CALL_CHECKER_REQUIRE_GV> bit currently has a defined meaning
12102 (for which see above).  All other bits should be clear.
12103
12104 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
12105
12106 The original form of L</cv_get_call_checker_flags>, which does not return
12107 checker flags.  When using a checker function returned by this function,
12108 it is only safe to call it with a genuine GV as its C<namegv> argument.
12109
12110 =cut
12111 */
12112
12113 void
12114 Perl_cv_get_call_checker_flags(pTHX_ CV *cv, U32 gflags,
12115         Perl_call_checker *ckfun_p, SV **ckobj_p, U32 *ckflags_p)
12116 {
12117     MAGIC *callmg;
12118     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER_FLAGS;
12119     PERL_UNUSED_CONTEXT;
12120     callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
12121     if (callmg) {
12122         *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
12123         *ckobj_p = callmg->mg_obj;
12124         *ckflags_p = (callmg->mg_flags | gflags) & MGf_REQUIRE_GV;
12125     } else {
12126         *ckfun_p = Perl_ck_entersub_args_proto_or_list;
12127         *ckobj_p = (SV*)cv;
12128         *ckflags_p = gflags & MGf_REQUIRE_GV;
12129     }
12130 }
12131
12132 void
12133 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
12134 {
12135     U32 ckflags;
12136     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
12137     PERL_UNUSED_CONTEXT;
12138     cv_get_call_checker_flags(cv, CALL_CHECKER_REQUIRE_GV, ckfun_p, ckobj_p,
12139         &ckflags);
12140 }
12141
12142 /*
12143 =for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 ckflags
12144
12145 Sets the function that will be used to fix up a call to C<cv>.
12146 Specifically, the function is applied to an C<entersub> op tree for a
12147 subroutine call, not marked with C<&>, where the callee can be identified
12148 at compile time as C<cv>.
12149
12150 The C-level function pointer is supplied in C<ckfun>, an SV argument for
12151 it is supplied in C<ckobj>, and control flags are supplied in C<ckflags>.
12152 The function should be defined like this:
12153
12154     STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
12155
12156 It is intended to be called in this manner:
12157
12158     entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
12159
12160 In this call, C<entersubop> is a pointer to the C<entersub> op,
12161 which may be replaced by the check function, and C<namegv> supplies
12162 the name that should be used by the check function to refer
12163 to the callee of the C<entersub> op if it needs to emit any diagnostics.
12164 It is permitted to apply the check function in non-standard situations,
12165 such as to a call to a different subroutine or to a method call.
12166
12167 C<namegv> may not actually be a GV.  For efficiency, perl may pass a
12168 CV or other SV instead.  Whatever is passed can be used as the first
12169 argument to L</cv_name>.  You can force perl to pass a GV by including
12170 C<CALL_CHECKER_REQUIRE_GV> in the C<ckflags>.
12171
12172 C<ckflags> is a bitset, in which only the C<CALL_CHECKER_REQUIRE_GV>
12173 bit currently has a defined meaning (for which see above).  All other
12174 bits should be clear.
12175
12176 The current setting for a particular CV can be retrieved by
12177 L</cv_get_call_checker_flags>.
12178
12179 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
12180
12181 The original form of L</cv_set_call_checker_flags>, which passes it the
12182 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.  The effect
12183 of that flag setting is that the check function is guaranteed to get a
12184 genuine GV as its C<namegv> argument.
12185
12186 =cut
12187 */
12188
12189 void
12190 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
12191 {
12192     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
12193     cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
12194 }
12195
12196 void
12197 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
12198                                      SV *ckobj, U32 ckflags)
12199 {
12200     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
12201     if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
12202         if (SvMAGICAL((SV*)cv))
12203             mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
12204     } else {
12205         MAGIC *callmg;
12206         sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
12207         callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
12208         assert(callmg);
12209         if (callmg->mg_flags & MGf_REFCOUNTED) {
12210             SvREFCNT_dec(callmg->mg_obj);
12211             callmg->mg_flags &= ~MGf_REFCOUNTED;
12212         }
12213         callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
12214         callmg->mg_obj = ckobj;
12215         if (ckobj != (SV*)cv) {
12216             SvREFCNT_inc_simple_void_NN(ckobj);
12217             callmg->mg_flags |= MGf_REFCOUNTED;
12218         }
12219         callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
12220                          | (U8)(ckflags & MGf_REQUIRE_GV) | MGf_COPY;
12221     }
12222 }
12223
12224 static void
12225 S_entersub_alloc_targ(pTHX_ OP * const o)
12226 {
12227     o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
12228     o->op_private |= OPpENTERSUB_HASTARG;
12229 }
12230
12231 OP *
12232 Perl_ck_subr(pTHX_ OP *o)
12233 {
12234     OP *aop, *cvop;
12235     CV *cv;
12236     GV *namegv;
12237     SV **const_class = NULL;
12238
12239     PERL_ARGS_ASSERT_CK_SUBR;
12240
12241     aop = cUNOPx(o)->op_first;
12242     if (!OpHAS_SIBLING(aop))
12243         aop = cUNOPx(aop)->op_first;
12244     aop = OpSIBLING(aop);
12245     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
12246     cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
12247     namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
12248
12249     o->op_private &= ~1;
12250     o->op_private |= (PL_hints & HINT_STRICT_REFS);
12251     if (PERLDB_SUB && PL_curstash != PL_debstash)
12252         o->op_private |= OPpENTERSUB_DB;
12253     switch (cvop->op_type) {
12254         case OP_RV2CV:
12255             o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
12256             op_null(cvop);
12257             break;
12258         case OP_METHOD:
12259         case OP_METHOD_NAMED:
12260         case OP_METHOD_SUPER:
12261         case OP_METHOD_REDIR:
12262         case OP_METHOD_REDIR_SUPER:
12263             o->op_flags |= OPf_REF;
12264             if (aop->op_type == OP_CONST) {
12265                 aop->op_private &= ~OPpCONST_STRICT;
12266                 const_class = &cSVOPx(aop)->op_sv;
12267             }
12268             else if (aop->op_type == OP_LIST) {
12269                 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
12270                 if (sib && sib->op_type == OP_CONST) {
12271                     sib->op_private &= ~OPpCONST_STRICT;
12272                     const_class = &cSVOPx(sib)->op_sv;
12273                 }
12274             }
12275             /* make class name a shared cow string to speedup method calls */
12276             /* constant string might be replaced with object, f.e. bigint */
12277             if (const_class && SvPOK(*const_class)) {
12278                 STRLEN len;
12279                 const char* str = SvPV(*const_class, len);
12280                 if (len) {
12281                     SV* const shared = newSVpvn_share(
12282                         str, SvUTF8(*const_class)
12283                                     ? -(SSize_t)len : (SSize_t)len,
12284                         0
12285                     );
12286                     if (SvREADONLY(*const_class))
12287                         SvREADONLY_on(shared);
12288                     SvREFCNT_dec(*const_class);
12289                     *const_class = shared;
12290                 }
12291             }
12292             break;
12293     }
12294
12295     if (!cv) {
12296         S_entersub_alloc_targ(aTHX_ o);
12297         return ck_entersub_args_list(o);
12298     } else {
12299         Perl_call_checker ckfun;
12300         SV *ckobj;
12301         U32 ckflags;
12302         cv_get_call_checker_flags(cv, 0, &ckfun, &ckobj, &ckflags);
12303         if (CvISXSUB(cv) || !CvROOT(cv))
12304             S_entersub_alloc_targ(aTHX_ o);
12305         if (!namegv) {
12306             /* The original call checker API guarantees that a GV will be
12307                be provided with the right name.  So, if the old API was
12308                used (or the REQUIRE_GV flag was passed), we have to reify
12309                the CV’s GV, unless this is an anonymous sub.  This is not
12310                ideal for lexical subs, as its stringification will include
12311                the package.  But it is the best we can do.  */
12312             if (ckflags & CALL_CHECKER_REQUIRE_GV) {
12313                 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
12314                     namegv = CvGV(cv);
12315             }
12316             else namegv = MUTABLE_GV(cv);
12317             /* After a syntax error in a lexical sub, the cv that
12318                rv2cv_op_cv returns may be a nameless stub. */
12319             if (!namegv) return ck_entersub_args_list(o);
12320
12321         }
12322         return ckfun(aTHX_ o, namegv, ckobj);
12323     }
12324 }
12325
12326 OP *
12327 Perl_ck_svconst(pTHX_ OP *o)
12328 {
12329     SV * const sv = cSVOPo->op_sv;
12330     PERL_ARGS_ASSERT_CK_SVCONST;
12331     PERL_UNUSED_CONTEXT;
12332 #ifdef PERL_COPY_ON_WRITE
12333     /* Since the read-only flag may be used to protect a string buffer, we
12334        cannot do copy-on-write with existing read-only scalars that are not
12335        already copy-on-write scalars.  To allow $_ = "hello" to do COW with
12336        that constant, mark the constant as COWable here, if it is not
12337        already read-only. */
12338     if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
12339         SvIsCOW_on(sv);
12340         CowREFCNT(sv) = 0;
12341 # ifdef PERL_DEBUG_READONLY_COW
12342         sv_buf_to_ro(sv);
12343 # endif
12344     }
12345 #endif
12346     SvREADONLY_on(sv);
12347     return o;
12348 }
12349
12350 OP *
12351 Perl_ck_trunc(pTHX_ OP *o)
12352 {
12353     PERL_ARGS_ASSERT_CK_TRUNC;
12354
12355     if (o->op_flags & OPf_KIDS) {
12356         SVOP *kid = (SVOP*)cUNOPo->op_first;
12357
12358         if (kid->op_type == OP_NULL)
12359             kid = (SVOP*)OpSIBLING(kid);
12360         if (kid && kid->op_type == OP_CONST &&
12361             (kid->op_private & OPpCONST_BARE) &&
12362             !kid->op_folded)
12363         {
12364             o->op_flags |= OPf_SPECIAL;
12365             kid->op_private &= ~OPpCONST_STRICT;
12366         }
12367     }
12368     return ck_fun(o);
12369 }
12370
12371 OP *
12372 Perl_ck_substr(pTHX_ OP *o)
12373 {
12374     PERL_ARGS_ASSERT_CK_SUBSTR;
12375
12376     o = ck_fun(o);
12377     if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
12378         OP *kid = cLISTOPo->op_first;
12379
12380         if (kid->op_type == OP_NULL)
12381             kid = OpSIBLING(kid);
12382         if (kid)
12383             kid->op_flags |= OPf_MOD;
12384
12385     }
12386     return o;
12387 }
12388
12389 OP *
12390 Perl_ck_tell(pTHX_ OP *o)
12391 {
12392     PERL_ARGS_ASSERT_CK_TELL;
12393     o = ck_fun(o);
12394     if (o->op_flags & OPf_KIDS) {
12395      OP *kid = cLISTOPo->op_first;
12396      if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
12397      if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
12398     }
12399     return o;
12400 }
12401
12402 OP *
12403 Perl_ck_each(pTHX_ OP *o)
12404 {
12405     dVAR;
12406     OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
12407     const unsigned orig_type  = o->op_type;
12408
12409     PERL_ARGS_ASSERT_CK_EACH;
12410
12411     if (kid) {
12412         switch (kid->op_type) {
12413             case OP_PADHV:
12414             case OP_RV2HV:
12415                 break;
12416             case OP_PADAV:
12417             case OP_RV2AV:
12418                 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
12419                             : orig_type == OP_KEYS ? OP_AKEYS
12420                             :                        OP_AVALUES);
12421                 break;
12422             case OP_CONST:
12423                 if (kid->op_private == OPpCONST_BARE
12424                  || !SvROK(cSVOPx_sv(kid))
12425                  || (  SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
12426                     && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV  )
12427                    )
12428                     goto bad;
12429                 /* FALLTHROUGH */
12430             default:
12431                 qerror(Perl_mess(aTHX_
12432                     "Experimental %s on scalar is now forbidden",
12433                      PL_op_desc[orig_type]));
12434                bad:
12435                 bad_type_pv(1, "hash or array", o, kid);
12436                 return o;
12437         }
12438     }
12439     return ck_fun(o);
12440 }
12441
12442 OP *
12443 Perl_ck_length(pTHX_ OP *o)
12444 {
12445     PERL_ARGS_ASSERT_CK_LENGTH;
12446
12447     o = ck_fun(o);
12448
12449     if (ckWARN(WARN_SYNTAX)) {
12450         const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
12451
12452         if (kid) {
12453             SV *name = NULL;
12454             const bool hash = kid->op_type == OP_PADHV
12455                            || kid->op_type == OP_RV2HV;
12456             switch (kid->op_type) {
12457                 case OP_PADHV:
12458                 case OP_PADAV:
12459                 case OP_RV2HV:
12460                 case OP_RV2AV:
12461                     name = S_op_varname(aTHX_ kid);
12462                     break;
12463                 default:
12464                     return o;
12465             }
12466             if (name)
12467                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12468                     "length() used on %" SVf " (did you mean \"scalar(%s%" SVf
12469                     ")\"?)",
12470                     SVfARG(name), hash ? "keys " : "", SVfARG(name)
12471                 );
12472             else if (hash)
12473      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
12474                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12475                     "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
12476             else
12477      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
12478                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12479                     "length() used on @array (did you mean \"scalar(@array)\"?)");
12480         }
12481     }
12482
12483     return o;
12484 }
12485
12486
12487
12488 /*
12489    ---------------------------------------------------------
12490
12491    Common vars in list assignment
12492
12493    There now follows some enums and static functions for detecting
12494    common variables in list assignments. Here is a little essay I wrote
12495    for myself when trying to get my head around this. DAPM.
12496
12497    ----
12498
12499    First some random observations:
12500
12501    * If a lexical var is an alias of something else, e.g.
12502        for my $x ($lex, $pkg, $a[0]) {...}
12503      then the act of aliasing will increase the reference count of the SV
12504
12505    * If a package var is an alias of something else, it may still have a
12506      reference count of 1, depending on how the alias was created, e.g.
12507      in *a = *b, $a may have a refcount of 1 since the GP is shared
12508      with a single GvSV pointer to the SV. So If it's an alias of another
12509      package var, then RC may be 1; if it's an alias of another scalar, e.g.
12510      a lexical var or an array element, then it will have RC > 1.
12511
12512    * There are many ways to create a package alias; ultimately, XS code
12513      may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
12514      run-time tracing mechanisms are unlikely to be able to catch all cases.
12515
12516    * When the LHS is all my declarations, the same vars can't appear directly
12517      on the RHS, but they can indirectly via closures, aliasing and lvalue
12518      subs. But those techniques all involve an increase in the lexical
12519      scalar's ref count.
12520
12521    * When the LHS is all lexical vars (but not necessarily my declarations),
12522      it is possible for the same lexicals to appear directly on the RHS, and
12523      without an increased ref count, since the stack isn't refcounted.
12524      This case can be detected at compile time by scanning for common lex
12525      vars with PL_generation.
12526
12527    * lvalue subs defeat common var detection, but they do at least
12528      return vars with a temporary ref count increment. Also, you can't
12529      tell at compile time whether a sub call is lvalue.
12530
12531
12532    So...
12533
12534    A: There are a few circumstances where there definitely can't be any
12535      commonality:
12536
12537        LHS empty:  () = (...);
12538        RHS empty:  (....) = ();
12539        RHS contains only constants or other 'can't possibly be shared'
12540            elements (e.g. ops that return PADTMPs):  (...) = (1,2, length)
12541            i.e. they only contain ops not marked as dangerous, whose children
12542            are also not dangerous;
12543        LHS ditto;
12544        LHS contains a single scalar element: e.g. ($x) = (....); because
12545            after $x has been modified, it won't be used again on the RHS;
12546        RHS contains a single element with no aggregate on LHS: e.g.
12547            ($a,$b,$c)  = ($x); again, once $a has been modified, its value
12548            won't be used again.
12549
12550    B: If LHS are all 'my' lexical var declarations (or safe ops, which
12551      we can ignore):
12552
12553        my ($a, $b, @c) = ...;
12554
12555        Due to closure and goto tricks, these vars may already have content.
12556        For the same reason, an element on the RHS may be a lexical or package
12557        alias of one of the vars on the left, or share common elements, for
12558        example:
12559
12560            my ($x,$y) = f(); # $x and $y on both sides
12561            sub f : lvalue { ($x,$y) = (1,2); $y, $x }
12562
12563        and
12564
12565            my $ra = f();
12566            my @a = @$ra;  # elements of @a on both sides
12567            sub f { @a = 1..4; \@a }
12568
12569
12570        First, just consider scalar vars on LHS:
12571
12572            RHS is safe only if (A), or in addition,
12573                * contains only lexical *scalar* vars, where neither side's
12574                  lexicals have been flagged as aliases
12575
12576            If RHS is not safe, then it's always legal to check LHS vars for
12577            RC==1, since the only RHS aliases will always be associated
12578            with an RC bump.
12579
12580            Note that in particular, RHS is not safe if:
12581
12582                * it contains package scalar vars; e.g.:
12583
12584                    f();
12585                    my ($x, $y) = (2, $x_alias);
12586                    sub f { $x = 1; *x_alias = \$x; }
12587
12588                * It contains other general elements, such as flattened or
12589                * spliced or single array or hash elements, e.g.
12590
12591                    f();
12592                    my ($x,$y) = @a; # or $a[0] or @a{@b} etc
12593
12594                    sub f {
12595                        ($x, $y) = (1,2);
12596                        use feature 'refaliasing';
12597                        \($a[0], $a[1]) = \($y,$x);
12598                    }
12599
12600                  It doesn't matter if the array/hash is lexical or package.
12601
12602                * it contains a function call that happens to be an lvalue
12603                  sub which returns one or more of the above, e.g.
12604
12605                    f();
12606                    my ($x,$y) = f();
12607
12608                    sub f : lvalue {
12609                        ($x, $y) = (1,2);
12610                        *x1 = \$x;
12611                        $y, $x1;
12612                    }
12613
12614                    (so a sub call on the RHS should be treated the same
12615                    as having a package var on the RHS).
12616
12617                * any other "dangerous" thing, such an op or built-in that
12618                  returns one of the above, e.g. pp_preinc
12619
12620
12621            If RHS is not safe, what we can do however is at compile time flag
12622            that the LHS are all my declarations, and at run time check whether
12623            all the LHS have RC == 1, and if so skip the full scan.
12624
12625        Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
12626
12627            Here the issue is whether there can be elements of @a on the RHS
12628            which will get prematurely freed when @a is cleared prior to
12629            assignment. This is only a problem if the aliasing mechanism
12630            is one which doesn't increase the refcount - only if RC == 1
12631            will the RHS element be prematurely freed.
12632
12633            Because the array/hash is being INTROed, it or its elements
12634            can't directly appear on the RHS:
12635
12636                my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
12637
12638            but can indirectly, e.g.:
12639
12640                my $r = f();
12641                my (@a) = @$r;
12642                sub f { @a = 1..3; \@a }
12643
12644            So if the RHS isn't safe as defined by (A), we must always
12645            mortalise and bump the ref count of any remaining RHS elements
12646            when assigning to a non-empty LHS aggregate.
12647
12648            Lexical scalars on the RHS aren't safe if they've been involved in
12649            aliasing, e.g.
12650
12651                use feature 'refaliasing';
12652
12653                f();
12654                \(my $lex) = \$pkg;
12655                my @a = ($lex,3); # equivalent to ($a[0],3)
12656
12657                sub f {
12658                    @a = (1,2);
12659                    \$pkg = \$a[0];
12660                }
12661
12662            Similarly with lexical arrays and hashes on the RHS:
12663
12664                f();
12665                my @b;
12666                my @a = (@b);
12667
12668                sub f {
12669                    @a = (1,2);
12670                    \$b[0] = \$a[1];
12671                    \$b[1] = \$a[0];
12672                }
12673
12674
12675
12676    C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
12677        my $a; ($a, my $b) = (....);
12678
12679        The difference between (B) and (C) is that it is now physically
12680        possible for the LHS vars to appear on the RHS too, where they
12681        are not reference counted; but in this case, the compile-time
12682        PL_generation sweep will detect such common vars.
12683
12684        So the rules for (C) differ from (B) in that if common vars are
12685        detected, the runtime "test RC==1" optimisation can no longer be used,
12686        and a full mark and sweep is required
12687
12688    D: As (C), but in addition the LHS may contain package vars.
12689
12690        Since package vars can be aliased without a corresponding refcount
12691        increase, all bets are off. It's only safe if (A). E.g.
12692
12693            my ($x, $y) = (1,2);
12694
12695            for $x_alias ($x) {
12696                ($x_alias, $y) = (3, $x); # whoops
12697            }
12698
12699        Ditto for LHS aggregate package vars.
12700
12701    E: Any other dangerous ops on LHS, e.g.
12702            (f(), $a[0], @$r) = (...);
12703
12704        this is similar to (E) in that all bets are off. In addition, it's
12705        impossible to determine at compile time whether the LHS
12706        contains a scalar or an aggregate, e.g.
12707
12708            sub f : lvalue { @a }
12709            (f()) = 1..3;
12710
12711 * ---------------------------------------------------------
12712 */
12713
12714
12715 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates
12716  * that at least one of the things flagged was seen.
12717  */
12718
12719 enum {
12720     AAS_MY_SCALAR       = 0x001, /* my $scalar */
12721     AAS_MY_AGG          = 0x002, /* aggregate: my @array or my %hash */
12722     AAS_LEX_SCALAR      = 0x004, /* $lexical */
12723     AAS_LEX_AGG         = 0x008, /* @lexical or %lexical aggregate */
12724     AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
12725     AAS_PKG_SCALAR      = 0x020, /* $scalar (where $scalar is pkg var) */
12726     AAS_PKG_AGG         = 0x040, /* package @array or %hash aggregate */
12727     AAS_DANGEROUS       = 0x080, /* an op (other than the above)
12728                                          that's flagged OA_DANGEROUS */
12729     AAS_SAFE_SCALAR     = 0x100, /* produces at least one scalar SV that's
12730                                         not in any of the categories above */
12731     AAS_DEFAV           = 0x200  /* contains just a single '@_' on RHS */
12732 };
12733
12734
12735
12736 /* helper function for S_aassign_scan().
12737  * check a PAD-related op for commonality and/or set its generation number.
12738  * Returns a boolean indicating whether its shared */
12739
12740 static bool
12741 S_aassign_padcheck(pTHX_ OP* o, bool rhs)
12742 {
12743     if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
12744         /* lexical used in aliasing */
12745         return TRUE;
12746
12747     if (rhs)
12748         return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
12749     else
12750         PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
12751
12752     return FALSE;
12753 }
12754
12755
12756 /*
12757   Helper function for OPpASSIGN_COMMON* detection in rpeep().
12758   It scans the left or right hand subtree of the aassign op, and returns a
12759   set of flags indicating what sorts of things it found there.
12760   'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
12761   set PL_generation on lexical vars; if the latter, we see if
12762   PL_generation matches.
12763   'top' indicates whether we're recursing or at the top level.
12764   'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
12765   This fn will increment it by the number seen. It's not intended to
12766   be an accurate count (especially as many ops can push a variable
12767   number of SVs onto the stack); rather it's used as to test whether there
12768   can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
12769 */
12770
12771 static int
12772 S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *scalars_p)
12773 {
12774     int flags = 0;
12775     bool kid_top = FALSE;
12776
12777     /* first, look for a solitary @_ on the RHS */
12778     if (   rhs
12779         && top
12780         && (o->op_flags & OPf_KIDS)
12781         && OP_TYPE_IS_OR_WAS(o, OP_LIST)
12782     ) {
12783         OP *kid = cUNOPo->op_first;
12784         if (   (   kid->op_type == OP_PUSHMARK
12785                 || kid->op_type == OP_PADRANGE) /* ex-pushmark */
12786             && ((kid = OpSIBLING(kid)))
12787             && !OpHAS_SIBLING(kid)
12788             && kid->op_type == OP_RV2AV
12789             && !(kid->op_flags & OPf_REF)
12790             && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
12791             && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
12792             && ((kid = cUNOPx(kid)->op_first))
12793             && kid->op_type == OP_GV
12794             && cGVOPx_gv(kid) == PL_defgv
12795         )
12796             flags |= AAS_DEFAV;
12797     }
12798
12799     switch (o->op_type) {
12800     case OP_GVSV:
12801         (*scalars_p)++;
12802         return AAS_PKG_SCALAR;
12803
12804     case OP_PADAV:
12805     case OP_PADHV:
12806         (*scalars_p) += 2;
12807         /* if !top, could be e.g. @a[0,1] */
12808         if (top && (o->op_flags & OPf_REF))
12809             return (o->op_private & OPpLVAL_INTRO)
12810                 ? AAS_MY_AGG : AAS_LEX_AGG;
12811         return AAS_DANGEROUS;
12812
12813     case OP_PADSV:
12814         {
12815             int comm = S_aassign_padcheck(aTHX_ o, rhs)
12816                         ?  AAS_LEX_SCALAR_COMM : 0;
12817             (*scalars_p)++;
12818             return (o->op_private & OPpLVAL_INTRO)
12819                 ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
12820         }
12821
12822     case OP_RV2AV:
12823     case OP_RV2HV:
12824         (*scalars_p) += 2;
12825         if (cUNOPx(o)->op_first->op_type != OP_GV)
12826             return AAS_DANGEROUS; /* @{expr}, %{expr} */
12827         /* @pkg, %pkg */
12828         /* if !top, could be e.g. @a[0,1] */
12829         if (top && (o->op_flags & OPf_REF))
12830             return AAS_PKG_AGG;
12831         return AAS_DANGEROUS;
12832
12833     case OP_RV2SV:
12834         (*scalars_p)++;
12835         if (cUNOPx(o)->op_first->op_type != OP_GV) {
12836             (*scalars_p) += 2;
12837             return AAS_DANGEROUS; /* ${expr} */
12838         }
12839         return AAS_PKG_SCALAR; /* $pkg */
12840
12841     case OP_SPLIT:
12842         if (o->op_private & OPpSPLIT_ASSIGN) {
12843             /* the assign in @a = split() has been optimised away
12844              * and the @a attached directly to the split op
12845              * Treat the array as appearing on the RHS, i.e.
12846              *    ... = (@a = split)
12847              * is treated like
12848              *    ... = @a;
12849              */
12850
12851             if (o->op_flags & OPf_STACKED)
12852                 /* @{expr} = split() - the array expression is tacked
12853                  * on as an extra child to split - process kid */
12854                 return S_aassign_scan(aTHX_ cLISTOPo->op_last, rhs,
12855                                         top, scalars_p);
12856
12857             /* ... else array is directly attached to split op */
12858             (*scalars_p) += 2;
12859             if (PL_op->op_private & OPpSPLIT_LEX)
12860                 return (o->op_private & OPpLVAL_INTRO)
12861                     ? AAS_MY_AGG : AAS_LEX_AGG;
12862             else
12863                 return AAS_PKG_AGG;
12864         }
12865         (*scalars_p)++;
12866         /* other args of split can't be returned */
12867         return AAS_SAFE_SCALAR;
12868
12869     case OP_UNDEF:
12870         /* undef counts as a scalar on the RHS:
12871          *   (undef, $x) = ...;         # only 1 scalar on LHS: always safe
12872          *   ($x, $y)    = (undef, $x); # 2 scalars on RHS: unsafe
12873          */
12874         if (rhs)
12875             (*scalars_p)++;
12876         flags = AAS_SAFE_SCALAR;
12877         break;
12878
12879     case OP_PUSHMARK:
12880     case OP_STUB:
12881         /* these are all no-ops; they don't push a potentially common SV
12882          * onto the stack, so they are neither AAS_DANGEROUS nor
12883          * AAS_SAFE_SCALAR */
12884         return 0;
12885
12886     case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
12887         break;
12888
12889     case OP_NULL:
12890     case OP_LIST:
12891         /* these do nothing but may have children; but their children
12892          * should also be treated as top-level */
12893         kid_top = top;
12894         break;
12895
12896     default:
12897         if (PL_opargs[o->op_type] & OA_DANGEROUS) {
12898             (*scalars_p) += 2;
12899             flags = AAS_DANGEROUS;
12900             break;
12901         }
12902
12903         if (   (PL_opargs[o->op_type] & OA_TARGLEX)
12904             && (o->op_private & OPpTARGET_MY))
12905         {
12906             (*scalars_p)++;
12907             return S_aassign_padcheck(aTHX_ o, rhs)
12908                 ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
12909         }
12910
12911         /* if its an unrecognised, non-dangerous op, assume that it
12912          * it the cause of at least one safe scalar */
12913         (*scalars_p)++;
12914         flags = AAS_SAFE_SCALAR;
12915         break;
12916     }
12917
12918     /* XXX this assumes that all other ops are "transparent" - i.e. that
12919      * they can return some of their children. While this true for e.g.
12920      * sort and grep, it's not true for e.g. map. We really need a
12921      * 'transparent' flag added to regen/opcodes
12922      */
12923     if (o->op_flags & OPf_KIDS) {
12924         OP *kid;
12925         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
12926             flags |= S_aassign_scan(aTHX_ kid, rhs, kid_top, scalars_p);
12927     }
12928     return flags;
12929 }
12930
12931
12932 /* Check for in place reverse and sort assignments like "@a = reverse @a"
12933    and modify the optree to make them work inplace */
12934
12935 STATIC void
12936 S_inplace_aassign(pTHX_ OP *o) {
12937
12938     OP *modop, *modop_pushmark;
12939     OP *oright;
12940     OP *oleft, *oleft_pushmark;
12941
12942     PERL_ARGS_ASSERT_INPLACE_AASSIGN;
12943
12944     assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
12945
12946     assert(cUNOPo->op_first->op_type == OP_NULL);
12947     modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
12948     assert(modop_pushmark->op_type == OP_PUSHMARK);
12949     modop = OpSIBLING(modop_pushmark);
12950
12951     if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
12952         return;
12953
12954     /* no other operation except sort/reverse */
12955     if (OpHAS_SIBLING(modop))
12956         return;
12957
12958     assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
12959     if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
12960
12961     if (modop->op_flags & OPf_STACKED) {
12962         /* skip sort subroutine/block */
12963         assert(oright->op_type == OP_NULL);
12964         oright = OpSIBLING(oright);
12965     }
12966
12967     assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
12968     oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
12969     assert(oleft_pushmark->op_type == OP_PUSHMARK);
12970     oleft = OpSIBLING(oleft_pushmark);
12971
12972     /* Check the lhs is an array */
12973     if (!oleft ||
12974         (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
12975         || OpHAS_SIBLING(oleft)
12976         || (oleft->op_private & OPpLVAL_INTRO)
12977     )
12978         return;
12979
12980     /* Only one thing on the rhs */
12981     if (OpHAS_SIBLING(oright))
12982         return;
12983
12984     /* check the array is the same on both sides */
12985     if (oleft->op_type == OP_RV2AV) {
12986         if (oright->op_type != OP_RV2AV
12987             || !cUNOPx(oright)->op_first
12988             || cUNOPx(oright)->op_first->op_type != OP_GV
12989             || cUNOPx(oleft )->op_first->op_type != OP_GV
12990             || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
12991                cGVOPx_gv(cUNOPx(oright)->op_first)
12992         )
12993             return;
12994     }
12995     else if (oright->op_type != OP_PADAV
12996         || oright->op_targ != oleft->op_targ
12997     )
12998         return;
12999
13000     /* This actually is an inplace assignment */
13001
13002     modop->op_private |= OPpSORT_INPLACE;
13003
13004     /* transfer MODishness etc from LHS arg to RHS arg */
13005     oright->op_flags = oleft->op_flags;
13006
13007     /* remove the aassign op and the lhs */
13008     op_null(o);
13009     op_null(oleft_pushmark);
13010     if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
13011         op_null(cUNOPx(oleft)->op_first);
13012     op_null(oleft);
13013 }
13014
13015
13016
13017 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
13018  * that potentially represent a series of one or more aggregate derefs
13019  * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
13020  * the whole chain to a single OP_MULTIDEREF op (maybe with a few
13021  * additional ops left in too).
13022  *
13023  * The caller will have already verified that the first few ops in the
13024  * chain following 'start' indicate a multideref candidate, and will have
13025  * set 'orig_o' to the point further on in the chain where the first index
13026  * expression (if any) begins.  'orig_action' specifies what type of
13027  * beginning has already been determined by the ops between start..orig_o
13028  * (e.g.  $lex_ary[], $pkg_ary->{}, expr->[], etc).
13029  *
13030  * 'hints' contains any hints flags that need adding (currently just
13031  * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
13032  */
13033
13034 STATIC void
13035 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
13036 {
13037     dVAR;
13038     int pass;
13039     UNOP_AUX_item *arg_buf = NULL;
13040     bool reset_start_targ  = FALSE; /* start->op_targ needs zeroing */
13041     int index_skip         = -1;    /* don't output index arg on this action */
13042
13043     /* similar to regex compiling, do two passes; the first pass
13044      * determines whether the op chain is convertible and calculates the
13045      * buffer size; the second pass populates the buffer and makes any
13046      * changes necessary to ops (such as moving consts to the pad on
13047      * threaded builds).
13048      *
13049      * NB: for things like Coverity, note that both passes take the same
13050      * path through the logic tree (except for 'if (pass)' bits), since
13051      * both passes are following the same op_next chain; and in
13052      * particular, if it would return early on the second pass, it would
13053      * already have returned early on the first pass.
13054      */
13055     for (pass = 0; pass < 2; pass++) {
13056         OP *o                = orig_o;
13057         UV action            = orig_action;
13058         OP *first_elem_op    = NULL;  /* first seen aelem/helem */
13059         OP *top_op           = NULL;  /* highest [ah]elem/exists/del/rv2[ah]v */
13060         int action_count     = 0;     /* number of actions seen so far */
13061         int action_ix        = 0;     /* action_count % (actions per IV) */
13062         bool next_is_hash    = FALSE; /* is the next lookup to be a hash? */
13063         bool is_last         = FALSE; /* no more derefs to follow */
13064         bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
13065         UNOP_AUX_item *arg     = arg_buf;
13066         UNOP_AUX_item *action_ptr = arg_buf;
13067
13068         if (pass)
13069             action_ptr->uv = 0;
13070         arg++;
13071
13072         switch (action) {
13073         case MDEREF_HV_gvsv_vivify_rv2hv_helem:
13074         case MDEREF_HV_gvhv_helem:
13075             next_is_hash = TRUE;
13076             /* FALLTHROUGH */
13077         case MDEREF_AV_gvsv_vivify_rv2av_aelem:
13078         case MDEREF_AV_gvav_aelem:
13079             if (pass) {
13080 #ifdef USE_ITHREADS
13081                 arg->pad_offset = cPADOPx(start)->op_padix;
13082                 /* stop it being swiped when nulled */
13083                 cPADOPx(start)->op_padix = 0;
13084 #else
13085                 arg->sv = cSVOPx(start)->op_sv;
13086                 cSVOPx(start)->op_sv = NULL;
13087 #endif
13088             }
13089             arg++;
13090             break;
13091
13092         case MDEREF_HV_padhv_helem:
13093         case MDEREF_HV_padsv_vivify_rv2hv_helem:
13094             next_is_hash = TRUE;
13095             /* FALLTHROUGH */
13096         case MDEREF_AV_padav_aelem:
13097         case MDEREF_AV_padsv_vivify_rv2av_aelem:
13098             if (pass) {
13099                 arg->pad_offset = start->op_targ;
13100                 /* we skip setting op_targ = 0 for now, since the intact
13101                  * OP_PADXV is needed by S_check_hash_fields_and_hekify */
13102                 reset_start_targ = TRUE;
13103             }
13104             arg++;
13105             break;
13106
13107         case MDEREF_HV_pop_rv2hv_helem:
13108             next_is_hash = TRUE;
13109             /* FALLTHROUGH */
13110         case MDEREF_AV_pop_rv2av_aelem:
13111             break;
13112
13113         default:
13114             NOT_REACHED; /* NOTREACHED */
13115             return;
13116         }
13117
13118         while (!is_last) {
13119             /* look for another (rv2av/hv; get index;
13120              * aelem/helem/exists/delele) sequence */
13121
13122             OP *kid;
13123             bool is_deref;
13124             bool ok;
13125             UV index_type = MDEREF_INDEX_none;
13126
13127             if (action_count) {
13128                 /* if this is not the first lookup, consume the rv2av/hv  */
13129
13130                 /* for N levels of aggregate lookup, we normally expect
13131                  * that the first N-1 [ah]elem ops will be flagged as
13132                  * /DEREF (so they autovivifiy if necessary), and the last
13133                  * lookup op not to be.
13134                  * For other things (like @{$h{k1}{k2}}) extra scope or
13135                  * leave ops can appear, so abandon the effort in that
13136                  * case */
13137                 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
13138                     return;
13139
13140                 /* rv2av or rv2hv sKR/1 */
13141
13142                 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
13143                                             |OPf_REF|OPf_MOD|OPf_SPECIAL)));
13144                 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
13145                     return;
13146
13147                 /* at this point, we wouldn't expect any of these
13148                  * possible private flags:
13149                  * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
13150                  * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
13151                  */
13152                 ASSUME(!(o->op_private &
13153                     ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
13154
13155                 hints = (o->op_private & OPpHINT_STRICT_REFS);
13156
13157                 /* make sure the type of the previous /DEREF matches the
13158                  * type of the next lookup */
13159                 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
13160                 top_op = o;
13161
13162                 action = next_is_hash
13163                             ? MDEREF_HV_vivify_rv2hv_helem
13164                             : MDEREF_AV_vivify_rv2av_aelem;
13165                 o = o->op_next;
13166             }
13167
13168             /* if this is the second pass, and we're at the depth where
13169              * previously we encountered a non-simple index expression,
13170              * stop processing the index at this point */
13171             if (action_count != index_skip) {
13172
13173                 /* look for one or more simple ops that return an array
13174                  * index or hash key */
13175
13176                 switch (o->op_type) {
13177                 case OP_PADSV:
13178                     /* it may be a lexical var index */
13179                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
13180                                             |OPf_REF|OPf_MOD|OPf_SPECIAL)));
13181                     ASSUME(!(o->op_private &
13182                             ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
13183
13184                     if (   OP_GIMME(o,0) == G_SCALAR
13185                         && !(o->op_flags & (OPf_REF|OPf_MOD))
13186                         && o->op_private == 0)
13187                     {
13188                         if (pass)
13189                             arg->pad_offset = o->op_targ;
13190                         arg++;
13191                         index_type = MDEREF_INDEX_padsv;
13192                         o = o->op_next;
13193                     }
13194                     break;
13195
13196                 case OP_CONST:
13197                     if (next_is_hash) {
13198                         /* it's a constant hash index */
13199                         if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
13200                             /* "use constant foo => FOO; $h{+foo}" for
13201                              * some weird FOO, can leave you with constants
13202                              * that aren't simple strings. It's not worth
13203                              * the extra hassle for those edge cases */
13204                             break;
13205
13206                         if (pass) {
13207                             UNOP *rop = NULL;
13208                             OP * helem_op = o->op_next;
13209
13210                             ASSUME(   helem_op->op_type == OP_HELEM
13211                                    || helem_op->op_type == OP_NULL);
13212                             if (helem_op->op_type == OP_HELEM) {
13213                                 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
13214                                 if (   helem_op->op_private & OPpLVAL_INTRO
13215                                     || rop->op_type != OP_RV2HV
13216                                 )
13217                                     rop = NULL;
13218                             }
13219                             S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo);
13220
13221 #ifdef USE_ITHREADS
13222                             /* Relocate sv to the pad for thread safety */
13223                             op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
13224                             arg->pad_offset = o->op_targ;
13225                             o->op_targ = 0;
13226 #else
13227                             arg->sv = cSVOPx_sv(o);
13228 #endif
13229                         }
13230                     }
13231                     else {
13232                         /* it's a constant array index */
13233                         IV iv;
13234                         SV *ix_sv = cSVOPo->op_sv;
13235                         if (!SvIOK(ix_sv))
13236                             break;
13237                         iv = SvIV(ix_sv);
13238
13239                         if (   action_count == 0
13240                             && iv >= -128
13241                             && iv <= 127
13242                             && (   action == MDEREF_AV_padav_aelem
13243                                 || action == MDEREF_AV_gvav_aelem)
13244                         )
13245                             maybe_aelemfast = TRUE;
13246
13247                         if (pass) {
13248                             arg->iv = iv;
13249                             SvREFCNT_dec_NN(cSVOPo->op_sv);
13250                         }
13251                     }
13252                     if (pass)
13253                         /* we've taken ownership of the SV */
13254                         cSVOPo->op_sv = NULL;
13255                     arg++;
13256                     index_type = MDEREF_INDEX_const;
13257                     o = o->op_next;
13258                     break;
13259
13260                 case OP_GV:
13261                     /* it may be a package var index */
13262
13263                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS|OPf_SPECIAL)));
13264                     ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
13265                     if (  (o->op_flags & ~(OPf_PARENS|OPf_SPECIAL)) != OPf_WANT_SCALAR
13266                         || o->op_private != 0
13267                     )
13268                         break;
13269
13270                     kid = o->op_next;
13271                     if (kid->op_type != OP_RV2SV)
13272                         break;
13273
13274                     ASSUME(!(kid->op_flags &
13275                             ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
13276                              |OPf_SPECIAL|OPf_PARENS)));
13277                     ASSUME(!(kid->op_private &
13278                                     ~(OPpARG1_MASK
13279                                      |OPpHINT_STRICT_REFS|OPpOUR_INTRO
13280                                      |OPpDEREF|OPpLVAL_INTRO)));
13281                     if(   (kid->op_flags &~ OPf_PARENS)
13282                             != (OPf_WANT_SCALAR|OPf_KIDS)
13283                        || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
13284                     )
13285                         break;
13286
13287                     if (pass) {
13288 #ifdef USE_ITHREADS
13289                         arg->pad_offset = cPADOPx(o)->op_padix;
13290                         /* stop it being swiped when nulled */
13291                         cPADOPx(o)->op_padix = 0;
13292 #else
13293                         arg->sv = cSVOPx(o)->op_sv;
13294                         cSVOPo->op_sv = NULL;
13295 #endif
13296                     }
13297                     arg++;
13298                     index_type = MDEREF_INDEX_gvsv;
13299                     o = kid->op_next;
13300                     break;
13301
13302                 } /* switch */
13303             } /* action_count != index_skip */
13304
13305             action |= index_type;
13306
13307
13308             /* at this point we have either:
13309              *   * detected what looks like a simple index expression,
13310              *     and expect the next op to be an [ah]elem, or
13311              *     an nulled  [ah]elem followed by a delete or exists;
13312              *  * found a more complex expression, so something other
13313              *    than the above follows.
13314              */
13315
13316             /* possibly an optimised away [ah]elem (where op_next is
13317              * exists or delete) */
13318             if (o->op_type == OP_NULL)
13319                 o = o->op_next;
13320
13321             /* at this point we're looking for an OP_AELEM, OP_HELEM,
13322              * OP_EXISTS or OP_DELETE */
13323
13324             /* if something like arybase (a.k.a $[ ) is in scope,
13325              * abandon optimisation attempt */
13326             if (  (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
13327                && PL_check[o->op_type] != Perl_ck_null)
13328                 return;
13329             /* similarly for customised exists and delete */
13330             if (  (o->op_type == OP_EXISTS)
13331                && PL_check[o->op_type] != Perl_ck_exists)
13332                 return;
13333             if (  (o->op_type == OP_DELETE)
13334                && PL_check[o->op_type] != Perl_ck_delete)
13335                 return;
13336
13337             if (   o->op_type != OP_AELEM
13338                 || (o->op_private &
13339                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
13340                 )
13341                 maybe_aelemfast = FALSE;
13342
13343             /* look for aelem/helem/exists/delete. If it's not the last elem
13344              * lookup, it *must* have OPpDEREF_AV/HV, but not many other
13345              * flags; if it's the last, then it mustn't have
13346              * OPpDEREF_AV/HV, but may have lots of other flags, like
13347              * OPpLVAL_INTRO etc
13348              */
13349
13350             if (   index_type == MDEREF_INDEX_none
13351                 || (   o->op_type != OP_AELEM  && o->op_type != OP_HELEM
13352                     && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
13353             )
13354                 ok = FALSE;
13355             else {
13356                 /* we have aelem/helem/exists/delete with valid simple index */
13357
13358                 is_deref =    (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
13359                            && (   (o->op_private & OPpDEREF) == OPpDEREF_AV
13360                                || (o->op_private & OPpDEREF) == OPpDEREF_HV);
13361
13362                 /* This doesn't make much sense but is legal:
13363                  *    @{ local $x[0][0] } = 1
13364                  * Since scope exit will undo the autovivification,
13365                  * don't bother in the first place. The OP_LEAVE
13366                  * assertion is in case there are other cases of both
13367                  * OPpLVAL_INTRO and OPpDEREF which don't include a scope
13368                  * exit that would undo the local - in which case this
13369                  * block of code would need rethinking.
13370                  */
13371                 if (is_deref && (o->op_private & OPpLVAL_INTRO)) {
13372 #ifdef DEBUGGING
13373                     OP *n = o->op_next;
13374                     while (n && (  n->op_type == OP_NULL
13375                                 || n->op_type == OP_LIST))
13376                         n = n->op_next;
13377                     assert(n && n->op_type == OP_LEAVE);
13378 #endif
13379                     o->op_private &= ~OPpDEREF;
13380                     is_deref = FALSE;
13381                 }
13382
13383                 if (is_deref) {
13384                     ASSUME(!(o->op_flags &
13385                                  ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
13386                     ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
13387
13388                     ok =    (o->op_flags &~ OPf_PARENS)
13389                                == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
13390                          && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
13391                 }
13392                 else if (o->op_type == OP_EXISTS) {
13393                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
13394                                 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
13395                     ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
13396                     ok =  !(o->op_private & ~OPpARG1_MASK);
13397                 }
13398                 else if (o->op_type == OP_DELETE) {
13399                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
13400                                 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
13401                     ASSUME(!(o->op_private &
13402                                     ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
13403                     /* don't handle slices or 'local delete'; the latter
13404                      * is fairly rare, and has a complex runtime */
13405                     ok =  !(o->op_private & ~OPpARG1_MASK);
13406                     if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
13407                         /* skip handling run-tome error */
13408                         ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
13409                 }
13410                 else {
13411                     ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
13412                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
13413                                             |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
13414                     ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
13415                                     |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
13416                     ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
13417                 }
13418             }
13419
13420             if (ok) {
13421                 if (!first_elem_op)
13422                     first_elem_op = o;
13423                 top_op = o;
13424                 if (is_deref) {
13425                     next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
13426                     o = o->op_next;
13427                 }
13428                 else {
13429                     is_last = TRUE;
13430                     action |= MDEREF_FLAG_last;
13431                 }
13432             }
13433             else {
13434                 /* at this point we have something that started
13435                  * promisingly enough (with rv2av or whatever), but failed
13436                  * to find a simple index followed by an
13437                  * aelem/helem/exists/delete. If this is the first action,
13438                  * give up; but if we've already seen at least one
13439                  * aelem/helem, then keep them and add a new action with
13440                  * MDEREF_INDEX_none, which causes it to do the vivify
13441                  * from the end of the previous lookup, and do the deref,
13442                  * but stop at that point. So $a[0][expr] will do one
13443                  * av_fetch, vivify and deref, then continue executing at
13444                  * expr */
13445                 if (!action_count)
13446                     return;
13447                 is_last = TRUE;
13448                 index_skip = action_count;
13449                 action |= MDEREF_FLAG_last;
13450                 if (index_type != MDEREF_INDEX_none)
13451                     arg--;
13452             }
13453
13454             if (pass)
13455                 action_ptr->uv |= (action << (action_ix * MDEREF_SHIFT));
13456             action_ix++;
13457             action_count++;
13458             /* if there's no space for the next action, create a new slot
13459              * for it *before* we start adding args for that action */
13460             if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
13461                 action_ptr = arg;
13462                 if (pass)
13463                     arg->uv = 0;
13464                 arg++;
13465                 action_ix = 0;
13466             }
13467         } /* while !is_last */
13468
13469         /* success! */
13470
13471         if (pass) {
13472             OP *mderef;
13473             OP *p, *q;
13474
13475             mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
13476             if (index_skip == -1) {
13477                 mderef->op_flags = o->op_flags
13478                         & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
13479                 if (o->op_type == OP_EXISTS)
13480                     mderef->op_private = OPpMULTIDEREF_EXISTS;
13481                 else if (o->op_type == OP_DELETE)
13482                     mderef->op_private = OPpMULTIDEREF_DELETE;
13483                 else
13484                     mderef->op_private = o->op_private
13485                         & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
13486             }
13487             /* accumulate strictness from every level (although I don't think
13488              * they can actually vary) */
13489             mderef->op_private |= hints;
13490
13491             /* integrate the new multideref op into the optree and the
13492              * op_next chain.
13493              *
13494              * In general an op like aelem or helem has two child
13495              * sub-trees: the aggregate expression (a_expr) and the
13496              * index expression (i_expr):
13497              *
13498              *     aelem
13499              *       |
13500              *     a_expr - i_expr
13501              *
13502              * The a_expr returns an AV or HV, while the i-expr returns an
13503              * index. In general a multideref replaces most or all of a
13504              * multi-level tree, e.g.
13505              *
13506              *     exists
13507              *       |
13508              *     ex-aelem
13509              *       |
13510              *     rv2av  - i_expr1
13511              *       |
13512              *     helem
13513              *       |
13514              *     rv2hv  - i_expr2
13515              *       |
13516              *     aelem
13517              *       |
13518              *     a_expr - i_expr3
13519              *
13520              * With multideref, all the i_exprs will be simple vars or
13521              * constants, except that i_expr1 may be arbitrary in the case
13522              * of MDEREF_INDEX_none.
13523              *
13524              * The bottom-most a_expr will be either:
13525              *   1) a simple var (so padXv or gv+rv2Xv);
13526              *   2) a simple scalar var dereferenced (e.g. $r->[0]):
13527              *      so a simple var with an extra rv2Xv;
13528              *   3) or an arbitrary expression.
13529              *
13530              * 'start', the first op in the execution chain, will point to
13531              *   1),2): the padXv or gv op;
13532              *   3):    the rv2Xv which forms the last op in the a_expr
13533              *          execution chain, and the top-most op in the a_expr
13534              *          subtree.
13535              *
13536              * For all cases, the 'start' node is no longer required,
13537              * but we can't free it since one or more external nodes
13538              * may point to it. E.g. consider
13539              *     $h{foo} = $a ? $b : $c
13540              * Here, both the op_next and op_other branches of the
13541              * cond_expr point to the gv[*h] of the hash expression, so
13542              * we can't free the 'start' op.
13543              *
13544              * For expr->[...], we need to save the subtree containing the
13545              * expression; for the other cases, we just need to save the
13546              * start node.
13547              * So in all cases, we null the start op and keep it around by
13548              * making it the child of the multideref op; for the expr->
13549              * case, the expr will be a subtree of the start node.
13550              *
13551              * So in the simple 1,2 case the  optree above changes to
13552              *
13553              *     ex-exists
13554              *       |
13555              *     multideref
13556              *       |
13557              *     ex-gv (or ex-padxv)
13558              *
13559              *  with the op_next chain being
13560              *
13561              *  -> ex-gv -> multideref -> op-following-ex-exists ->
13562              *
13563              *  In the 3 case, we have
13564              *
13565              *     ex-exists
13566              *       |
13567              *     multideref
13568              *       |
13569              *     ex-rv2xv
13570              *       |
13571              *    rest-of-a_expr
13572              *      subtree
13573              *
13574              *  and
13575              *
13576              *  -> rest-of-a_expr subtree ->
13577              *    ex-rv2xv -> multideref -> op-following-ex-exists ->
13578              *
13579              *
13580              * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
13581              * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
13582              * multideref attached as the child, e.g.
13583              *
13584              *     exists
13585              *       |
13586              *     ex-aelem
13587              *       |
13588              *     ex-rv2av  - i_expr1
13589              *       |
13590              *     multideref
13591              *       |
13592              *     ex-whatever
13593              *
13594              */
13595
13596             /* if we free this op, don't free the pad entry */
13597             if (reset_start_targ)
13598                 start->op_targ = 0;
13599
13600
13601             /* Cut the bit we need to save out of the tree and attach to
13602              * the multideref op, then free the rest of the tree */
13603
13604             /* find parent of node to be detached (for use by splice) */
13605             p = first_elem_op;
13606             if (   orig_action == MDEREF_AV_pop_rv2av_aelem
13607                 || orig_action == MDEREF_HV_pop_rv2hv_helem)
13608             {
13609                 /* there is an arbitrary expression preceding us, e.g.
13610                  * expr->[..]? so we need to save the 'expr' subtree */
13611                 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
13612                     p = cUNOPx(p)->op_first;
13613                 ASSUME(   start->op_type == OP_RV2AV
13614                        || start->op_type == OP_RV2HV);
13615             }
13616             else {
13617                 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
13618                  * above for exists/delete. */
13619                 while (   (p->op_flags & OPf_KIDS)
13620                        && cUNOPx(p)->op_first != start
13621                 )
13622                     p = cUNOPx(p)->op_first;
13623             }
13624             ASSUME(cUNOPx(p)->op_first == start);
13625
13626             /* detach from main tree, and re-attach under the multideref */
13627             op_sibling_splice(mderef, NULL, 0,
13628                     op_sibling_splice(p, NULL, 1, NULL));
13629             op_null(start);
13630
13631             start->op_next = mderef;
13632
13633             mderef->op_next = index_skip == -1 ? o->op_next : o;
13634
13635             /* excise and free the original tree, and replace with
13636              * the multideref op */
13637             p = op_sibling_splice(top_op, NULL, -1, mderef);
13638             while (p) {
13639                 q = OpSIBLING(p);
13640                 op_free(p);
13641                 p = q;
13642             }
13643             op_null(top_op);
13644         }
13645         else {
13646             Size_t size = arg - arg_buf;
13647
13648             if (maybe_aelemfast && action_count == 1)
13649                 return;
13650
13651             arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
13652                                 sizeof(UNOP_AUX_item) * (size + 1));
13653             /* for dumping etc: store the length in a hidden first slot;
13654              * we set the op_aux pointer to the second slot */
13655             arg_buf->uv = size;
13656             arg_buf++;
13657         }
13658     } /* for (pass = ...) */
13659 }
13660
13661 /* See if the ops following o are such that o will always be executed in
13662  * boolean context: that is, the SV which o pushes onto the stack will
13663  * only ever be consumed by later ops via SvTRUE(sv) or similar.
13664  * If so, set a suitable private flag on o. Normally this will be
13665  * bool_flag; but see below why maybe_flag is needed too.
13666  *
13667  * Typically the two flags you pass will be the generic OPpTRUEBOOL and
13668  * OPpMAYBE_TRUEBOOL, buts it's possible that for some ops those bits may
13669  * already be taken, so you'll have to give that op two different flags.
13670  *
13671  * More explanation of 'maybe_flag' and 'safe_and' parameters.
13672  * The binary logical ops &&, ||, // (plus 'if' and 'unless' which use
13673  * those underlying ops) short-circuit, which means that rather than
13674  * necessarily returning a truth value, they may return the LH argument,
13675  * which may not be boolean. For example in $x = (keys %h || -1), keys
13676  * should return a key count rather than a boolean, even though its
13677  * sort-of being used in boolean context.
13678  *
13679  * So we only consider such logical ops to provide boolean context to
13680  * their LH argument if they themselves are in void or boolean context.
13681  * However, sometimes the context isn't known until run-time. In this
13682  * case the op is marked with the maybe_flag flag it.
13683  *
13684  * Consider the following.
13685  *
13686  *     sub f { ....;  if (%h) { .... } }
13687  *
13688  * This is actually compiled as
13689  *
13690  *     sub f { ....;  %h && do { .... } }
13691  *
13692  * Here we won't know until runtime whether the final statement (and hence
13693  * the &&) is in void context and so is safe to return a boolean value.
13694  * So mark o with maybe_flag rather than the bool_flag.
13695  * Note that there is cost associated with determining context at runtime
13696  * (e.g. a call to block_gimme()), so it may not be worth setting (at
13697  * compile time) and testing (at runtime) maybe_flag if the scalar verses
13698  * boolean costs savings are marginal.
13699  *
13700  * However, we can do slightly better with && (compared to || and //):
13701  * this op only returns its LH argument when that argument is false. In
13702  * this case, as long as the op promises to return a false value which is
13703  * valid in both boolean and scalar contexts, we can mark an op consumed
13704  * by && with bool_flag rather than maybe_flag.
13705  * For example as long as pp_padhv and pp_rv2hv return &PL_sv_zero rather
13706  * than &PL_sv_no for a false result in boolean context, then it's safe. An
13707  * op which promises to handle this case is indicated by setting safe_and
13708  * to true.
13709  */
13710
13711 static void
13712 S_check_for_bool_cxt(OP*o, bool safe_and, U8 bool_flag, U8 maybe_flag)
13713 {
13714     OP *lop;
13715     U8 flag = 0;
13716
13717     assert((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR);
13718
13719     /* OPpTARGET_MY and boolean context probably don't mix well.
13720      * If someone finds a valid use case, maybe add an extra flag to this
13721      * function which indicates its safe to do so for this op? */
13722     assert(!(   (PL_opargs[o->op_type] & OA_TARGLEX)
13723              && (o->op_private & OPpTARGET_MY)));
13724
13725     lop = o->op_next;
13726
13727     while (lop) {
13728         switch (lop->op_type) {
13729         case OP_NULL:
13730         case OP_SCALAR:
13731             break;
13732
13733         /* these two consume the stack argument in the scalar case,
13734          * and treat it as a boolean in the non linenumber case */
13735         case OP_FLIP:
13736         case OP_FLOP:
13737             if (   ((lop->op_flags & OPf_WANT) == OPf_WANT_LIST)
13738                 || (lop->op_private & OPpFLIP_LINENUM))
13739             {
13740                 lop = NULL;
13741                 break;
13742             }
13743             /* FALLTHROUGH */
13744         /* these never leave the original value on the stack */
13745         case OP_NOT:
13746         case OP_XOR:
13747         case OP_COND_EXPR:
13748         case OP_GREPWHILE:
13749             flag = bool_flag;
13750             lop = NULL;
13751             break;
13752
13753         /* OR DOR and AND evaluate their arg as a boolean, but then may
13754          * leave the original scalar value on the stack when following the
13755          * op_next route. If not in void context, we need to ensure
13756          * that whatever follows consumes the arg only in boolean context
13757          * too.
13758          */
13759         case OP_AND:
13760             if (safe_and) {
13761                 flag = bool_flag;
13762                 lop = NULL;
13763                 break;
13764             }
13765             /* FALLTHROUGH */
13766         case OP_OR:
13767         case OP_DOR:
13768             if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
13769                 flag = bool_flag;
13770                 lop = NULL;
13771             }
13772             else if (!(lop->op_flags & OPf_WANT)) {
13773                 /* unknown context - decide at runtime */
13774                 flag = maybe_flag;
13775                 lop = NULL;
13776             }
13777             break;
13778
13779         default:
13780             lop = NULL;
13781             break;
13782         }
13783
13784         if (lop)
13785             lop = lop->op_next;
13786     }
13787
13788     o->op_private |= flag;
13789 }
13790
13791
13792
13793 /* mechanism for deferring recursion in rpeep() */
13794
13795 #define MAX_DEFERRED 4
13796
13797 #define DEFER(o) \
13798   STMT_START { \
13799     if (defer_ix == (MAX_DEFERRED-1)) { \
13800         OP **defer = defer_queue[defer_base]; \
13801         CALL_RPEEP(*defer); \
13802         S_prune_chain_head(defer); \
13803         defer_base = (defer_base + 1) % MAX_DEFERRED; \
13804         defer_ix--; \
13805     } \
13806     defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
13807   } STMT_END
13808
13809 #define IS_AND_OP(o)   (o->op_type == OP_AND)
13810 #define IS_OR_OP(o)    (o->op_type == OP_OR)
13811
13812
13813 /* A peephole optimizer.  We visit the ops in the order they're to execute.
13814  * See the comments at the top of this file for more details about when
13815  * peep() is called */
13816
13817 void
13818 Perl_rpeep(pTHX_ OP *o)
13819 {
13820     dVAR;
13821     OP* oldop = NULL;
13822     OP* oldoldop = NULL;
13823     OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
13824     int defer_base = 0;
13825     int defer_ix = -1;
13826
13827     if (!o || o->op_opt)
13828         return;
13829
13830     assert(o->op_type != OP_FREED);
13831
13832     ENTER;
13833     SAVEOP();
13834     SAVEVPTR(PL_curcop);
13835     for (;; o = o->op_next) {
13836         if (o && o->op_opt)
13837             o = NULL;
13838         if (!o) {
13839             while (defer_ix >= 0) {
13840                 OP **defer =
13841                         defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
13842                 CALL_RPEEP(*defer);
13843                 S_prune_chain_head(defer);
13844             }
13845             break;
13846         }
13847
13848       redo:
13849
13850         /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */
13851         assert(!oldoldop || oldoldop->op_next == oldop);
13852         assert(!oldop    || oldop->op_next    == o);
13853
13854         /* By default, this op has now been optimised. A couple of cases below
13855            clear this again.  */
13856         o->op_opt = 1;
13857         PL_op = o;
13858
13859         /* look for a series of 1 or more aggregate derefs, e.g.
13860          *   $a[1]{foo}[$i]{$k}
13861          * and replace with a single OP_MULTIDEREF op.
13862          * Each index must be either a const, or a simple variable,
13863          *
13864          * First, look for likely combinations of starting ops,
13865          * corresponding to (global and lexical variants of)
13866          *     $a[...]   $h{...}
13867          *     $r->[...] $r->{...}
13868          *     (preceding expression)->[...]
13869          *     (preceding expression)->{...}
13870          * and if so, call maybe_multideref() to do a full inspection
13871          * of the op chain and if appropriate, replace with an
13872          * OP_MULTIDEREF
13873          */
13874         {
13875             UV action;
13876             OP *o2 = o;
13877             U8 hints = 0;
13878
13879             switch (o2->op_type) {
13880             case OP_GV:
13881                 /* $pkg[..]   :   gv[*pkg]
13882                  * $pkg->[...]:   gv[*pkg]; rv2sv sKM/DREFAV */
13883
13884                 /* Fail if there are new op flag combinations that we're
13885                  * not aware of, rather than:
13886                  *  * silently failing to optimise, or
13887                  *  * silently optimising the flag away.
13888                  * If this ASSUME starts failing, examine what new flag
13889                  * has been added to the op, and decide whether the
13890                  * optimisation should still occur with that flag, then
13891                  * update the code accordingly. This applies to all the
13892                  * other ASSUMEs in the block of code too.
13893                  */
13894                 ASSUME(!(o2->op_flags &
13895                             ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
13896                 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
13897
13898                 o2 = o2->op_next;
13899
13900                 if (o2->op_type == OP_RV2AV) {
13901                     action = MDEREF_AV_gvav_aelem;
13902                     goto do_deref;
13903                 }
13904
13905                 if (o2->op_type == OP_RV2HV) {
13906                     action = MDEREF_HV_gvhv_helem;
13907                     goto do_deref;
13908                 }
13909
13910                 if (o2->op_type != OP_RV2SV)
13911                     break;
13912
13913                 /* at this point we've seen gv,rv2sv, so the only valid
13914                  * construct left is $pkg->[] or $pkg->{} */
13915
13916                 ASSUME(!(o2->op_flags & OPf_STACKED));
13917                 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13918                             != (OPf_WANT_SCALAR|OPf_MOD))
13919                     break;
13920
13921                 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
13922                                     |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
13923                 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
13924                     break;
13925                 if (   (o2->op_private & OPpDEREF) != OPpDEREF_AV
13926                     && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
13927                     break;
13928
13929                 o2 = o2->op_next;
13930                 if (o2->op_type == OP_RV2AV) {
13931                     action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
13932                     goto do_deref;
13933                 }
13934                 if (o2->op_type == OP_RV2HV) {
13935                     action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
13936                     goto do_deref;
13937                 }
13938                 break;
13939
13940             case OP_PADSV:
13941                 /* $lex->[...]: padsv[$lex] sM/DREFAV */
13942
13943                 ASSUME(!(o2->op_flags &
13944                     ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
13945                 if ((o2->op_flags &
13946                         (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13947                      != (OPf_WANT_SCALAR|OPf_MOD))
13948                     break;
13949
13950                 ASSUME(!(o2->op_private &
13951                                 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
13952                 /* skip if state or intro, or not a deref */
13953                 if (      o2->op_private != OPpDEREF_AV
13954                        && o2->op_private != OPpDEREF_HV)
13955                     break;
13956
13957                 o2 = o2->op_next;
13958                 if (o2->op_type == OP_RV2AV) {
13959                     action = MDEREF_AV_padsv_vivify_rv2av_aelem;
13960                     goto do_deref;
13961                 }
13962                 if (o2->op_type == OP_RV2HV) {
13963                     action = MDEREF_HV_padsv_vivify_rv2hv_helem;
13964                     goto do_deref;
13965                 }
13966                 break;
13967
13968             case OP_PADAV:
13969             case OP_PADHV:
13970                 /*    $lex[..]:  padav[@lex:1,2] sR *
13971                  * or $lex{..}:  padhv[%lex:1,2] sR */
13972                 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
13973                                             OPf_REF|OPf_SPECIAL)));
13974                 if ((o2->op_flags &
13975                         (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13976                      != (OPf_WANT_SCALAR|OPf_REF))
13977                     break;
13978                 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
13979                     break;
13980                 /* OPf_PARENS isn't currently used in this case;
13981                  * if that changes, let us know! */
13982                 ASSUME(!(o2->op_flags & OPf_PARENS));
13983
13984                 /* at this point, we wouldn't expect any of the remaining
13985                  * possible private flags:
13986                  * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
13987                  * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
13988                  *
13989                  * OPpSLICEWARNING shouldn't affect runtime
13990                  */
13991                 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
13992
13993                 action = o2->op_type == OP_PADAV
13994                             ? MDEREF_AV_padav_aelem
13995                             : MDEREF_HV_padhv_helem;
13996                 o2 = o2->op_next;
13997                 S_maybe_multideref(aTHX_ o, o2, action, 0);
13998                 break;
13999
14000
14001             case OP_RV2AV:
14002             case OP_RV2HV:
14003                 action = o2->op_type == OP_RV2AV
14004                             ? MDEREF_AV_pop_rv2av_aelem
14005                             : MDEREF_HV_pop_rv2hv_helem;
14006                 /* FALLTHROUGH */
14007             do_deref:
14008                 /* (expr)->[...]:  rv2av sKR/1;
14009                  * (expr)->{...}:  rv2hv sKR/1; */
14010
14011                 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
14012
14013                 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14014                                 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
14015                 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
14016                     break;
14017
14018                 /* at this point, we wouldn't expect any of these
14019                  * possible private flags:
14020                  * OPpMAYBE_LVSUB, OPpLVAL_INTRO
14021                  * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
14022                  */
14023                 ASSUME(!(o2->op_private &
14024                     ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
14025                      |OPpOUR_INTRO)));
14026                 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
14027
14028                 o2 = o2->op_next;
14029
14030                 S_maybe_multideref(aTHX_ o, o2, action, hints);
14031                 break;
14032
14033             default:
14034                 break;
14035             }
14036         }
14037
14038
14039         switch (o->op_type) {
14040         case OP_DBSTATE:
14041             PL_curcop = ((COP*)o);              /* for warnings */
14042             break;
14043         case OP_NEXTSTATE:
14044             PL_curcop = ((COP*)o);              /* for warnings */
14045
14046             /* Optimise a "return ..." at the end of a sub to just be "...".
14047              * This saves 2 ops. Before:
14048              * 1  <;> nextstate(main 1 -e:1) v ->2
14049              * 4  <@> return K ->5
14050              * 2    <0> pushmark s ->3
14051              * -    <1> ex-rv2sv sK/1 ->4
14052              * 3      <#> gvsv[*cat] s ->4
14053              *
14054              * After:
14055              * -  <@> return K ->-
14056              * -    <0> pushmark s ->2
14057              * -    <1> ex-rv2sv sK/1 ->-
14058              * 2      <$> gvsv(*cat) s ->3
14059              */
14060             {
14061                 OP *next = o->op_next;
14062                 OP *sibling = OpSIBLING(o);
14063                 if (   OP_TYPE_IS(next, OP_PUSHMARK)
14064                     && OP_TYPE_IS(sibling, OP_RETURN)
14065                     && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
14066                     && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
14067                        ||OP_TYPE_IS(sibling->op_next->op_next,
14068                                     OP_LEAVESUBLV))
14069                     && cUNOPx(sibling)->op_first == next
14070                     && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
14071                     && next->op_next
14072                 ) {
14073                     /* Look through the PUSHMARK's siblings for one that
14074                      * points to the RETURN */
14075                     OP *top = OpSIBLING(next);
14076                     while (top && top->op_next) {
14077                         if (top->op_next == sibling) {
14078                             top->op_next = sibling->op_next;
14079                             o->op_next = next->op_next;
14080                             break;
14081                         }
14082                         top = OpSIBLING(top);
14083                     }
14084                 }
14085             }
14086
14087             /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
14088              *
14089              * This latter form is then suitable for conversion into padrange
14090              * later on. Convert:
14091              *
14092              *   nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
14093              *
14094              * into:
14095              *
14096              *   nextstate1 ->     listop     -> nextstate3
14097              *                 /            \
14098              *         pushmark -> padop1 -> padop2
14099              */
14100             if (o->op_next && (
14101                     o->op_next->op_type == OP_PADSV
14102                  || o->op_next->op_type == OP_PADAV
14103                  || o->op_next->op_type == OP_PADHV
14104                 )
14105                 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
14106                 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
14107                 && o->op_next->op_next->op_next && (
14108                     o->op_next->op_next->op_next->op_type == OP_PADSV
14109                  || o->op_next->op_next->op_next->op_type == OP_PADAV
14110                  || o->op_next->op_next->op_next->op_type == OP_PADHV
14111                 )
14112                 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
14113                 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
14114                 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
14115                 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
14116             ) {
14117                 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
14118
14119                 pad1 =    o->op_next;
14120                 ns2  = pad1->op_next;
14121                 pad2 =  ns2->op_next;
14122                 ns3  = pad2->op_next;
14123
14124                 /* we assume here that the op_next chain is the same as
14125                  * the op_sibling chain */
14126                 assert(OpSIBLING(o)    == pad1);
14127                 assert(OpSIBLING(pad1) == ns2);
14128                 assert(OpSIBLING(ns2)  == pad2);
14129                 assert(OpSIBLING(pad2) == ns3);
14130
14131                 /* excise and delete ns2 */
14132                 op_sibling_splice(NULL, pad1, 1, NULL);
14133                 op_free(ns2);
14134
14135                 /* excise pad1 and pad2 */
14136                 op_sibling_splice(NULL, o, 2, NULL);
14137
14138                 /* create new listop, with children consisting of:
14139                  * a new pushmark, pad1, pad2. */
14140                 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
14141                 newop->op_flags |= OPf_PARENS;
14142                 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
14143
14144                 /* insert newop between o and ns3 */
14145                 op_sibling_splice(NULL, o, 0, newop);
14146
14147                 /*fixup op_next chain */
14148                 newpm = cUNOPx(newop)->op_first; /* pushmark */
14149                 o    ->op_next = newpm;
14150                 newpm->op_next = pad1;
14151                 pad1 ->op_next = pad2;
14152                 pad2 ->op_next = newop; /* listop */
14153                 newop->op_next = ns3;
14154
14155                 /* Ensure pushmark has this flag if padops do */
14156                 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
14157                     newpm->op_flags |= OPf_MOD;
14158                 }
14159
14160                 break;
14161             }
14162
14163             /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
14164                to carry two labels. For now, take the easier option, and skip
14165                this optimisation if the first NEXTSTATE has a label.  */
14166             if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
14167                 OP *nextop = o->op_next;
14168                 while (nextop && nextop->op_type == OP_NULL)
14169                     nextop = nextop->op_next;
14170
14171                 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
14172                     op_null(o);
14173                     if (oldop)
14174                         oldop->op_next = nextop;
14175                     o = nextop;
14176                     /* Skip (old)oldop assignment since the current oldop's
14177                        op_next already points to the next op.  */
14178                     goto redo;
14179                 }
14180             }
14181             break;
14182
14183         case OP_CONCAT:
14184             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
14185                 if (o->op_next->op_private & OPpTARGET_MY) {
14186                     if (o->op_flags & OPf_STACKED) /* chained concats */
14187                         break; /* ignore_optimization */
14188                     else {
14189                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
14190                         o->op_targ = o->op_next->op_targ;
14191                         o->op_next->op_targ = 0;
14192                         o->op_private |= OPpTARGET_MY;
14193                     }
14194                 }
14195                 op_null(o->op_next);
14196             }
14197             break;
14198         case OP_STUB:
14199             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
14200                 break; /* Scalar stub must produce undef.  List stub is noop */
14201             }
14202             goto nothin;
14203         case OP_NULL:
14204             if (o->op_targ == OP_NEXTSTATE
14205                 || o->op_targ == OP_DBSTATE)
14206             {
14207                 PL_curcop = ((COP*)o);
14208             }
14209             /* XXX: We avoid setting op_seq here to prevent later calls
14210                to rpeep() from mistakenly concluding that optimisation
14211                has already occurred. This doesn't fix the real problem,
14212                though (See 20010220.007 (#5874)). AMS 20010719 */
14213             /* op_seq functionality is now replaced by op_opt */
14214             o->op_opt = 0;
14215             /* FALLTHROUGH */
14216         case OP_SCALAR:
14217         case OP_LINESEQ:
14218         case OP_SCOPE:
14219         nothin:
14220             if (oldop) {
14221                 oldop->op_next = o->op_next;
14222                 o->op_opt = 0;
14223                 continue;
14224             }
14225             break;
14226
14227         case OP_PUSHMARK:
14228
14229             /* Given
14230                  5 repeat/DOLIST
14231                  3   ex-list
14232                  1     pushmark
14233                  2     scalar or const
14234                  4   const[0]
14235                convert repeat into a stub with no kids.
14236              */
14237             if (o->op_next->op_type == OP_CONST
14238              || (  o->op_next->op_type == OP_PADSV
14239                 && !(o->op_next->op_private & OPpLVAL_INTRO))
14240              || (  o->op_next->op_type == OP_GV
14241                 && o->op_next->op_next->op_type == OP_RV2SV
14242                 && !(o->op_next->op_next->op_private
14243                         & (OPpLVAL_INTRO|OPpOUR_INTRO))))
14244             {
14245                 const OP *kid = o->op_next->op_next;
14246                 if (o->op_next->op_type == OP_GV)
14247                    kid = kid->op_next;
14248                 /* kid is now the ex-list.  */
14249                 if (kid->op_type == OP_NULL
14250                  && (kid = kid->op_next)->op_type == OP_CONST
14251                     /* kid is now the repeat count.  */
14252                  && kid->op_next->op_type == OP_REPEAT
14253                  && kid->op_next->op_private & OPpREPEAT_DOLIST
14254                  && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
14255                  && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0
14256                  && oldop)
14257                 {
14258                     o = kid->op_next; /* repeat */
14259                     oldop->op_next = o;
14260                     op_free(cBINOPo->op_first);
14261                     op_free(cBINOPo->op_last );
14262                     o->op_flags &=~ OPf_KIDS;
14263                     /* stub is a baseop; repeat is a binop */
14264                     STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
14265                     OpTYPE_set(o, OP_STUB);
14266                     o->op_private = 0;
14267                     break;
14268                 }
14269             }
14270
14271             /* Convert a series of PAD ops for my vars plus support into a
14272              * single padrange op. Basically
14273              *
14274              *    pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
14275              *
14276              * becomes, depending on circumstances, one of
14277              *
14278              *    padrange  ----------------------------------> (list) -> rest
14279              *    padrange  --------------------------------------------> rest
14280              *
14281              * where all the pad indexes are sequential and of the same type
14282              * (INTRO or not).
14283              * We convert the pushmark into a padrange op, then skip
14284              * any other pad ops, and possibly some trailing ops.
14285              * Note that we don't null() the skipped ops, to make it
14286              * easier for Deparse to undo this optimisation (and none of
14287              * the skipped ops are holding any resourses). It also makes
14288              * it easier for find_uninit_var(), as it can just ignore
14289              * padrange, and examine the original pad ops.
14290              */
14291         {
14292             OP *p;
14293             OP *followop = NULL; /* the op that will follow the padrange op */
14294             U8 count = 0;
14295             U8 intro = 0;
14296             PADOFFSET base = 0; /* init only to stop compiler whining */
14297             bool gvoid = 0;     /* init only to stop compiler whining */
14298             bool defav = 0;  /* seen (...) = @_ */
14299             bool reuse = 0;  /* reuse an existing padrange op */
14300
14301             /* look for a pushmark -> gv[_] -> rv2av */
14302
14303             {
14304                 OP *rv2av, *q;
14305                 p = o->op_next;
14306                 if (   p->op_type == OP_GV
14307                     && cGVOPx_gv(p) == PL_defgv
14308                     && (rv2av = p->op_next)
14309                     && rv2av->op_type == OP_RV2AV
14310                     && !(rv2av->op_flags & OPf_REF)
14311                     && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
14312                     && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
14313                 ) {
14314                     q = rv2av->op_next;
14315                     if (q->op_type == OP_NULL)
14316                         q = q->op_next;
14317                     if (q->op_type == OP_PUSHMARK) {
14318                         defav = 1;
14319                         p = q;
14320                     }
14321                 }
14322             }
14323             if (!defav) {
14324                 p = o;
14325             }
14326
14327             /* scan for PAD ops */
14328
14329             for (p = p->op_next; p; p = p->op_next) {
14330                 if (p->op_type == OP_NULL)
14331                     continue;
14332
14333                 if ((     p->op_type != OP_PADSV
14334                        && p->op_type != OP_PADAV
14335                        && p->op_type != OP_PADHV
14336                     )
14337                       /* any private flag other than INTRO? e.g. STATE */
14338                    || (p->op_private & ~OPpLVAL_INTRO)
14339                 )
14340                     break;
14341
14342                 /* let $a[N] potentially be optimised into AELEMFAST_LEX
14343                  * instead */
14344                 if (   p->op_type == OP_PADAV
14345                     && p->op_next
14346                     && p->op_next->op_type == OP_CONST
14347                     && p->op_next->op_next
14348                     && p->op_next->op_next->op_type == OP_AELEM
14349                 )
14350                     break;
14351
14352                 /* for 1st padop, note what type it is and the range
14353                  * start; for the others, check that it's the same type
14354                  * and that the targs are contiguous */
14355                 if (count == 0) {
14356                     intro = (p->op_private & OPpLVAL_INTRO);
14357                     base = p->op_targ;
14358                     gvoid = OP_GIMME(p,0) == G_VOID;
14359                 }
14360                 else {
14361                     if ((p->op_private & OPpLVAL_INTRO) != intro)
14362                         break;
14363                     /* Note that you'd normally  expect targs to be
14364                      * contiguous in my($a,$b,$c), but that's not the case
14365                      * when external modules start doing things, e.g.
14366                      * Function::Parameters */
14367                     if (p->op_targ != base + count)
14368                         break;
14369                     assert(p->op_targ == base + count);
14370                     /* Either all the padops or none of the padops should
14371                        be in void context.  Since we only do the optimisa-
14372                        tion for av/hv when the aggregate itself is pushed
14373                        on to the stack (one item), there is no need to dis-
14374                        tinguish list from scalar context.  */
14375                     if (gvoid != (OP_GIMME(p,0) == G_VOID))
14376                         break;
14377                 }
14378
14379                 /* for AV, HV, only when we're not flattening */
14380                 if (   p->op_type != OP_PADSV
14381                     && !gvoid
14382                     && !(p->op_flags & OPf_REF)
14383                 )
14384                     break;
14385
14386                 if (count >= OPpPADRANGE_COUNTMASK)
14387                     break;
14388
14389                 /* there's a biggest base we can fit into a
14390                  * SAVEt_CLEARPADRANGE in pp_padrange.
14391                  * (The sizeof() stuff will be constant-folded, and is
14392                  * intended to avoid getting "comparison is always false"
14393                  * compiler warnings. See the comments above
14394                  * MEM_WRAP_CHECK for more explanation on why we do this
14395                  * in a weird way to avoid compiler warnings.)
14396                  */
14397                 if (   intro
14398                     && (8*sizeof(base) >
14399                         8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
14400                         ? (Size_t)base
14401                         : (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
14402                         ) >
14403                         (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
14404                 )
14405                     break;
14406
14407                 /* Success! We've got another valid pad op to optimise away */
14408                 count++;
14409                 followop = p->op_next;
14410             }
14411
14412             if (count < 1 || (count == 1 && !defav))
14413                 break;
14414
14415             /* pp_padrange in specifically compile-time void context
14416              * skips pushing a mark and lexicals; in all other contexts
14417              * (including unknown till runtime) it pushes a mark and the
14418              * lexicals. We must be very careful then, that the ops we
14419              * optimise away would have exactly the same effect as the
14420              * padrange.
14421              * In particular in void context, we can only optimise to
14422              * a padrange if we see the complete sequence
14423              *     pushmark, pad*v, ...., list
14424              * which has the net effect of leaving the markstack as it
14425              * was.  Not pushing onto the stack (whereas padsv does touch
14426              * the stack) makes no difference in void context.
14427              */
14428             assert(followop);
14429             if (gvoid) {
14430                 if (followop->op_type == OP_LIST
14431                         && OP_GIMME(followop,0) == G_VOID
14432                    )
14433                 {
14434                     followop = followop->op_next; /* skip OP_LIST */
14435
14436                     /* consolidate two successive my(...);'s */
14437
14438                     if (   oldoldop
14439                         && oldoldop->op_type == OP_PADRANGE
14440                         && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
14441                         && (oldoldop->op_private & OPpLVAL_INTRO) == intro
14442                         && !(oldoldop->op_flags & OPf_SPECIAL)
14443                     ) {
14444                         U8 old_count;
14445                         assert(oldoldop->op_next == oldop);
14446                         assert(   oldop->op_type == OP_NEXTSTATE
14447                                || oldop->op_type == OP_DBSTATE);
14448                         assert(oldop->op_next == o);
14449
14450                         old_count
14451                             = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
14452
14453                        /* Do not assume pad offsets for $c and $d are con-
14454                           tiguous in
14455                             my ($a,$b,$c);
14456                             my ($d,$e,$f);
14457                         */
14458                         if (  oldoldop->op_targ + old_count == base
14459                            && old_count < OPpPADRANGE_COUNTMASK - count) {
14460                             base = oldoldop->op_targ;
14461                             count += old_count;
14462                             reuse = 1;
14463                         }
14464                     }
14465
14466                     /* if there's any immediately following singleton
14467                      * my var's; then swallow them and the associated
14468                      * nextstates; i.e.
14469                      *    my ($a,$b); my $c; my $d;
14470                      * is treated as
14471                      *    my ($a,$b,$c,$d);
14472                      */
14473
14474                     while (    ((p = followop->op_next))
14475                             && (  p->op_type == OP_PADSV
14476                                || p->op_type == OP_PADAV
14477                                || p->op_type == OP_PADHV)
14478                             && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
14479                             && (p->op_private & OPpLVAL_INTRO) == intro
14480                             && !(p->op_private & ~OPpLVAL_INTRO)
14481                             && p->op_next
14482                             && (   p->op_next->op_type == OP_NEXTSTATE
14483                                 || p->op_next->op_type == OP_DBSTATE)
14484                             && count < OPpPADRANGE_COUNTMASK
14485                             && base + count == p->op_targ
14486                     ) {
14487                         count++;
14488                         followop = p->op_next;
14489                     }
14490                 }
14491                 else
14492                     break;
14493             }
14494
14495             if (reuse) {
14496                 assert(oldoldop->op_type == OP_PADRANGE);
14497                 oldoldop->op_next = followop;
14498                 oldoldop->op_private = (intro | count);
14499                 o = oldoldop;
14500                 oldop = NULL;
14501                 oldoldop = NULL;
14502             }
14503             else {
14504                 /* Convert the pushmark into a padrange.
14505                  * To make Deparse easier, we guarantee that a padrange was
14506                  * *always* formerly a pushmark */
14507                 assert(o->op_type == OP_PUSHMARK);
14508                 o->op_next = followop;
14509                 OpTYPE_set(o, OP_PADRANGE);
14510                 o->op_targ = base;
14511                 /* bit 7: INTRO; bit 6..0: count */
14512                 o->op_private = (intro | count);
14513                 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
14514                               | gvoid * OPf_WANT_VOID
14515                               | (defav ? OPf_SPECIAL : 0));
14516             }
14517             break;
14518         }
14519
14520         case OP_RV2AV:
14521             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
14522                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
14523             break;
14524
14525         case OP_RV2HV:
14526         case OP_PADHV:
14527             /*'keys %h' in void or scalar context: skip the OP_KEYS
14528              * and perform the functionality directly in the RV2HV/PADHV
14529              * op
14530              */
14531             if (o->op_flags & OPf_REF) {
14532                 OP *k = o->op_next;
14533                 U8 want = (k->op_flags & OPf_WANT);
14534                 if (   k
14535                     && k->op_type == OP_KEYS
14536                     && (   want == OPf_WANT_VOID
14537                         || want == OPf_WANT_SCALAR)
14538                     && !(k->op_private & OPpMAYBE_LVSUB)
14539                     && !(k->op_flags & OPf_MOD)
14540                 ) {
14541                     o->op_next     = k->op_next;
14542                     o->op_flags   &= ~(OPf_REF|OPf_WANT);
14543                     o->op_flags   |= want;
14544                     o->op_private |= (o->op_type == OP_PADHV ?
14545                                       OPpRV2HV_ISKEYS : OPpRV2HV_ISKEYS);
14546                     /* for keys(%lex), hold onto the OP_KEYS's targ
14547                      * since padhv doesn't have its own targ to return
14548                      * an int with */
14549                     if (!(o->op_type ==OP_PADHV && want == OPf_WANT_SCALAR))
14550                         op_null(k);
14551                 }
14552             }
14553
14554             /* see if %h is used in boolean context */
14555             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
14556                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
14557
14558
14559             if (o->op_type != OP_PADHV)
14560                 break;
14561             /* FALLTHROUGH */
14562         case OP_PADAV:
14563             if (   o->op_type == OP_PADAV
14564                 && (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
14565             )
14566                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
14567             /* FALLTHROUGH */
14568         case OP_PADSV:
14569             /* Skip over state($x) in void context.  */
14570             if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
14571              && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
14572             {
14573                 oldop->op_next = o->op_next;
14574                 goto redo_nextstate;
14575             }
14576             if (o->op_type != OP_PADAV)
14577                 break;
14578             /* FALLTHROUGH */
14579         case OP_GV:
14580             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
14581                 OP* const pop = (o->op_type == OP_PADAV) ?
14582                             o->op_next : o->op_next->op_next;
14583                 IV i;
14584                 if (pop && pop->op_type == OP_CONST &&
14585                     ((PL_op = pop->op_next)) &&
14586                     pop->op_next->op_type == OP_AELEM &&
14587                     !(pop->op_next->op_private &
14588                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
14589                     (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
14590                 {
14591                     GV *gv;
14592                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
14593                         no_bareword_allowed(pop);
14594                     if (o->op_type == OP_GV)
14595                         op_null(o->op_next);
14596                     op_null(pop->op_next);
14597                     op_null(pop);
14598                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
14599                     o->op_next = pop->op_next->op_next;
14600                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
14601                     o->op_private = (U8)i;
14602                     if (o->op_type == OP_GV) {
14603                         gv = cGVOPo_gv;
14604                         GvAVn(gv);
14605                         o->op_type = OP_AELEMFAST;
14606                     }
14607                     else
14608                         o->op_type = OP_AELEMFAST_LEX;
14609                 }
14610                 if (o->op_type != OP_GV)
14611                     break;
14612             }
14613
14614             /* Remove $foo from the op_next chain in void context.  */
14615             if (oldop
14616              && (  o->op_next->op_type == OP_RV2SV
14617                 || o->op_next->op_type == OP_RV2AV
14618                 || o->op_next->op_type == OP_RV2HV  )
14619              && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
14620              && !(o->op_next->op_private & OPpLVAL_INTRO))
14621             {
14622                 oldop->op_next = o->op_next->op_next;
14623                 /* Reprocess the previous op if it is a nextstate, to
14624                    allow double-nextstate optimisation.  */
14625               redo_nextstate:
14626                 if (oldop->op_type == OP_NEXTSTATE) {
14627                     oldop->op_opt = 0;
14628                     o = oldop;
14629                     oldop = oldoldop;
14630                     oldoldop = NULL;
14631                     goto redo;
14632                 }
14633                 o = oldop->op_next;
14634                 goto redo;
14635             }
14636             else if (o->op_next->op_type == OP_RV2SV) {
14637                 if (!(o->op_next->op_private & OPpDEREF)) {
14638                     op_null(o->op_next);
14639                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
14640                                                                | OPpOUR_INTRO);
14641                     o->op_next = o->op_next->op_next;
14642                     OpTYPE_set(o, OP_GVSV);
14643                 }
14644             }
14645             else if (o->op_next->op_type == OP_READLINE
14646                     && o->op_next->op_next->op_type == OP_CONCAT
14647                     && (o->op_next->op_next->op_flags & OPf_STACKED))
14648             {
14649                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
14650                 OpTYPE_set(o, OP_RCATLINE);
14651                 o->op_flags |= OPf_STACKED;
14652                 op_null(o->op_next->op_next);
14653                 op_null(o->op_next);
14654             }
14655
14656             break;
14657
14658         case OP_NOT:
14659             break;
14660
14661         case OP_AND:
14662         case OP_OR:
14663         case OP_DOR:
14664             while (cLOGOP->op_other->op_type == OP_NULL)
14665                 cLOGOP->op_other = cLOGOP->op_other->op_next;
14666             while (o->op_next && (   o->op_type == o->op_next->op_type
14667                                   || o->op_next->op_type == OP_NULL))
14668                 o->op_next = o->op_next->op_next;
14669
14670             /* If we're an OR and our next is an AND in void context, we'll
14671                follow its op_other on short circuit, same for reverse.
14672                We can't do this with OP_DOR since if it's true, its return
14673                value is the underlying value which must be evaluated
14674                by the next op. */
14675             if (o->op_next &&
14676                 (
14677                     (IS_AND_OP(o) && IS_OR_OP(o->op_next))
14678                  || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
14679                 )
14680                 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
14681             ) {
14682                 o->op_next = ((LOGOP*)o->op_next)->op_other;
14683             }
14684             DEFER(cLOGOP->op_other);
14685             o->op_opt = 1;
14686             break;
14687
14688         case OP_GREPWHILE:
14689             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
14690                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
14691             /* FALLTHROUGH */
14692         case OP_COND_EXPR:
14693         case OP_MAPWHILE:
14694         case OP_ANDASSIGN:
14695         case OP_ORASSIGN:
14696         case OP_DORASSIGN:
14697         case OP_RANGE:
14698         case OP_ONCE:
14699         case OP_ARGDEFELEM:
14700             while (cLOGOP->op_other->op_type == OP_NULL)
14701                 cLOGOP->op_other = cLOGOP->op_other->op_next;
14702             DEFER(cLOGOP->op_other);
14703             break;
14704
14705         case OP_ENTERLOOP:
14706         case OP_ENTERITER:
14707             while (cLOOP->op_redoop->op_type == OP_NULL)
14708                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
14709             while (cLOOP->op_nextop->op_type == OP_NULL)
14710                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
14711             while (cLOOP->op_lastop->op_type == OP_NULL)
14712                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
14713             /* a while(1) loop doesn't have an op_next that escapes the
14714              * loop, so we have to explicitly follow the op_lastop to
14715              * process the rest of the code */
14716             DEFER(cLOOP->op_lastop);
14717             break;
14718
14719         case OP_ENTERTRY:
14720             assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
14721             DEFER(cLOGOPo->op_other);
14722             break;
14723
14724         case OP_SUBST:
14725             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
14726                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
14727             assert(!(cPMOP->op_pmflags & PMf_ONCE));
14728             while (cPMOP->op_pmstashstartu.op_pmreplstart &&
14729                    cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
14730                 cPMOP->op_pmstashstartu.op_pmreplstart
14731                     = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
14732             DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
14733             break;
14734
14735         case OP_SORT: {
14736             OP *oright;
14737
14738             if (o->op_flags & OPf_SPECIAL) {
14739                 /* first arg is a code block */
14740                 OP * const nullop = OpSIBLING(cLISTOP->op_first);
14741                 OP * kid          = cUNOPx(nullop)->op_first;
14742
14743                 assert(nullop->op_type == OP_NULL);
14744                 assert(kid->op_type == OP_SCOPE
14745                  || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
14746                 /* since OP_SORT doesn't have a handy op_other-style
14747                  * field that can point directly to the start of the code
14748                  * block, store it in the otherwise-unused op_next field
14749                  * of the top-level OP_NULL. This will be quicker at
14750                  * run-time, and it will also allow us to remove leading
14751                  * OP_NULLs by just messing with op_nexts without
14752                  * altering the basic op_first/op_sibling layout. */
14753                 kid = kLISTOP->op_first;
14754                 assert(
14755                       (kid->op_type == OP_NULL
14756                       && (  kid->op_targ == OP_NEXTSTATE
14757                          || kid->op_targ == OP_DBSTATE  ))
14758                     || kid->op_type == OP_STUB
14759                     || kid->op_type == OP_ENTER
14760                     || (PL_parser && PL_parser->error_count));
14761                 nullop->op_next = kid->op_next;
14762                 DEFER(nullop->op_next);
14763             }
14764
14765             /* check that RHS of sort is a single plain array */
14766             oright = cUNOPo->op_first;
14767             if (!oright || oright->op_type != OP_PUSHMARK)
14768                 break;
14769
14770             if (o->op_private & OPpSORT_INPLACE)
14771                 break;
14772
14773             /* reverse sort ... can be optimised.  */
14774             if (!OpHAS_SIBLING(cUNOPo)) {
14775                 /* Nothing follows us on the list. */
14776                 OP * const reverse = o->op_next;
14777
14778                 if (reverse->op_type == OP_REVERSE &&
14779                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
14780                     OP * const pushmark = cUNOPx(reverse)->op_first;
14781                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
14782                         && (OpSIBLING(cUNOPx(pushmark)) == o)) {
14783                         /* reverse -> pushmark -> sort */
14784                         o->op_private |= OPpSORT_REVERSE;
14785                         op_null(reverse);
14786                         pushmark->op_next = oright->op_next;
14787                         op_null(oright);
14788                     }
14789                 }
14790             }
14791
14792             break;
14793         }
14794
14795         case OP_REVERSE: {
14796             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
14797             OP *gvop = NULL;
14798             LISTOP *enter, *exlist;
14799
14800             if (o->op_private & OPpSORT_INPLACE)
14801                 break;
14802
14803             enter = (LISTOP *) o->op_next;
14804             if (!enter)
14805                 break;
14806             if (enter->op_type == OP_NULL) {
14807                 enter = (LISTOP *) enter->op_next;
14808                 if (!enter)
14809                     break;
14810             }
14811             /* for $a (...) will have OP_GV then OP_RV2GV here.
14812                for (...) just has an OP_GV.  */
14813             if (enter->op_type == OP_GV) {
14814                 gvop = (OP *) enter;
14815                 enter = (LISTOP *) enter->op_next;
14816                 if (!enter)
14817                     break;
14818                 if (enter->op_type == OP_RV2GV) {
14819                   enter = (LISTOP *) enter->op_next;
14820                   if (!enter)
14821                     break;
14822                 }
14823             }
14824
14825             if (enter->op_type != OP_ENTERITER)
14826                 break;
14827
14828             iter = enter->op_next;
14829             if (!iter || iter->op_type != OP_ITER)
14830                 break;
14831
14832             expushmark = enter->op_first;
14833             if (!expushmark || expushmark->op_type != OP_NULL
14834                 || expushmark->op_targ != OP_PUSHMARK)
14835                 break;
14836
14837             exlist = (LISTOP *) OpSIBLING(expushmark);
14838             if (!exlist || exlist->op_type != OP_NULL
14839                 || exlist->op_targ != OP_LIST)
14840                 break;
14841
14842             if (exlist->op_last != o) {
14843                 /* Mmm. Was expecting to point back to this op.  */
14844                 break;
14845             }
14846             theirmark = exlist->op_first;
14847             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
14848                 break;
14849
14850             if (OpSIBLING(theirmark) != o) {
14851                 /* There's something between the mark and the reverse, eg
14852                    for (1, reverse (...))
14853                    so no go.  */
14854                 break;
14855             }
14856
14857             ourmark = ((LISTOP *)o)->op_first;
14858             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
14859                 break;
14860
14861             ourlast = ((LISTOP *)o)->op_last;
14862             if (!ourlast || ourlast->op_next != o)
14863                 break;
14864
14865             rv2av = OpSIBLING(ourmark);
14866             if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
14867                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
14868                 /* We're just reversing a single array.  */
14869                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
14870                 enter->op_flags |= OPf_STACKED;
14871             }
14872
14873             /* We don't have control over who points to theirmark, so sacrifice
14874                ours.  */
14875             theirmark->op_next = ourmark->op_next;
14876             theirmark->op_flags = ourmark->op_flags;
14877             ourlast->op_next = gvop ? gvop : (OP *) enter;
14878             op_null(ourmark);
14879             op_null(o);
14880             enter->op_private |= OPpITER_REVERSED;
14881             iter->op_private |= OPpITER_REVERSED;
14882
14883             oldoldop = NULL;
14884             oldop    = ourlast;
14885             o        = oldop->op_next;
14886             goto redo;
14887             NOT_REACHED; /* NOTREACHED */
14888             break;
14889         }
14890
14891         case OP_QR:
14892         case OP_MATCH:
14893             if (!(cPMOP->op_pmflags & PMf_ONCE)) {
14894                 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
14895             }
14896             break;
14897
14898         case OP_RUNCV:
14899             if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
14900              && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
14901             {
14902                 SV *sv;
14903                 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
14904                 else {
14905                     sv = newRV((SV *)PL_compcv);
14906                     sv_rvweaken(sv);
14907                     SvREADONLY_on(sv);
14908                 }
14909                 OpTYPE_set(o, OP_CONST);
14910                 o->op_flags |= OPf_SPECIAL;
14911                 cSVOPo->op_sv = sv;
14912             }
14913             break;
14914
14915         case OP_SASSIGN:
14916             if (OP_GIMME(o,0) == G_VOID
14917              || (  o->op_next->op_type == OP_LINESEQ
14918                 && (  o->op_next->op_next->op_type == OP_LEAVESUB
14919                    || (  o->op_next->op_next->op_type == OP_RETURN
14920                       && !CvLVALUE(PL_compcv)))))
14921             {
14922                 OP *right = cBINOP->op_first;
14923                 if (right) {
14924                     /*   sassign
14925                     *      RIGHT
14926                     *      substr
14927                     *         pushmark
14928                     *         arg1
14929                     *         arg2
14930                     *         ...
14931                     * becomes
14932                     *
14933                     *  ex-sassign
14934                     *     substr
14935                     *        pushmark
14936                     *        RIGHT
14937                     *        arg1
14938                     *        arg2
14939                     *        ...
14940                     */
14941                     OP *left = OpSIBLING(right);
14942                     if (left->op_type == OP_SUBSTR
14943                          && (left->op_private & 7) < 4) {
14944                         op_null(o);
14945                         /* cut out right */
14946                         op_sibling_splice(o, NULL, 1, NULL);
14947                         /* and insert it as second child of OP_SUBSTR */
14948                         op_sibling_splice(left, cBINOPx(left)->op_first, 0,
14949                                     right);
14950                         left->op_private |= OPpSUBSTR_REPL_FIRST;
14951                         left->op_flags =
14952                             (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
14953                     }
14954                 }
14955             }
14956             break;
14957
14958         case OP_AASSIGN: {
14959             int l, r, lr, lscalars, rscalars;
14960
14961             /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
14962                Note that we do this now rather than in newASSIGNOP(),
14963                since only by now are aliased lexicals flagged as such
14964
14965                See the essay "Common vars in list assignment" above for
14966                the full details of the rationale behind all the conditions
14967                below.
14968
14969                PL_generation sorcery:
14970                To detect whether there are common vars, the global var
14971                PL_generation is incremented for each assign op we scan.
14972                Then we run through all the lexical variables on the LHS,
14973                of the assignment, setting a spare slot in each of them to
14974                PL_generation.  Then we scan the RHS, and if any lexicals
14975                already have that value, we know we've got commonality.
14976                Also, if the generation number is already set to
14977                PERL_INT_MAX, then the variable is involved in aliasing, so
14978                we also have potential commonality in that case.
14979              */
14980
14981             PL_generation++;
14982             /* scan LHS */
14983             lscalars = 0;
14984             l = S_aassign_scan(aTHX_ cLISTOPo->op_last,  FALSE, 1, &lscalars);
14985             /* scan RHS */
14986             rscalars = 0;
14987             r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, 1, &rscalars);
14988             lr = (l|r);
14989
14990
14991             /* After looking for things which are *always* safe, this main
14992              * if/else chain selects primarily based on the type of the
14993              * LHS, gradually working its way down from the more dangerous
14994              * to the more restrictive and thus safer cases */
14995
14996             if (   !l                      /* () = ....; */
14997                 || !r                      /* .... = (); */
14998                 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
14999                 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
15000                 || (lscalars < 2)          /* ($x, undef) = ... */
15001             ) {
15002                 NOOP; /* always safe */
15003             }
15004             else if (l & AAS_DANGEROUS) {
15005                 /* always dangerous */
15006                 o->op_private |= OPpASSIGN_COMMON_SCALAR;
15007                 o->op_private |= OPpASSIGN_COMMON_AGG;
15008             }
15009             else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
15010                 /* package vars are always dangerous - too many
15011                  * aliasing possibilities */
15012                 if (l & AAS_PKG_SCALAR)
15013                     o->op_private |= OPpASSIGN_COMMON_SCALAR;
15014                 if (l & AAS_PKG_AGG)
15015                     o->op_private |= OPpASSIGN_COMMON_AGG;
15016             }
15017             else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
15018                           |AAS_LEX_SCALAR|AAS_LEX_AGG))
15019             {
15020                 /* LHS contains only lexicals and safe ops */
15021
15022                 if (l & (AAS_MY_AGG|AAS_LEX_AGG))
15023                     o->op_private |= OPpASSIGN_COMMON_AGG;
15024
15025                 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
15026                     if (lr & AAS_LEX_SCALAR_COMM)
15027                         o->op_private |= OPpASSIGN_COMMON_SCALAR;
15028                     else if (   !(l & AAS_LEX_SCALAR)
15029                              && (r & AAS_DEFAV))
15030                     {
15031                         /* falsely mark
15032                          *    my (...) = @_
15033                          * as scalar-safe for performance reasons.
15034                          * (it will still have been marked _AGG if necessary */
15035                         NOOP;
15036                     }
15037                     else if (r  & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
15038                         /* if there are only lexicals on the LHS and no
15039                          * common ones on the RHS, then we assume that the
15040                          * only way those lexicals could also get
15041                          * on the RHS is via some sort of dereffing or
15042                          * closure, e.g.
15043                          *    $r = \$lex;
15044                          *    ($lex, $x) = (1, $$r)
15045                          * and in this case we assume the var must have
15046                          *  a bumped ref count. So if its ref count is 1,
15047                          *  it must only be on the LHS.
15048                          */
15049                         o->op_private |= OPpASSIGN_COMMON_RC1;
15050                 }
15051             }
15052
15053             /* ... = ($x)
15054              * may have to handle aggregate on LHS, but we can't
15055              * have common scalars. */
15056             if (rscalars < 2)
15057                 o->op_private &=
15058                         ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
15059
15060             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
15061                 S_check_for_bool_cxt(o, 1, OPpASSIGN_TRUEBOOL, 0);
15062             break;
15063         }
15064
15065         case OP_REF:
15066             /* see if ref() is used in boolean context */
15067             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
15068                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
15069             break;
15070
15071         case OP_LENGTH:
15072             /* see if the op is used in known boolean context,
15073              * but not if OA_TARGLEX optimisation is enabled */
15074             if (   (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
15075                 && !(o->op_private & OPpTARGET_MY)
15076             )
15077                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
15078             break;
15079
15080         case OP_POS:
15081             /* see if the op is used in known boolean context */
15082             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
15083                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
15084             break;
15085
15086         case OP_CUSTOM: {
15087             Perl_cpeep_t cpeep =
15088                 XopENTRYCUSTOM(o, xop_peep);
15089             if (cpeep)
15090                 cpeep(aTHX_ o, oldop);
15091             break;
15092         }
15093
15094         }
15095         /* did we just null the current op? If so, re-process it to handle
15096          * eliding "empty" ops from the chain */
15097         if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
15098             o->op_opt = 0;
15099             o = oldop;
15100         }
15101         else {
15102             oldoldop = oldop;
15103             oldop = o;
15104         }
15105     }
15106     LEAVE;
15107 }
15108
15109 void
15110 Perl_peep(pTHX_ OP *o)
15111 {
15112     CALL_RPEEP(o);
15113 }
15114
15115 /*
15116 =head1 Custom Operators
15117
15118 =for apidoc Ao||custom_op_xop
15119 Return the XOP structure for a given custom op.  This macro should be
15120 considered internal to C<OP_NAME> and the other access macros: use them instead.
15121 This macro does call a function.  Prior
15122 to 5.19.6, this was implemented as a
15123 function.
15124
15125 =cut
15126 */
15127
15128 XOPRETANY
15129 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
15130 {
15131     SV *keysv;
15132     HE *he = NULL;
15133     XOP *xop;
15134
15135     static const XOP xop_null = { 0, 0, 0, 0, 0 };
15136
15137     PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
15138     assert(o->op_type == OP_CUSTOM);
15139
15140     /* This is wrong. It assumes a function pointer can be cast to IV,
15141      * which isn't guaranteed, but this is what the old custom OP code
15142      * did. In principle it should be safer to Copy the bytes of the
15143      * pointer into a PV: since the new interface is hidden behind
15144      * functions, this can be changed later if necessary.  */
15145     /* Change custom_op_xop if this ever happens */
15146     keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
15147
15148     if (PL_custom_ops)
15149         he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
15150
15151     /* assume noone will have just registered a desc */
15152     if (!he && PL_custom_op_names &&
15153         (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
15154     ) {
15155         const char *pv;
15156         STRLEN l;
15157
15158         /* XXX does all this need to be shared mem? */
15159         Newxz(xop, 1, XOP);
15160         pv = SvPV(HeVAL(he), l);
15161         XopENTRY_set(xop, xop_name, savepvn(pv, l));
15162         if (PL_custom_op_descs &&
15163             (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
15164         ) {
15165             pv = SvPV(HeVAL(he), l);
15166             XopENTRY_set(xop, xop_desc, savepvn(pv, l));
15167         }
15168         Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
15169     }
15170     else {
15171         if (!he)
15172             xop = (XOP *)&xop_null;
15173         else
15174             xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
15175     }
15176     {
15177         XOPRETANY any;
15178         if(field == XOPe_xop_ptr) {
15179             any.xop_ptr = xop;
15180         } else {
15181             const U32 flags = XopFLAGS(xop);
15182             if(flags & field) {
15183                 switch(field) {
15184                 case XOPe_xop_name:
15185                     any.xop_name = xop->xop_name;
15186                     break;
15187                 case XOPe_xop_desc:
15188                     any.xop_desc = xop->xop_desc;
15189                     break;
15190                 case XOPe_xop_class:
15191                     any.xop_class = xop->xop_class;
15192                     break;
15193                 case XOPe_xop_peep:
15194                     any.xop_peep = xop->xop_peep;
15195                     break;
15196                 default:
15197                     NOT_REACHED; /* NOTREACHED */
15198                     break;
15199                 }
15200             } else {
15201                 switch(field) {
15202                 case XOPe_xop_name:
15203                     any.xop_name = XOPd_xop_name;
15204                     break;
15205                 case XOPe_xop_desc:
15206                     any.xop_desc = XOPd_xop_desc;
15207                     break;
15208                 case XOPe_xop_class:
15209                     any.xop_class = XOPd_xop_class;
15210                     break;
15211                 case XOPe_xop_peep:
15212                     any.xop_peep = XOPd_xop_peep;
15213                     break;
15214                 default:
15215                     NOT_REACHED; /* NOTREACHED */
15216                     break;
15217                 }
15218             }
15219         }
15220         /* On some platforms (HP-UX, IA64) gcc emits a warning for this function:
15221          * op.c: In function 'Perl_custom_op_get_field':
15222          * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
15223          * This is because on those platforms (with -DEBUGGING) NOT_REACHED
15224          * expands to assert(0), which expands to ((0) ? (void)0 :
15225          * __assert(...)), and gcc doesn't know that __assert can never return. */
15226         return any;
15227     }
15228 }
15229
15230 /*
15231 =for apidoc Ao||custom_op_register
15232 Register a custom op.  See L<perlguts/"Custom Operators">.
15233
15234 =cut
15235 */
15236
15237 void
15238 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
15239 {
15240     SV *keysv;
15241
15242     PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
15243
15244     /* see the comment in custom_op_xop */
15245     keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
15246
15247     if (!PL_custom_ops)
15248         PL_custom_ops = newHV();
15249
15250     if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
15251         Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
15252 }
15253
15254 /*
15255
15256 =for apidoc core_prototype
15257
15258 This function assigns the prototype of the named core function to C<sv>, or
15259 to a new mortal SV if C<sv> is C<NULL>.  It returns the modified C<sv>, or
15260 C<NULL> if the core function has no prototype.  C<code> is a code as returned
15261 by C<keyword()>.  It must not be equal to 0.
15262
15263 =cut
15264 */
15265
15266 SV *
15267 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
15268                           int * const opnum)
15269 {
15270     int i = 0, n = 0, seen_question = 0, defgv = 0;
15271     I32 oa;
15272 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
15273     char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
15274     bool nullret = FALSE;
15275
15276     PERL_ARGS_ASSERT_CORE_PROTOTYPE;
15277
15278     assert (code);
15279
15280     if (!sv) sv = sv_newmortal();
15281
15282 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
15283
15284     switch (code < 0 ? -code : code) {
15285     case KEY_and   : case KEY_chop: case KEY_chomp:
15286     case KEY_cmp   : case KEY_defined: case KEY_delete: case KEY_exec  :
15287     case KEY_exists: case KEY_eq     : case KEY_ge    : case KEY_goto  :
15288     case KEY_grep  : case KEY_gt     : case KEY_last  : case KEY_le    :
15289     case KEY_lt    : case KEY_map    : case KEY_ne    : case KEY_next  :
15290     case KEY_or    : case KEY_print  : case KEY_printf: case KEY_qr    :
15291     case KEY_redo  : case KEY_require: case KEY_return: case KEY_say   :
15292     case KEY_select: case KEY_sort   : case KEY_split : case KEY_system:
15293     case KEY_x     : case KEY_xor    :
15294         if (!opnum) return NULL; nullret = TRUE; goto findopnum;
15295     case KEY_glob:    retsetpvs("_;", OP_GLOB);
15296     case KEY_keys:    retsetpvs("\\[%@]", OP_KEYS);
15297     case KEY_values:  retsetpvs("\\[%@]", OP_VALUES);
15298     case KEY_each:    retsetpvs("\\[%@]", OP_EACH);
15299     case KEY_pos:     retsetpvs(";\\[$*]", OP_POS);
15300     case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
15301         retsetpvs("", 0);
15302     case KEY_evalbytes:
15303         name = "entereval"; break;
15304     case KEY_readpipe:
15305         name = "backtick";
15306     }
15307
15308 #undef retsetpvs
15309
15310   findopnum:
15311     while (i < MAXO) {  /* The slow way. */
15312         if (strEQ(name, PL_op_name[i])
15313             || strEQ(name, PL_op_desc[i]))
15314         {
15315             if (nullret) { assert(opnum); *opnum = i; return NULL; }
15316             goto found;
15317         }
15318         i++;
15319     }
15320     return NULL;
15321   found:
15322     defgv = PL_opargs[i] & OA_DEFGV;
15323     oa = PL_opargs[i] >> OASHIFT;
15324     while (oa) {
15325         if (oa & OA_OPTIONAL && !seen_question && (
15326               !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
15327         )) {
15328             seen_question = 1;
15329             str[n++] = ';';
15330         }
15331         if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
15332             && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
15333             /* But globs are already references (kinda) */
15334             && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
15335         ) {
15336             str[n++] = '\\';
15337         }
15338         if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
15339          && !scalar_mod_type(NULL, i)) {
15340             str[n++] = '[';
15341             str[n++] = '$';
15342             str[n++] = '@';
15343             str[n++] = '%';
15344             if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
15345             str[n++] = '*';
15346             str[n++] = ']';
15347         }
15348         else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
15349         if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
15350             str[n-1] = '_'; defgv = 0;
15351         }
15352         oa = oa >> 4;
15353     }
15354     if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
15355     str[n++] = '\0';
15356     sv_setpvn(sv, str, n - 1);
15357     if (opnum) *opnum = i;
15358     return sv;
15359 }
15360
15361 OP *
15362 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
15363                       const int opnum)
15364 {
15365     OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
15366     OP *o;
15367
15368     PERL_ARGS_ASSERT_CORESUB_OP;
15369
15370     switch(opnum) {
15371     case 0:
15372         return op_append_elem(OP_LINESEQ,
15373                        argop,
15374                        newSLICEOP(0,
15375                                   newSVOP(OP_CONST, 0, newSViv(-code % 3)),
15376                                   newOP(OP_CALLER,0)
15377                        )
15378                );
15379     case OP_EACH:
15380     case OP_KEYS:
15381     case OP_VALUES:
15382         o = newUNOP(OP_AVHVSWITCH,0,argop);
15383         o->op_private = opnum-OP_EACH;
15384         return o;
15385     case OP_SELECT: /* which represents OP_SSELECT as well */
15386         if (code)
15387             return newCONDOP(
15388                          0,
15389                          newBINOP(OP_GT, 0,
15390                                   newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
15391                                   newSVOP(OP_CONST, 0, newSVuv(1))
15392                                  ),
15393                          coresub_op(newSVuv((UV)OP_SSELECT), 0,
15394                                     OP_SSELECT),
15395                          coresub_op(coreargssv, 0, OP_SELECT)
15396                    );
15397         /* FALLTHROUGH */
15398     default:
15399         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
15400         case OA_BASEOP:
15401             return op_append_elem(
15402                         OP_LINESEQ, argop,
15403                         newOP(opnum,
15404                               opnum == OP_WANTARRAY || opnum == OP_RUNCV
15405                                 ? OPpOFFBYONE << 8 : 0)
15406                    );
15407         case OA_BASEOP_OR_UNOP:
15408             if (opnum == OP_ENTEREVAL) {
15409                 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
15410                 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
15411             }
15412             else o = newUNOP(opnum,0,argop);
15413             if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
15414             else {
15415           onearg:
15416               if (is_handle_constructor(o, 1))
15417                 argop->op_private |= OPpCOREARGS_DEREF1;
15418               if (scalar_mod_type(NULL, opnum))
15419                 argop->op_private |= OPpCOREARGS_SCALARMOD;
15420             }
15421             return o;
15422         default:
15423             o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
15424             if (is_handle_constructor(o, 2))
15425                 argop->op_private |= OPpCOREARGS_DEREF2;
15426             if (opnum == OP_SUBSTR) {
15427                 o->op_private |= OPpMAYBE_LVSUB;
15428                 return o;
15429             }
15430             else goto onearg;
15431         }
15432     }
15433 }
15434
15435 void
15436 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
15437                                SV * const *new_const_svp)
15438 {
15439     const char *hvname;
15440     bool is_const = !!CvCONST(old_cv);
15441     SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
15442
15443     PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
15444
15445     if (is_const && new_const_svp && old_const_sv == *new_const_svp)
15446         return;
15447         /* They are 2 constant subroutines generated from
15448            the same constant. This probably means that
15449            they are really the "same" proxy subroutine
15450            instantiated in 2 places. Most likely this is
15451            when a constant is exported twice.  Don't warn.
15452         */
15453     if (
15454         (ckWARN(WARN_REDEFINE)
15455          && !(
15456                 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
15457              && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
15458              && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
15459                  strEQ(hvname, "autouse"))
15460              )
15461         )
15462      || (is_const
15463          && ckWARN_d(WARN_REDEFINE)
15464          && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
15465         )
15466     )
15467         Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
15468                           is_const
15469                             ? "Constant subroutine %" SVf " redefined"
15470                             : "Subroutine %" SVf " redefined",
15471                           SVfARG(name));
15472 }
15473
15474 /*
15475 =head1 Hook manipulation
15476
15477 These functions provide convenient and thread-safe means of manipulating
15478 hook variables.
15479
15480 =cut
15481 */
15482
15483 /*
15484 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
15485
15486 Puts a C function into the chain of check functions for a specified op
15487 type.  This is the preferred way to manipulate the L</PL_check> array.
15488 C<opcode> specifies which type of op is to be affected.  C<new_checker>
15489 is a pointer to the C function that is to be added to that opcode's
15490 check chain, and C<old_checker_p> points to the storage location where a
15491 pointer to the next function in the chain will be stored.  The value of
15492 C<new_checker> is written into the L</PL_check> array, while the value
15493 previously stored there is written to C<*old_checker_p>.
15494
15495 L</PL_check> is global to an entire process, and a module wishing to
15496 hook op checking may find itself invoked more than once per process,
15497 typically in different threads.  To handle that situation, this function
15498 is idempotent.  The location C<*old_checker_p> must initially (once
15499 per process) contain a null pointer.  A C variable of static duration
15500 (declared at file scope, typically also marked C<static> to give
15501 it internal linkage) will be implicitly initialised appropriately,
15502 if it does not have an explicit initialiser.  This function will only
15503 actually modify the check chain if it finds C<*old_checker_p> to be null.
15504 This function is also thread safe on the small scale.  It uses appropriate
15505 locking to avoid race conditions in accessing L</PL_check>.
15506
15507 When this function is called, the function referenced by C<new_checker>
15508 must be ready to be called, except for C<*old_checker_p> being unfilled.
15509 In a threading situation, C<new_checker> may be called immediately,
15510 even before this function has returned.  C<*old_checker_p> will always
15511 be appropriately set before C<new_checker> is called.  If C<new_checker>
15512 decides not to do anything special with an op that it is given (which
15513 is the usual case for most uses of op check hooking), it must chain the
15514 check function referenced by C<*old_checker_p>.
15515
15516 Taken all together, XS code to hook an op checker should typically look
15517 something like this:
15518
15519     static Perl_check_t nxck_frob;
15520     static OP *myck_frob(pTHX_ OP *op) {
15521         ...
15522         op = nxck_frob(aTHX_ op);
15523         ...
15524         return op;
15525     }
15526     BOOT:
15527         wrap_op_checker(OP_FROB, myck_frob, &nxck_frob);
15528
15529 If you want to influence compilation of calls to a specific subroutine,
15530 then use L</cv_set_call_checker_flags> rather than hooking checking of
15531 all C<entersub> ops.
15532
15533 =cut
15534 */
15535
15536 void
15537 Perl_wrap_op_checker(pTHX_ Optype opcode,
15538     Perl_check_t new_checker, Perl_check_t *old_checker_p)
15539 {
15540     dVAR;
15541
15542     PERL_UNUSED_CONTEXT;
15543     PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
15544     if (*old_checker_p) return;
15545     OP_CHECK_MUTEX_LOCK;
15546     if (!*old_checker_p) {
15547         *old_checker_p = PL_check[opcode];
15548         PL_check[opcode] = new_checker;
15549     }
15550     OP_CHECK_MUTEX_UNLOCK;
15551 }
15552
15553 #include "XSUB.h"
15554
15555 /* Efficient sub that returns a constant scalar value. */
15556 static void
15557 const_sv_xsub(pTHX_ CV* cv)
15558 {
15559     dXSARGS;
15560     SV *const sv = MUTABLE_SV(XSANY.any_ptr);
15561     PERL_UNUSED_ARG(items);
15562     if (!sv) {
15563         XSRETURN(0);
15564     }
15565     EXTEND(sp, 1);
15566     ST(0) = sv;
15567     XSRETURN(1);
15568 }
15569
15570 static void
15571 const_av_xsub(pTHX_ CV* cv)
15572 {
15573     dXSARGS;
15574     AV * const av = MUTABLE_AV(XSANY.any_ptr);
15575     SP -= items;
15576     assert(av);
15577 #ifndef DEBUGGING
15578     if (!av) {
15579         XSRETURN(0);
15580     }
15581 #endif
15582     if (SvRMAGICAL(av))
15583         Perl_croak(aTHX_ "Magical list constants are not supported");
15584     if (GIMME_V != G_ARRAY) {
15585         EXTEND(SP, 1);
15586         ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
15587         XSRETURN(1);
15588     }
15589     EXTEND(SP, AvFILLp(av)+1);
15590     Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
15591     XSRETURN(AvFILLp(av)+1);
15592 }
15593
15594
15595 /*
15596  * ex: set ts=8 sts=4 sw=4 et:
15597  */