op.c

   1 #line 2 "op.c"
   2 /*    op.c
   3  *
   4  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
   5  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
   6  *
   7  *    You may distribute under the terms of either the GNU General Public
   8  *    License or the Artistic License, as specified in the README file.
   9  *
  10  */
  11
  12 /*
  13  * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck.  She was
  14  *  our Mr. Bilbo's first cousin on the mother's side (her mother being the
  15  *  youngest of the Old Took's daughters); and Mr. Drogo was his second
  16  *  cousin.  So Mr. Frodo is his first *and* second cousin, once removed
  17  *  either way, as the saying is, if you follow me.'       --the Gaffer
  18  *
  19  *     [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
  20  */
  21
  22 /* This file contains the functions that create, manipulate and optimize
  23  * the OP structures that hold a compiled perl program.
  24  *
  25  * A Perl program is compiled into a tree of OPs. Each op contains
  26  * structural pointers (eg to its siblings and the next op in the
  27  * execution sequence), a pointer to the function that would execute the
  28  * op, plus any data specific to that op. For example, an OP_CONST op
  29  * points to the pp_const() function and to an SV containing the constant
  30  * value. When pp_const() is executed, its job is to push that SV onto the
  31  * stack.
  32  *
  33  * OPs are mainly created by the newFOO() functions, which are mainly
  34  * called from the parser (in perly.y) as the code is parsed. For example
  35  * the Perl code $a + $b * $c would cause the equivalent of the following
  36  * to be called (oversimplifying a bit):
  37  *
  38  *  newBINOP(OP_ADD, flags,
  39  *      newSVREF($a),
  40  *      newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
  41  *  )
  42  *
  43  * Note that during the build of miniperl, a temporary copy of this file
  44  * is made, called opmini.c.
  45  */
  46
  47 /*
  48 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
  49
  50     A bottom-up pass
  51     A top-down pass
  52     An execution-order pass
  53
  54 The bottom-up pass is represented by all the "newOP" routines and
  55 the ck_ routines.  The bottom-upness is actually driven by yacc.
  56 So at the point that a ck_ routine fires, we have no idea what the
  57 context is, either upward in the syntax tree, or either forward or
  58 backward in the execution order.  (The bottom-up parser builds that
  59 part of the execution order it knows about, but if you follow the "next"
  60 links around, you'll find it's actually a closed loop through the
  61 top level node.)
  62
  63 Whenever the bottom-up parser gets to a node that supplies context to
  64 its components, it invokes that portion of the top-down pass that applies
  65 to that part of the subtree (and marks the top node as processed, so
  66 if a node further up supplies context, it doesn't have to take the
  67 plunge again).  As a particular subcase of this, as the new node is
  68 built, it takes all the closed execution loops of its subcomponents
  69 and links them into a new closed loop for the higher level node.  But
  70 it's still not the real execution order.
  71
  72 The actual execution order is not known till we get a grammar reduction
  73 to a top-level unit like a subroutine or file that will be called by
  74 "name" rather than via a "next" pointer.  At that point, we can call
  75 into peep() to do that code's portion of the 3rd pass.  It has to be
  76 recursive, but it's recursive on basic blocks, not on tree nodes.
  77 */
  78
  79 /* To implement user lexical pragmas, there needs to be a way at run time to
  80    get the compile time state of %^H for that block.  Storing %^H in every
  81    block (or even COP) would be very expensive, so a different approach is
  82    taken.  The (running) state of %^H is serialised into a tree of HE-like
  83    structs.  Stores into %^H are chained onto the current leaf as a struct
  84    refcounted_he * with the key and the value.  Deletes from %^H are saved
  85    with a value of PL_sv_placeholder.  The state of %^H at any point can be
  86    turned back into a regular HV by walking back up the tree from that point's
  87    leaf, ignoring any key you've already seen (placeholder or not), storing
  88    the rest into the HV structure, then removing the placeholders. Hence
  89    memory is only used to store the %^H deltas from the enclosing COP, rather
  90    than the entire %^H on each COP.
  91
  92    To cause actions on %^H to write out the serialisation records, it has
  93    magic type 'H'. This magic (itself) does nothing, but its presence causes
  94    the values to gain magic type 'h', which has entries for set and clear.
  95    C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
  96    record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
  97    saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
  98    it will be correctly restored when any inner compiling scope is exited.
  99 */
 100
 101 #include "EXTERN.h"
 102 #define PERL_IN_OP_C
 103 #include "perl.h"
 104 #include "keywords.h"
 105 #include "feature.h"
 106 #include "regcomp.h"
 107
 108 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
 109 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
 110 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
 111
 112 /* Used to avoid recursion through the op tree in scalarvoid() and
 113    op_free()
 114 */
 115
 116 #define DEFERRED_OP_STEP 100
 117 #define DEFER_OP(o) \
 118   STMT_START { \
 119     if (UNLIKELY(defer_ix == (defer_stack_alloc-1))) {    \
 120         defer_stack_alloc += DEFERRED_OP_STEP; \
 121         assert(defer_stack_alloc > 0); \
 122         Renew(defer_stack, defer_stack_alloc, OP *); \
 123     } \
 124     defer_stack[++defer_ix] = o; \
 125   } STMT_END
 126
 127 #define POP_DEFERRED_OP() (defer_ix >= 0 ? defer_stack[defer_ix--] : (OP *)NULL)
 128
 129 /* remove any leading "empty" ops from the op_next chain whose first
 130  * node's address is stored in op_p. Store the updated address of the
 131  * first node in op_p.
 132  */
 133
 134 STATIC void
 135 S_prune_chain_head(OP** op_p)
 136 {
 137     while (*op_p
 138         && (   (*op_p)->op_type == OP_NULL
 139             || (*op_p)->op_type == OP_SCOPE
 140             || (*op_p)->op_type == OP_SCALAR
 141             || (*op_p)->op_type == OP_LINESEQ)
 142     )
 143         *op_p = (*op_p)->op_next;
 144 }
 145
 146
 147 /* See the explanatory comments above struct opslab in op.h. */
 148
 149 #ifdef PERL_DEBUG_READONLY_OPS
 150 #  define PERL_SLAB_SIZE 128
 151 #  define PERL_MAX_SLAB_SIZE 4096
 152 #  include <sys/mman.h>
 153 #endif
 154
 155 #ifndef PERL_SLAB_SIZE
 156 #  define PERL_SLAB_SIZE 64
 157 #endif
 158 #ifndef PERL_MAX_SLAB_SIZE
 159 #  define PERL_MAX_SLAB_SIZE 2048
 160 #endif
 161
 162 /* rounds up to nearest pointer */
 163 #define SIZE_TO_PSIZE(x)        (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
 164 #define DIFF(o,p)               ((size_t)((I32 **)(p) - (I32**)(o)))
 165
 166 static OPSLAB *
 167 S_new_slab(pTHX_ size_t sz)
 168 {
 169 #ifdef PERL_DEBUG_READONLY_OPS
 170     OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
 171                                    PROT_READ|PROT_WRITE,
 172                                    MAP_ANON|MAP_PRIVATE, -1, 0);
 173     DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
 174                           (unsigned long) sz, slab));
 175     if (slab == MAP_FAILED) {
 176         perror("mmap failed");
 177         abort();
 178     }
 179     slab->opslab_size = (U16)sz;
 180 #else
 181     OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
 182 #endif
 183 #ifndef WIN32
 184     /* The context is unused in non-Windows */
 185     PERL_UNUSED_CONTEXT;
 186 #endif
 187     slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
 188     return slab;
 189 }
 190
 191 /* requires double parens and aTHX_ */
 192 #define DEBUG_S_warn(args)                                             \
 193     DEBUG_S(                                                            \
 194         PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
 195     )
 196
 197 void *
 198 Perl_Slab_Alloc(pTHX_ size_t sz)
 199 {
 200     OPSLAB *slab;
 201     OPSLAB *slab2;
 202     OPSLOT *slot;
 203     OP *o;
 204     size_t opsz, space;
 205
 206     /* We only allocate ops from the slab during subroutine compilation.
 207        We find the slab via PL_compcv, hence that must be non-NULL. It could
 208        also be pointing to a subroutine which is now fully set up (CvROOT()
 209        pointing to the top of the optree for that sub), or a subroutine
 210        which isn't using the slab allocator. If our sanity checks aren't met,
 211        don't use a slab, but allocate the OP directly from the heap.  */
 212     if (!PL_compcv || CvROOT(PL_compcv)
 213      || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
 214     {
 215         o = (OP*)PerlMemShared_calloc(1, sz);
 216         goto gotit;
 217     }
 218
 219     /* While the subroutine is under construction, the slabs are accessed via
 220        CvSTART(), to avoid needing to expand PVCV by one pointer for something
 221        unneeded at runtime. Once a subroutine is constructed, the slabs are
 222        accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
 223        allocated yet.  See the commit message for 8be227ab5eaa23f2 for more
 224        details.  */
 225     if (!CvSTART(PL_compcv)) {
 226         CvSTART(PL_compcv) =
 227             (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
 228         CvSLABBED_on(PL_compcv);
 229         slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
 230     }
 231     else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
 232
 233     opsz = SIZE_TO_PSIZE(sz);
 234     sz = opsz + OPSLOT_HEADER_P;
 235
 236     /* The slabs maintain a free list of OPs. In particular, constant folding
 237        will free up OPs, so it makes sense to re-use them where possible. A
 238        freed up slot is used in preference to a new allocation.  */
 239     if (slab->opslab_freed) {
 240         OP **too = &slab->opslab_freed;
 241         o = *too;
 242         DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", (void*)o, (void*)slab));
 243         while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
 244             DEBUG_S_warn((aTHX_ "Alas! too small"));
 245             o = *(too = &o->op_next);
 246             if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", (void*)o)); }
 247         }
 248         if (o) {
 249             *too = o->op_next;
 250             Zero(o, opsz, I32 *);
 251             o->op_slabbed = 1;
 252             goto gotit;
 253         }
 254     }
 255
 256 #define INIT_OPSLOT \
 257             slot->opslot_slab = slab;                   \
 258             slot->opslot_next = slab2->opslab_first;    \
 259             slab2->opslab_first = slot;                 \
 260             o = &slot->opslot_op;                       \
 261             o->op_slabbed = 1
 262
 263     /* The partially-filled slab is next in the chain. */
 264     slab2 = slab->opslab_next ? slab->opslab_next : slab;
 265     if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
 266         /* Remaining space is too small. */
 267
 268         /* If we can fit a BASEOP, add it to the free chain, so as not
 269            to waste it. */
 270         if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
 271             slot = &slab2->opslab_slots;
 272             INIT_OPSLOT;
 273             o->op_type = OP_FREED;
 274             o->op_next = slab->opslab_freed;
 275             slab->opslab_freed = o;
 276         }
 277
 278         /* Create a new slab.  Make this one twice as big. */
 279         slot = slab2->opslab_first;
 280         while (slot->opslot_next) slot = slot->opslot_next;
 281         slab2 = S_new_slab(aTHX_
 282                             (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
 283                                         ? PERL_MAX_SLAB_SIZE
 284                                         : (DIFF(slab2, slot)+1)*2);
 285         slab2->opslab_next = slab->opslab_next;
 286         slab->opslab_next = slab2;
 287     }
 288     assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
 289
 290     /* Create a new op slot */
 291     slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
 292     assert(slot >= &slab2->opslab_slots);
 293     if (DIFF(&slab2->opslab_slots, slot)
 294          < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
 295         slot = &slab2->opslab_slots;
 296     INIT_OPSLOT;
 297     DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab));
 298
 299   gotit:
 300     /* lastsib == 1, op_sibling == 0 implies a solitary unattached op */
 301     o->op_lastsib = 1;
 302     assert(!o->op_sibling);
 303
 304     return (void *)o;
 305 }
 306
 307 #undef INIT_OPSLOT
 308
 309 #ifdef PERL_DEBUG_READONLY_OPS
 310 void
 311 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
 312 {
 313     PERL_ARGS_ASSERT_SLAB_TO_RO;
 314
 315     if (slab->opslab_readonly) return;
 316     slab->opslab_readonly = 1;
 317     for (; slab; slab = slab->opslab_next) {
 318         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
 319                               (unsigned long) slab->opslab_size, slab));*/
 320         if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
 321             Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
 322                              (unsigned long)slab->opslab_size, errno);
 323     }
 324 }
 325
 326 void
 327 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
 328 {
 329     OPSLAB *slab2;
 330
 331     PERL_ARGS_ASSERT_SLAB_TO_RW;
 332
 333     if (!slab->opslab_readonly) return;
 334     slab2 = slab;
 335     for (; slab2; slab2 = slab2->opslab_next) {
 336         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
 337                               (unsigned long) size, slab2));*/
 338         if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
 339                      PROT_READ|PROT_WRITE)) {
 340             Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
 341                              (unsigned long)slab2->opslab_size, errno);
 342         }
 343     }
 344     slab->opslab_readonly = 0;
 345 }
 346
 347 #else
 348 #  define Slab_to_rw(op)    NOOP
 349 #endif
 350
 351 /* This cannot possibly be right, but it was copied from the old slab
 352    allocator, to which it was originally added, without explanation, in
 353    commit 083fcd5. */
 354 #ifdef NETWARE
 355 #    define PerlMemShared PerlMem
 356 #endif
 357
 358 void
 359 Perl_Slab_Free(pTHX_ void *op)
 360 {
 361     OP * const o = (OP *)op;
 362     OPSLAB *slab;
 363
 364     PERL_ARGS_ASSERT_SLAB_FREE;
 365
 366     if (!o->op_slabbed) {
 367         if (!o->op_static)
 368             PerlMemShared_free(op);
 369         return;
 370     }
 371
 372     slab = OpSLAB(o);
 373     /* If this op is already freed, our refcount will get screwy. */
 374     assert(o->op_type != OP_FREED);
 375     o->op_type = OP_FREED;
 376     o->op_next = slab->opslab_freed;
 377     slab->opslab_freed = o;
 378     DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", (void*)o, (void*)slab));
 379     OpslabREFCNT_dec_padok(slab);
 380 }
 381
 382 void
 383 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
 384 {
 385     const bool havepad = !!PL_comppad;
 386     PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
 387     if (havepad) {
 388         ENTER;
 389         PAD_SAVE_SETNULLPAD();
 390     }
 391     opslab_free(slab);
 392     if (havepad) LEAVE;
 393 }
 394
 395 void
 396 Perl_opslab_free(pTHX_ OPSLAB *slab)
 397 {
 398     OPSLAB *slab2;
 399     PERL_ARGS_ASSERT_OPSLAB_FREE;
 400     PERL_UNUSED_CONTEXT;
 401     DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
 402     assert(slab->opslab_refcnt == 1);
 403     for (; slab; slab = slab2) {
 404         slab2 = slab->opslab_next;
 405 #ifdef DEBUGGING
 406         slab->opslab_refcnt = ~(size_t)0;
 407 #endif
 408 #ifdef PERL_DEBUG_READONLY_OPS
 409         DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
 410                                                (void*)slab));
 411         if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
 412             perror("munmap failed");
 413             abort();
 414         }
 415 #else
 416         PerlMemShared_free(slab);
 417 #endif
 418     }
 419 }
 420
 421 void
 422 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
 423 {
 424     OPSLAB *slab2;
 425     OPSLOT *slot;
 426 #ifdef DEBUGGING
 427     size_t savestack_count = 0;
 428 #endif
 429     PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
 430     slab2 = slab;
 431     do {
 432         for (slot = slab2->opslab_first;
 433              slot->opslot_next;
 434              slot = slot->opslot_next) {
 435             if (slot->opslot_op.op_type != OP_FREED
 436              && !(slot->opslot_op.op_savefree
 437 #ifdef DEBUGGING
 438                   && ++savestack_count
 439 #endif
 440                  )
 441             ) {
 442                 assert(slot->opslot_op.op_slabbed);
 443                 op_free(&slot->opslot_op);
 444                 if (slab->opslab_refcnt == 1) goto free;
 445             }
 446         }
 447     } while ((slab2 = slab2->opslab_next));
 448     /* > 1 because the CV still holds a reference count. */
 449     if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
 450 #ifdef DEBUGGING
 451         assert(savestack_count == slab->opslab_refcnt-1);
 452 #endif
 453         /* Remove the CV’s reference count. */
 454         slab->opslab_refcnt--;
 455         return;
 456     }
 457    free:
 458     opslab_free(slab);
 459 }
 460
 461 #ifdef PERL_DEBUG_READONLY_OPS
 462 OP *
 463 Perl_op_refcnt_inc(pTHX_ OP *o)
 464 {
 465     if(o) {
 466         OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
 467         if (slab && slab->opslab_readonly) {
 468             Slab_to_rw(slab);
 469             ++o->op_targ;
 470             Slab_to_ro(slab);
 471         } else {
 472             ++o->op_targ;
 473         }
 474     }
 475     return o;
 476
 477 }
 478
 479 PADOFFSET
 480 Perl_op_refcnt_dec(pTHX_ OP *o)
 481 {
 482     PADOFFSET result;
 483     OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
 484
 485     PERL_ARGS_ASSERT_OP_REFCNT_DEC;
 486
 487     if (slab && slab->opslab_readonly) {
 488         Slab_to_rw(slab);
 489         result = --o->op_targ;
 490         Slab_to_ro(slab);
 491     } else {
 492         result = --o->op_targ;
 493     }
 494     return result;
 495 }
 496 #endif
 497 /*
 498  * In the following definition, the ", (OP*)0" is just to make the compiler
 499  * think the expression is of the right type: croak actually does a Siglongjmp.
 500  */
 501 #define CHECKOP(type,o) \
 502     ((PL_op_mask && PL_op_mask[type])                           \
 503      ? ( op_free((OP*)o),                                       \
 504          Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]),  \
 505          (OP*)0 )                                               \
 506      : PL_check[type](aTHX_ (OP*)o))
 507
 508 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
 509
 510 #define CHANGE_TYPE(o,type) \
 511     STMT_START {                                \
 512         o->op_type = (OPCODE)type;              \
 513         o->op_ppaddr = PL_ppaddr[type];         \
 514     } STMT_END
 515
 516 STATIC OP *
 517 S_no_fh_allowed(pTHX_ OP *o)
 518 {
 519     PERL_ARGS_ASSERT_NO_FH_ALLOWED;
 520
 521     yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
 522                  OP_DESC(o)));
 523     return o;
 524 }
 525
 526 STATIC OP *
 527 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
 528 {
 529     PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
 530     yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
 531     return o;
 532 }
 533
 534 STATIC OP *
 535 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
 536 {
 537     PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
 538
 539     yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
 540     return o;
 541 }
 542
 543 STATIC void
 544 S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid)
 545 {
 546     PERL_ARGS_ASSERT_BAD_TYPE_PV;
 547
 548     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
 549                  (int)n, name, t, OP_DESC(kid)), flags);
 550 }
 551
 552 STATIC void
 553 S_bad_type_gv(pTHX_ I32 n, const char *t, GV *gv, U32 flags, const OP *kid)
 554 {
 555     SV * const namesv = cv_name((CV *)gv, NULL, 0);
 556     PERL_ARGS_ASSERT_BAD_TYPE_GV;
 557
 558     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
 559                  (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv) | flags);
 560 }
 561
 562 STATIC void
 563 S_no_bareword_allowed(pTHX_ OP *o)
 564 {
 565     PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
 566
 567     qerror(Perl_mess(aTHX_
 568                      "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
 569                      SVfARG(cSVOPo_sv)));
 570     o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
 571 }
 572
 573 /* "register" allocation */
 574
 575 PADOFFSET
 576 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
 577 {
 578     PADOFFSET off;
 579     const bool is_our = (PL_parser->in_my == KEY_our);
 580
 581     PERL_ARGS_ASSERT_ALLOCMY;
 582
 583     if (flags & ~SVf_UTF8)
 584         Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
 585                    (UV)flags);
 586
 587     /* complain about "my $<special_var>" etc etc */
 588     if (len &&
 589         !(is_our ||
 590           isALPHA(name[1]) ||
 591           ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
 592           (name[1] == '_' && (*name == '$' || len > 2))))
 593     {
 594         if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
 595          && isASCII(name[1])
 596          && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
 597             yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
 598                               name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
 599                               PL_parser->in_my == KEY_state ? "state" : "my"));
 600         } else {
 601             yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
 602                               PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
 603         }
 604     }
 605     else if (len == 2 && name[1] == '_' && !is_our)
 606         /* diag_listed_as: Use of my $_ is experimental */
 607         Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__LEXICAL_TOPIC),
 608                               "Use of %s $_ is experimental",
 609                                PL_parser->in_my == KEY_state
 610                                  ? "state"
 611                                  : "my");
 612
 613     /* allocate a spare slot and store the name in that slot */
 614
 615     off = pad_add_name_pvn(name, len,
 616                        (is_our ? padadd_OUR :
 617                         PL_parser->in_my == KEY_state ? padadd_STATE : 0),
 618                     PL_parser->in_my_stash,
 619                     (is_our
 620                         /* $_ is always in main::, even with our */
 621                         ? (PL_curstash && !memEQs(name,len,"$_")
 622                             ? PL_curstash
 623                             : PL_defstash)
 624                         : NULL
 625                     )
 626     );
 627     /* anon sub prototypes contains state vars should always be cloned,
 628      * otherwise the state var would be shared between anon subs */
 629
 630     if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
 631         CvCLONE_on(PL_compcv);
 632
 633     return off;
 634 }
 635
 636 /*
 637 =head1 Optree Manipulation Functions
 638
 639 =for apidoc alloccopstash
 640
 641 Available only under threaded builds, this function allocates an entry in
 642 C<PL_stashpad> for the stash passed to it.
 643
 644 =cut
 645 */
 646
 647 #ifdef USE_ITHREADS
 648 PADOFFSET
 649 Perl_alloccopstash(pTHX_ HV *hv)
 650 {
 651     PADOFFSET off = 0, o = 1;
 652     bool found_slot = FALSE;
 653
 654     PERL_ARGS_ASSERT_ALLOCCOPSTASH;
 655
 656     if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
 657
 658     for (; o < PL_stashpadmax; ++o) {
 659         if (PL_stashpad[o] == hv) return PL_stashpadix = o;
 660         if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
 661             found_slot = TRUE, off = o;
 662     }
 663     if (!found_slot) {
 664         Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
 665         Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
 666         off = PL_stashpadmax;
 667         PL_stashpadmax += 10;
 668     }
 669
 670     PL_stashpad[PL_stashpadix = off] = hv;
 671     return off;
 672 }
 673 #endif
 674
 675 /* free the body of an op without examining its contents.
 676  * Always use this rather than FreeOp directly */
 677
 678 static void
 679 S_op_destroy(pTHX_ OP *o)
 680 {
 681     FreeOp(o);
 682 }
 683
 684 /* Destructor */
 685
 686 /*
 687 =for apidoc Am|void|op_free|OP *o
 688
 689 Free an op.  Only use this when an op is no longer linked to from any
 690 optree.
 691
 692 =cut
 693 */
 694
 695 void
 696 Perl_op_free(pTHX_ OP *o)
 697 {
 698     dVAR;
 699     OPCODE type;
 700     SSize_t defer_ix = -1;
 701     SSize_t defer_stack_alloc = 0;
 702     OP **defer_stack = NULL;
 703
 704     do {
 705
 706         /* Though ops may be freed twice, freeing the op after its slab is a
 707            big no-no. */
 708         assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
 709         /* During the forced freeing of ops after compilation failure, kidops
 710            may be freed before their parents. */
 711         if (!o || o->op_type == OP_FREED)
 712             continue;
 713
 714         type = o->op_type;
 715
 716         /* an op should only ever acquire op_private flags that we know about.
 717          * If this fails, you may need to fix something in regen/op_private */
 718         if (o->op_ppaddr == PL_ppaddr[o->op_type]) {
 719             assert(!(o->op_private & ~PL_op_private_valid[type]));
 720         }
 721
 722         if (o->op_private & OPpREFCOUNTED) {
 723             switch (type) {
 724             case OP_LEAVESUB:
 725             case OP_LEAVESUBLV:
 726             case OP_LEAVEEVAL:
 727             case OP_LEAVE:
 728             case OP_SCOPE:
 729             case OP_LEAVEWRITE:
 730                 {
 731                 PADOFFSET refcnt;
 732                 OP_REFCNT_LOCK;
 733                 refcnt = OpREFCNT_dec(o);
 734                 OP_REFCNT_UNLOCK;
 735                 if (refcnt) {
 736                     /* Need to find and remove any pattern match ops from the list
 737                        we maintain for reset().  */
 738                     find_and_forget_pmops(o);
 739                     continue;
 740                 }
 741                 }
 742                 break;
 743             default:
 744                 break;
 745             }
 746         }
 747
 748         /* Call the op_free hook if it has been set. Do it now so that it's called
 749          * at the right time for refcounted ops, but still before all of the kids
 750          * are freed. */
 751         CALL_OPFREEHOOK(o);
 752
 753         if (o->op_flags & OPf_KIDS) {
 754             OP *kid, *nextkid;
 755             for (kid = cUNOPo->op_first; kid; kid = nextkid) {
 756                 nextkid = OpSIBLING(kid); /* Get before next freeing kid */
 757                 if (!kid || kid->op_type == OP_FREED)
 758                     /* During the forced freeing of ops after
 759                        compilation failure, kidops may be freed before
 760                        their parents. */
 761                     continue;
 762                 if (!(kid->op_flags & OPf_KIDS))
 763                     /* If it has no kids, just free it now */
 764                     op_free(kid);
 765                 else
 766                     DEFER_OP(kid);
 767             }
 768         }
 769         if (type == OP_NULL)
 770             type = (OPCODE)o->op_targ;
 771
 772         if (o->op_slabbed)
 773             Slab_to_rw(OpSLAB(o));
 774
 775         /* COP* is not cleared by op_clear() so that we may track line
 776          * numbers etc even after null() */
 777         if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
 778             cop_free((COP*)o);
 779         }
 780
 781         op_clear(o);
 782         FreeOp(o);
 783 #ifdef DEBUG_LEAKING_SCALARS
 784         if (PL_op == o)
 785             PL_op = NULL;
 786 #endif
 787     } while ( (o = POP_DEFERRED_OP()) );
 788
 789     Safefree(defer_stack);
 790 }
 791
 792 /* S_op_clear_gv(): free a GV attached to an OP */
 793
 794 #ifdef USE_ITHREADS
 795 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
 796 #else
 797 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
 798 #endif
 799 {
 800
 801     GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
 802             || o->op_type == OP_MULTIDEREF)
 803 #ifdef USE_ITHREADS
 804                 && PL_curpad
 805                 ? ((GV*)PAD_SVl(*ixp)) : NULL;
 806 #else
 807                 ? (GV*)(*svp) : NULL;
 808 #endif
 809     /* It's possible during global destruction that the GV is freed
 810        before the optree. Whilst the SvREFCNT_inc is happy to bump from
 811        0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
 812        will trigger an assertion failure, because the entry to sv_clear
 813        checks that the scalar is not already freed.  A check of for
 814        !SvIS_FREED(gv) turns out to be invalid, because during global
 815        destruction the reference count can be forced down to zero
 816        (with SVf_BREAK set).  In which case raising to 1 and then
 817        dropping to 0 triggers cleanup before it should happen.  I
 818        *think* that this might actually be a general, systematic,
 819        weakness of the whole idea of SVf_BREAK, in that code *is*
 820        allowed to raise and lower references during global destruction,
 821        so any *valid* code that happens to do this during global
 822        destruction might well trigger premature cleanup.  */
 823     bool still_valid = gv && SvREFCNT(gv);
 824
 825     if (still_valid)
 826         SvREFCNT_inc_simple_void(gv);
 827 #ifdef USE_ITHREADS
 828     if (*ixp > 0) {
 829         pad_swipe(*ixp, TRUE);
 830         *ixp = 0;
 831     }
 832 #else
 833     SvREFCNT_dec(*svp);
 834     *svp = NULL;
 835 #endif
 836     if (still_valid) {
 837         int try_downgrade = SvREFCNT(gv) == 2;
 838         SvREFCNT_dec_NN(gv);
 839         if (try_downgrade)
 840             gv_try_downgrade(gv);
 841     }
 842 }
 843
 844
 845 void
 846 Perl_op_clear(pTHX_ OP *o)
 847 {
 848
 849     dVAR;
 850
 851     PERL_ARGS_ASSERT_OP_CLEAR;
 852
 853     switch (o->op_type) {
 854     case OP_NULL:       /* Was holding old type, if any. */
 855         /* FALLTHROUGH */
 856     case OP_ENTERTRY:
 857     case OP_ENTEREVAL:  /* Was holding hints. */
 858         o->op_targ = 0;
 859         break;
 860     default:
 861         if (!(o->op_flags & OPf_REF)
 862             || (PL_check[o->op_type] != Perl_ck_ftst))
 863             break;
 864         /* FALLTHROUGH */
 865     case OP_GVSV:
 866     case OP_GV:
 867     case OP_AELEMFAST:
 868 #ifdef USE_ITHREADS
 869             S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
 870 #else
 871             S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
 872 #endif
 873         break;
 874     case OP_METHOD_REDIR:
 875     case OP_METHOD_REDIR_SUPER:
 876 #ifdef USE_ITHREADS
 877         if (cMETHOPx(o)->op_rclass_targ) {
 878             pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
 879             cMETHOPx(o)->op_rclass_targ = 0;
 880         }
 881 #else
 882         SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
 883         cMETHOPx(o)->op_rclass_sv = NULL;
 884 #endif
 885     case OP_METHOD_NAMED:
 886     case OP_METHOD_SUPER:
 887         SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
 888         cMETHOPx(o)->op_u.op_meth_sv = NULL;
 889 #ifdef USE_ITHREADS
 890         if (o->op_targ) {
 891             pad_swipe(o->op_targ, 1);
 892             o->op_targ = 0;
 893         }
 894 #endif
 895         break;
 896     case OP_CONST:
 897     case OP_HINTSEVAL:
 898         SvREFCNT_dec(cSVOPo->op_sv);
 899         cSVOPo->op_sv = NULL;
 900 #ifdef USE_ITHREADS
 901         /** Bug #15654
 902           Even if op_clear does a pad_free for the target of the op,
 903           pad_free doesn't actually remove the sv that exists in the pad;
 904           instead it lives on. This results in that it could be reused as
 905           a target later on when the pad was reallocated.
 906         **/
 907         if(o->op_targ) {
 908           pad_swipe(o->op_targ,1);
 909           o->op_targ = 0;
 910         }
 911 #endif
 912         break;
 913     case OP_DUMP:
 914     case OP_GOTO:
 915     case OP_NEXT:
 916     case OP_LAST:
 917     case OP_REDO:
 918         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
 919             break;
 920         /* FALLTHROUGH */
 921     case OP_TRANS:
 922     case OP_TRANSR:
 923         if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
 924             assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
 925 #ifdef USE_ITHREADS
 926             if (cPADOPo->op_padix > 0) {
 927                 pad_swipe(cPADOPo->op_padix, TRUE);
 928                 cPADOPo->op_padix = 0;
 929             }
 930 #else
 931             SvREFCNT_dec(cSVOPo->op_sv);
 932             cSVOPo->op_sv = NULL;
 933 #endif
 934         }
 935         else {
 936             PerlMemShared_free(cPVOPo->op_pv);
 937             cPVOPo->op_pv = NULL;
 938         }
 939         break;
 940     case OP_SUBST:
 941         op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
 942         goto clear_pmop;
 943     case OP_PUSHRE:
 944 #ifdef USE_ITHREADS
 945         if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
 946             pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
 947         }
 948 #else
 949         SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
 950 #endif
 951         /* FALLTHROUGH */
 952     case OP_MATCH:
 953     case OP_QR:
 954 clear_pmop:
 955         if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
 956             op_free(cPMOPo->op_code_list);
 957         cPMOPo->op_code_list = NULL;
 958         forget_pmop(cPMOPo);
 959         cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
 960         /* we use the same protection as the "SAFE" version of the PM_ macros
 961          * here since sv_clean_all might release some PMOPs
 962          * after PL_regex_padav has been cleared
 963          * and the clearing of PL_regex_padav needs to
 964          * happen before sv_clean_all
 965          */
 966 #ifdef USE_ITHREADS
 967         if(PL_regex_pad) {        /* We could be in destruction */
 968             const IV offset = (cPMOPo)->op_pmoffset;
 969             ReREFCNT_dec(PM_GETRE(cPMOPo));
 970             PL_regex_pad[offset] = &PL_sv_undef;
 971             sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
 972                            sizeof(offset));
 973         }
 974 #else
 975         ReREFCNT_dec(PM_GETRE(cPMOPo));
 976         PM_SETRE(cPMOPo, NULL);
 977 #endif
 978
 979         break;
 980
 981     case OP_MULTIDEREF:
 982         {
 983             UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
 984             UV actions = items->uv;
 985             bool last = 0;
 986             bool is_hash = FALSE;
 987
 988             while (!last) {
 989                 switch (actions & MDEREF_ACTION_MASK) {
 990
 991                 case MDEREF_reload:
 992                     actions = (++items)->uv;
 993                     continue;
 994
 995                 case MDEREF_HV_padhv_helem:
 996                     is_hash = TRUE;
 997                 case MDEREF_AV_padav_aelem:
 998                     pad_free((++items)->pad_offset);
 999                     goto do_elem;
1000
1001                 case MDEREF_HV_gvhv_helem:
1002                     is_hash = TRUE;
1003                 case MDEREF_AV_gvav_aelem:
1004 #ifdef USE_ITHREADS
1005                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1006 #else
1007                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1008 #endif
1009                     goto do_elem;
1010
1011                 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1012                     is_hash = TRUE;
1013                 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1014 #ifdef USE_ITHREADS
1015                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1016 #else
1017                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1018 #endif
1019                     goto do_vivify_rv2xv_elem;
1020
1021                 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1022                     is_hash = TRUE;
1023                 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1024                     pad_free((++items)->pad_offset);
1025                     goto do_vivify_rv2xv_elem;
1026
1027                 case MDEREF_HV_pop_rv2hv_helem:
1028                 case MDEREF_HV_vivify_rv2hv_helem:
1029                     is_hash = TRUE;
1030                 do_vivify_rv2xv_elem:
1031                 case MDEREF_AV_pop_rv2av_aelem:
1032                 case MDEREF_AV_vivify_rv2av_aelem:
1033                 do_elem:
1034                     switch (actions & MDEREF_INDEX_MASK) {
1035                     case MDEREF_INDEX_none:
1036                         last = 1;
1037                         break;
1038                     case MDEREF_INDEX_const:
1039                         if (is_hash) {
1040 #ifdef USE_ITHREADS
1041                             /* see RT #15654 */
1042                             pad_swipe((++items)->pad_offset, 1);
1043 #else
1044                             SvREFCNT_dec((++items)->sv);
1045 #endif
1046                         }
1047                         else
1048                             items++;
1049                         break;
1050                     case MDEREF_INDEX_padsv:
1051                         pad_free((++items)->pad_offset);
1052                         break;
1053                     case MDEREF_INDEX_gvsv:
1054 #ifdef USE_ITHREADS
1055                         S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1056 #else
1057                         S_op_clear_gv(aTHX_ o, &((++items)->sv));
1058 #endif
1059                         break;
1060                     }
1061
1062                     if (actions & MDEREF_FLAG_last)
1063                         last = 1;
1064                     is_hash = FALSE;
1065
1066                     break;
1067
1068                 default:
1069                     assert(0);
1070                     last = 1;
1071                     break;
1072
1073                 } /* switch */
1074
1075                 actions >>= MDEREF_SHIFT;
1076             } /* while */
1077
1078             /* start of malloc is at op_aux[-1], where the length is
1079              * stored */
1080             PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1081         }
1082         break;
1083     }
1084
1085     if (o->op_targ > 0) {
1086         pad_free(o->op_targ);
1087         o->op_targ = 0;
1088     }
1089 }
1090
1091 STATIC void
1092 S_cop_free(pTHX_ COP* cop)
1093 {
1094     PERL_ARGS_ASSERT_COP_FREE;
1095
1096     CopFILE_free(cop);
1097     if (! specialWARN(cop->cop_warnings))
1098         PerlMemShared_free(cop->cop_warnings);
1099     cophh_free(CopHINTHASH_get(cop));
1100     if (PL_curcop == cop)
1101        PL_curcop = NULL;
1102 }
1103
1104 STATIC void
1105 S_forget_pmop(pTHX_ PMOP *const o
1106               )
1107 {
1108     HV * const pmstash = PmopSTASH(o);
1109
1110     PERL_ARGS_ASSERT_FORGET_PMOP;
1111
1112     if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1113         MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1114         if (mg) {
1115             PMOP **const array = (PMOP**) mg->mg_ptr;
1116             U32 count = mg->mg_len / sizeof(PMOP**);
1117             U32 i = count;
1118
1119             while (i--) {
1120                 if (array[i] == o) {
1121                     /* Found it. Move the entry at the end to overwrite it.  */
1122                     array[i] = array[--count];
1123                     mg->mg_len = count * sizeof(PMOP**);
1124                     /* Could realloc smaller at this point always, but probably
1125                        not worth it. Probably worth free()ing if we're the
1126                        last.  */
1127                     if(!count) {
1128                         Safefree(mg->mg_ptr);
1129                         mg->mg_ptr = NULL;
1130                     }
1131                     break;
1132                 }
1133             }
1134         }
1135     }
1136     if (PL_curpm == o)
1137         PL_curpm = NULL;
1138 }
1139
1140 STATIC void
1141 S_find_and_forget_pmops(pTHX_ OP *o)
1142 {
1143     PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1144
1145     if (o->op_flags & OPf_KIDS) {
1146         OP *kid = cUNOPo->op_first;
1147         while (kid) {
1148             switch (kid->op_type) {
1149             case OP_SUBST:
1150             case OP_PUSHRE:
1151             case OP_MATCH:
1152             case OP_QR:
1153                 forget_pmop((PMOP*)kid);
1154             }
1155             find_and_forget_pmops(kid);
1156             kid = OpSIBLING(kid);
1157         }
1158     }
1159 }
1160
1161 /*
1162 =for apidoc Am|void|op_null|OP *o
1163
1164 Neutralizes an op when it is no longer needed, but is still linked to from
1165 other ops.
1166
1167 =cut
1168 */
1169
1170 void
1171 Perl_op_null(pTHX_ OP *o)
1172 {
1173     dVAR;
1174
1175     PERL_ARGS_ASSERT_OP_NULL;
1176
1177     if (o->op_type == OP_NULL)
1178         return;
1179     op_clear(o);
1180     o->op_targ = o->op_type;
1181     CHANGE_TYPE(o, OP_NULL);
1182 }
1183
1184 void
1185 Perl_op_refcnt_lock(pTHX)
1186 {
1187 #ifdef USE_ITHREADS
1188     dVAR;
1189 #endif
1190     PERL_UNUSED_CONTEXT;
1191     OP_REFCNT_LOCK;
1192 }
1193
1194 void
1195 Perl_op_refcnt_unlock(pTHX)
1196 {
1197 #ifdef USE_ITHREADS
1198     dVAR;
1199 #endif
1200     PERL_UNUSED_CONTEXT;
1201     OP_REFCNT_UNLOCK;
1202 }
1203
1204
1205 /*
1206 =for apidoc op_sibling_splice
1207
1208 A general function for editing the structure of an existing chain of
1209 op_sibling nodes.  By analogy with the perl-level splice() function, allows
1210 you to delete zero or more sequential nodes, replacing them with zero or
1211 more different nodes.  Performs the necessary op_first/op_last
1212 housekeeping on the parent node and op_sibling manipulation on the
1213 children.  The last deleted node will be marked as as the last node by
1214 updating the op_sibling or op_lastsib field as appropriate.
1215
1216 Note that op_next is not manipulated, and nodes are not freed; that is the
1217 responsibility of the caller.  It also won't create a new list op for an
1218 empty list etc; use higher-level functions like op_append_elem() for that.
1219
1220 parent is the parent node of the sibling chain.
1221
1222 start is the node preceding the first node to be spliced.  Node(s)
1223 following it will be deleted, and ops will be inserted after it.  If it is
1224 NULL, the first node onwards is deleted, and nodes are inserted at the
1225 beginning.
1226
1227 del_count is the number of nodes to delete.  If zero, no nodes are deleted.
1228 If -1 or greater than or equal to the number of remaining kids, all
1229 remaining kids are deleted.
1230
1231 insert is the first of a chain of nodes to be inserted in place of the nodes.
1232 If NULL, no nodes are inserted.
1233
1234 The head of the chain of deleted ops is returned, or NULL if no ops were
1235 deleted.
1236
1237 For example:
1238
1239     action                    before      after         returns
1240     ------                    -----       -----         -------
1241
1242                               P           P
1243     splice(P, A, 2, X-Y-Z)    |           |             B-C
1244                               A-B-C-D     A-X-Y-Z-D
1245
1246                               P           P
1247     splice(P, NULL, 1, X-Y)   |           |             A
1248                               A-B-C-D     X-Y-B-C-D
1249
1250                               P           P
1251     splice(P, NULL, 3, NULL)  |           |             A-B-C
1252                               A-B-C-D     D
1253
1254                               P           P
1255     splice(P, B, 0, X-Y)      |           |             NULL
1256                               A-B-C-D     A-B-X-Y-C-D
1257
1258 =cut
1259 */
1260
1261 OP *
1262 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1263 {
1264     OP *first = start ? OpSIBLING(start) : cLISTOPx(parent)->op_first;
1265     OP *rest;
1266     OP *last_del = NULL;
1267     OP *last_ins = NULL;
1268
1269     PERL_ARGS_ASSERT_OP_SIBLING_SPLICE;
1270
1271     assert(del_count >= -1);
1272
1273     if (del_count && first) {
1274         last_del = first;
1275         while (--del_count && OpHAS_SIBLING(last_del))
1276             last_del = OpSIBLING(last_del);
1277         rest = OpSIBLING(last_del);
1278         OpSIBLING_set(last_del, NULL);
1279         last_del->op_lastsib = 1;
1280     }
1281     else
1282         rest = first;
1283
1284     if (insert) {
1285         last_ins = insert;
1286         while (OpHAS_SIBLING(last_ins))
1287             last_ins = OpSIBLING(last_ins);
1288         OpSIBLING_set(last_ins, rest);
1289         last_ins->op_lastsib = rest ? 0 : 1;
1290     }
1291     else
1292         insert = rest;
1293
1294     if (start) {
1295         OpSIBLING_set(start, insert);
1296         start->op_lastsib = insert ? 0 : 1;
1297     }
1298     else {
1299         cLISTOPx(parent)->op_first = insert;
1300         if (insert)
1301             parent->op_flags |= OPf_KIDS;
1302         else
1303             parent->op_flags &= ~OPf_KIDS;
1304     }
1305
1306     if (!rest) {
1307         /* update op_last etc */
1308         U32 type = parent->op_type;
1309         OP *lastop;
1310
1311         if (type == OP_NULL)
1312             type = parent->op_targ;
1313         type = PL_opargs[type] & OA_CLASS_MASK;
1314
1315         lastop = last_ins ? last_ins : start ? start : NULL;
1316         if (   type == OA_BINOP
1317             || type == OA_LISTOP
1318             || type == OA_PMOP
1319             || type == OA_LOOP
1320         )
1321             cLISTOPx(parent)->op_last = lastop;
1322
1323         if (lastop) {
1324             lastop->op_lastsib = 1;
1325 #ifdef PERL_OP_PARENT
1326             lastop->op_sibling = parent;
1327 #endif
1328         }
1329     }
1330     return last_del ? first : NULL;
1331 }
1332
1333 /*
1334 =for apidoc op_parent
1335
1336 returns the parent OP of o, if it has a parent.  Returns NULL otherwise.
1337 (Currently perl must be built with C<-DPERL_OP_PARENT> for this feature to
1338 work.
1339
1340 =cut
1341 */
1342
1343 OP *
1344 Perl_op_parent(OP *o)
1345 {
1346     PERL_ARGS_ASSERT_OP_PARENT;
1347 #ifdef PERL_OP_PARENT
1348     while (OpHAS_SIBLING(o))
1349         o = OpSIBLING(o);
1350     return o->op_sibling;
1351 #else
1352     PERL_UNUSED_ARG(o);
1353     return NULL;
1354 #endif
1355 }
1356
1357
1358 /* replace the sibling following start with a new UNOP, which becomes
1359  * the parent of the original sibling; e.g.
1360  *
1361  *  op_sibling_newUNOP(P, A, unop-args...)
1362  *
1363  *  P              P
1364  *  |      becomes |
1365  *  A-B-C          A-U-C
1366  *                   |
1367  *                   B
1368  *
1369  * where U is the new UNOP.
1370  *
1371  * parent and start args are the same as for op_sibling_splice();
1372  * type and flags args are as newUNOP().
1373  *
1374  * Returns the new UNOP.
1375  */
1376
1377 OP *
1378 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1379 {
1380     OP *kid, *newop;
1381
1382     kid = op_sibling_splice(parent, start, 1, NULL);
1383     newop = newUNOP(type, flags, kid);
1384     op_sibling_splice(parent, start, 0, newop);
1385     return newop;
1386 }
1387
1388
1389 /* lowest-level newLOGOP-style function - just allocates and populates
1390  * the struct. Higher-level stuff should be done by S_new_logop() /
1391  * newLOGOP(). This function exists mainly to avoid op_first assignment
1392  * being spread throughout this file.
1393  */
1394
1395 LOGOP *
1396 S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1397 {
1398     dVAR;
1399     LOGOP *logop;
1400     OP *kid = first;
1401     NewOp(1101, logop, 1, LOGOP);
1402     CHANGE_TYPE(logop, type);
1403     logop->op_first = first;
1404     logop->op_other = other;
1405     logop->op_flags = OPf_KIDS;
1406     while (kid && OpHAS_SIBLING(kid))
1407         kid = OpSIBLING(kid);
1408     if (kid) {
1409         kid->op_lastsib = 1;
1410 #ifdef PERL_OP_PARENT
1411         kid->op_sibling = (OP*)logop;
1412 #endif
1413     }
1414     return logop;
1415 }
1416
1417
1418 /* Contextualizers */
1419
1420 /*
1421 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1422
1423 Applies a syntactic context to an op tree representing an expression.
1424 I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
1425 or C<G_VOID> to specify the context to apply.  The modified op tree
1426 is returned.
1427
1428 =cut
1429 */
1430
1431 OP *
1432 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1433 {
1434     PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1435     switch (context) {
1436         case G_SCALAR: return scalar(o);
1437         case G_ARRAY:  return list(o);
1438         case G_VOID:   return scalarvoid(o);
1439         default:
1440             Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1441                        (long) context);
1442     }
1443 }
1444
1445 /*
1446
1447 =for apidoc Am|OP*|op_linklist|OP *o
1448 This function is the implementation of the L</LINKLIST> macro.  It should
1449 not be called directly.
1450
1451 =cut
1452 */
1453
1454 OP *
1455 Perl_op_linklist(pTHX_ OP *o)
1456 {
1457     OP *first;
1458
1459     PERL_ARGS_ASSERT_OP_LINKLIST;
1460
1461     if (o->op_next)
1462         return o->op_next;
1463
1464     /* establish postfix order */
1465     first = cUNOPo->op_first;
1466     if (first) {
1467         OP *kid;
1468         o->op_next = LINKLIST(first);
1469         kid = first;
1470         for (;;) {
1471             OP *sibl = OpSIBLING(kid);
1472             if (sibl) {
1473                 kid->op_next = LINKLIST(sibl);
1474                 kid = sibl;
1475             } else {
1476                 kid->op_next = o;
1477                 break;
1478             }
1479         }
1480     }
1481     else
1482         o->op_next = o;
1483
1484     return o->op_next;
1485 }
1486
1487 static OP *
1488 S_scalarkids(pTHX_ OP *o)
1489 {
1490     if (o && o->op_flags & OPf_KIDS) {
1491         OP *kid;
1492         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1493             scalar(kid);
1494     }
1495     return o;
1496 }
1497
1498 STATIC OP *
1499 S_scalarboolean(pTHX_ OP *o)
1500 {
1501     PERL_ARGS_ASSERT_SCALARBOOLEAN;
1502
1503     if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
1504      && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
1505         if (ckWARN(WARN_SYNTAX)) {
1506             const line_t oldline = CopLINE(PL_curcop);
1507
1508             if (PL_parser && PL_parser->copline != NOLINE) {
1509                 /* This ensures that warnings are reported at the first line
1510                    of the conditional, not the last.  */
1511                 CopLINE_set(PL_curcop, PL_parser->copline);
1512             }
1513             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1514             CopLINE_set(PL_curcop, oldline);
1515         }
1516     }
1517     return scalar(o);
1518 }
1519
1520 static SV *
1521 S_op_varname(pTHX_ const OP *o)
1522 {
1523     assert(o);
1524     assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1525            o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1526     {
1527         const char funny  = o->op_type == OP_PADAV
1528                          || o->op_type == OP_RV2AV ? '@' : '%';
1529         if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1530             GV *gv;
1531             if (cUNOPo->op_first->op_type != OP_GV
1532              || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1533                 return NULL;
1534             return varname(gv, funny, 0, NULL, 0, 1);
1535         }
1536         return
1537             varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, 1);
1538     }
1539 }
1540
1541 static void
1542 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1543 { /* or not so pretty :-) */
1544     if (o->op_type == OP_CONST) {
1545         *retsv = cSVOPo_sv;
1546         if (SvPOK(*retsv)) {
1547             SV *sv = *retsv;
1548             *retsv = sv_newmortal();
1549             pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1550                       PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1551         }
1552         else if (!SvOK(*retsv))
1553             *retpv = "undef";
1554     }
1555     else *retpv = "...";
1556 }
1557
1558 static void
1559 S_scalar_slice_warning(pTHX_ const OP *o)
1560 {
1561     OP *kid;
1562     const char lbrack =
1563         o->op_type == OP_HSLICE ? '{' : '[';
1564     const char rbrack =
1565         o->op_type == OP_HSLICE ? '}' : ']';
1566     SV *name;
1567     SV *keysv = NULL; /* just to silence compiler warnings */
1568     const char *key = NULL;
1569
1570     if (!(o->op_private & OPpSLICEWARNING))
1571         return;
1572     if (PL_parser && PL_parser->error_count)
1573         /* This warning can be nonsensical when there is a syntax error. */
1574         return;
1575
1576     kid = cLISTOPo->op_first;
1577     kid = OpSIBLING(kid); /* get past pushmark */
1578     /* weed out false positives: any ops that can return lists */
1579     switch (kid->op_type) {
1580     case OP_BACKTICK:
1581     case OP_GLOB:
1582     case OP_READLINE:
1583     case OP_MATCH:
1584     case OP_RV2AV:
1585     case OP_EACH:
1586     case OP_VALUES:
1587     case OP_KEYS:
1588     case OP_SPLIT:
1589     case OP_LIST:
1590     case OP_SORT:
1591     case OP_REVERSE:
1592     case OP_ENTERSUB:
1593     case OP_CALLER:
1594     case OP_LSTAT:
1595     case OP_STAT:
1596     case OP_READDIR:
1597     case OP_SYSTEM:
1598     case OP_TMS:
1599     case OP_LOCALTIME:
1600     case OP_GMTIME:
1601     case OP_ENTEREVAL:
1602     case OP_REACH:
1603     case OP_RKEYS:
1604     case OP_RVALUES:
1605         return;
1606     }
1607
1608     /* Don't warn if we have a nulled list either. */
1609     if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1610         return;
1611
1612     assert(OpSIBLING(kid));
1613     name = S_op_varname(aTHX_ OpSIBLING(kid));
1614     if (!name) /* XS module fiddling with the op tree */
1615         return;
1616     S_op_pretty(aTHX_ kid, &keysv, &key);
1617     assert(SvPOK(name));
1618     sv_chop(name,SvPVX(name)+1);
1619     if (key)
1620        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1621         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1622                    "Scalar value @%"SVf"%c%s%c better written as $%"SVf
1623                    "%c%s%c",
1624                     SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1625                     lbrack, key, rbrack);
1626     else
1627        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1628         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1629                    "Scalar value @%"SVf"%c%"SVf"%c better written as $%"
1630                     SVf"%c%"SVf"%c",
1631                     SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1632                     SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1633 }
1634
1635 OP *
1636 Perl_scalar(pTHX_ OP *o)
1637 {
1638     OP *kid;
1639
1640     /* assumes no premature commitment */
1641     if (!o || (PL_parser && PL_parser->error_count)
1642          || (o->op_flags & OPf_WANT)
1643          || o->op_type == OP_RETURN)
1644     {
1645         return o;
1646     }
1647
1648     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1649
1650     switch (o->op_type) {
1651     case OP_REPEAT:
1652         scalar(cBINOPo->op_first);
1653         if (o->op_private & OPpREPEAT_DOLIST) {
1654             kid = cLISTOPx(cUNOPo->op_first)->op_first;
1655             assert(kid->op_type == OP_PUSHMARK);
1656             if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1657                 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1658                 o->op_private &=~ OPpREPEAT_DOLIST;
1659             }
1660         }
1661         break;
1662     case OP_OR:
1663     case OP_AND:
1664     case OP_COND_EXPR:
1665         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
1666             scalar(kid);
1667         break;
1668         /* FALLTHROUGH */
1669     case OP_SPLIT:
1670     case OP_MATCH:
1671     case OP_QR:
1672     case OP_SUBST:
1673     case OP_NULL:
1674     default:
1675         if (o->op_flags & OPf_KIDS) {
1676             for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1677                 scalar(kid);
1678         }
1679         break;
1680     case OP_LEAVE:
1681     case OP_LEAVETRY:
1682         kid = cLISTOPo->op_first;
1683         scalar(kid);
1684         kid = OpSIBLING(kid);
1685     do_kids:
1686         while (kid) {
1687             OP *sib = OpSIBLING(kid);
1688             if (sib && kid->op_type != OP_LEAVEWHEN
1689              && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
1690                 || (  sib->op_targ != OP_NEXTSTATE
1691                    && sib->op_targ != OP_DBSTATE  )))
1692                 scalarvoid(kid);
1693             else
1694                 scalar(kid);
1695             kid = sib;
1696         }
1697         PL_curcop = &PL_compiling;
1698         break;
1699     case OP_SCOPE:
1700     case OP_LINESEQ:
1701     case OP_LIST:
1702         kid = cLISTOPo->op_first;
1703         goto do_kids;
1704     case OP_SORT:
1705         Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1706         break;
1707     case OP_KVHSLICE:
1708     case OP_KVASLICE:
1709     {
1710         /* Warn about scalar context */
1711         const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1712         const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1713         SV *name;
1714         SV *keysv;
1715         const char *key = NULL;
1716
1717         /* This warning can be nonsensical when there is a syntax error. */
1718         if (PL_parser && PL_parser->error_count)
1719             break;
1720
1721         if (!ckWARN(WARN_SYNTAX)) break;
1722
1723         kid = cLISTOPo->op_first;
1724         kid = OpSIBLING(kid); /* get past pushmark */
1725         assert(OpSIBLING(kid));
1726         name = S_op_varname(aTHX_ OpSIBLING(kid));
1727         if (!name) /* XS module fiddling with the op tree */
1728             break;
1729         S_op_pretty(aTHX_ kid, &keysv, &key);
1730         assert(SvPOK(name));
1731         sv_chop(name,SvPVX(name)+1);
1732         if (key)
1733   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1734             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1735                        "%%%"SVf"%c%s%c in scalar context better written "
1736                        "as $%"SVf"%c%s%c",
1737                         SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1738                         lbrack, key, rbrack);
1739         else
1740   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1741             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1742                        "%%%"SVf"%c%"SVf"%c in scalar context better "
1743                        "written as $%"SVf"%c%"SVf"%c",
1744                         SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1745                         SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1746     }
1747     }
1748     return o;
1749 }
1750
1751 OP *
1752 Perl_scalarvoid(pTHX_ OP *arg)
1753 {
1754     dVAR;
1755     OP *kid;
1756     SV* sv;
1757     U8 want;
1758     SSize_t defer_stack_alloc = 0;
1759     SSize_t defer_ix = -1;
1760     OP **defer_stack = NULL;
1761     OP *o = arg;
1762
1763     PERL_ARGS_ASSERT_SCALARVOID;
1764
1765     do {
1766         SV *useless_sv = NULL;
1767         const char* useless = NULL;
1768         bool useless_is_grep = FALSE;
1769
1770         if (o->op_type == OP_NEXTSTATE
1771             || o->op_type == OP_DBSTATE
1772             || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1773                                           || o->op_targ == OP_DBSTATE)))
1774             PL_curcop = (COP*)o;                /* for warning below */
1775
1776         /* assumes no premature commitment */
1777         want = o->op_flags & OPf_WANT;
1778         if ((want && want != OPf_WANT_SCALAR)
1779             || (PL_parser && PL_parser->error_count)
1780             || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1781         {
1782             continue;
1783         }
1784
1785         if ((o->op_private & OPpTARGET_MY)
1786             && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1787         {
1788             /* newASSIGNOP has already applied scalar context, which we
1789                leave, as if this op is inside SASSIGN.  */
1790             continue;
1791         }
1792
1793         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1794
1795         switch (o->op_type) {
1796         default:
1797             if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1798                 break;
1799             /* FALLTHROUGH */
1800         case OP_REPEAT:
1801             if (o->op_flags & OPf_STACKED)
1802                 break;
1803             if (o->op_type == OP_REPEAT)
1804                 scalar(cBINOPo->op_first);
1805             goto func_ops;
1806         case OP_SUBSTR:
1807             if (o->op_private == 4)
1808                 break;
1809             /* FALLTHROUGH */
1810         case OP_WANTARRAY:
1811         case OP_GV:
1812         case OP_SMARTMATCH:
1813         case OP_AV2ARYLEN:
1814         case OP_REF:
1815         case OP_REFGEN:
1816         case OP_SREFGEN:
1817         case OP_DEFINED:
1818         case OP_HEX:
1819         case OP_OCT:
1820         case OP_LENGTH:
1821         case OP_VEC:
1822         case OP_INDEX:
1823         case OP_RINDEX:
1824         case OP_SPRINTF:
1825         case OP_KVASLICE:
1826         case OP_KVHSLICE:
1827         case OP_UNPACK:
1828         case OP_PACK:
1829         case OP_JOIN:
1830         case OP_LSLICE:
1831         case OP_ANONLIST:
1832         case OP_ANONHASH:
1833         case OP_SORT:
1834         case OP_REVERSE:
1835         case OP_RANGE:
1836         case OP_FLIP:
1837         case OP_FLOP:
1838         case OP_CALLER:
1839         case OP_FILENO:
1840         case OP_EOF:
1841         case OP_TELL:
1842         case OP_GETSOCKNAME:
1843         case OP_GETPEERNAME:
1844         case OP_READLINK:
1845         case OP_TELLDIR:
1846         case OP_GETPPID:
1847         case OP_GETPGRP:
1848         case OP_GETPRIORITY:
1849         case OP_TIME:
1850         case OP_TMS:
1851         case OP_LOCALTIME:
1852         case OP_GMTIME:
1853         case OP_GHBYNAME:
1854         case OP_GHBYADDR:
1855         case OP_GHOSTENT:
1856         case OP_GNBYNAME:
1857         case OP_GNBYADDR:
1858         case OP_GNETENT:
1859         case OP_GPBYNAME:
1860         case OP_GPBYNUMBER:
1861         case OP_GPROTOENT:
1862         case OP_GSBYNAME:
1863         case OP_GSBYPORT:
1864         case OP_GSERVENT:
1865         case OP_GPWNAM:
1866         case OP_GPWUID:
1867         case OP_GGRNAM:
1868         case OP_GGRGID:
1869         case OP_GETLOGIN:
1870         case OP_PROTOTYPE:
1871         case OP_RUNCV:
1872         func_ops:
1873             useless = OP_DESC(o);
1874             break;
1875
1876         case OP_GVSV:
1877         case OP_PADSV:
1878         case OP_PADAV:
1879         case OP_PADHV:
1880         case OP_PADANY:
1881         case OP_AELEM:
1882         case OP_AELEMFAST:
1883         case OP_AELEMFAST_LEX:
1884         case OP_ASLICE:
1885         case OP_HELEM:
1886         case OP_HSLICE:
1887             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1888                 useless = OP_DESC(o);
1889             break;
1890         case OP_GREPWHILE:
1891             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO))) {
1892                 /* Otherwise it's "Useless use of grep iterator" */
1893                 useless = "grep";
1894                 useless_is_grep = TRUE;
1895             }
1896             break;
1897
1898         case OP_SPLIT:
1899             kid = cLISTOPo->op_first;
1900             if (kid && kid->op_type == OP_PUSHRE
1901                 && !kid->op_targ
1902                 && !(o->op_flags & OPf_STACKED)
1903 #ifdef USE_ITHREADS
1904                 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
1905 #else
1906                 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
1907 #endif
1908                 )
1909                 useless = OP_DESC(o);
1910             break;
1911
1912         case OP_NOT:
1913             kid = cUNOPo->op_first;
1914             if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1915                 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1916                 goto func_ops;
1917             }
1918             useless = "negative pattern binding (!~)";
1919             break;
1920
1921         case OP_SUBST:
1922             if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1923                 useless = "non-destructive substitution (s///r)";
1924             break;
1925
1926         case OP_TRANSR:
1927             useless = "non-destructive transliteration (tr///r)";
1928             break;
1929
1930         case OP_RV2GV:
1931         case OP_RV2SV:
1932         case OP_RV2AV:
1933         case OP_RV2HV:
1934             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1935                 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
1936                 useless = "a variable";
1937             break;
1938
1939         case OP_CONST:
1940             sv = cSVOPo_sv;
1941             if (cSVOPo->op_private & OPpCONST_STRICT)
1942                 no_bareword_allowed(o);
1943             else {
1944                 if (ckWARN(WARN_VOID)) {
1945                     NV nv;
1946                     /* don't warn on optimised away booleans, eg
1947                      * use constant Foo, 5; Foo || print; */
1948                     if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1949                         useless = NULL;
1950                     /* the constants 0 and 1 are permitted as they are
1951                        conventionally used as dummies in constructs like
1952                        1 while some_condition_with_side_effects;  */
1953                     else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
1954                         useless = NULL;
1955                     else if (SvPOK(sv)) {
1956                         SV * const dsv = newSVpvs("");
1957                         useless_sv
1958                             = Perl_newSVpvf(aTHX_
1959                                             "a constant (%s)",
1960                                             pv_pretty(dsv, SvPVX_const(sv),
1961                                                       SvCUR(sv), 32, NULL, NULL,
1962                                                       PERL_PV_PRETTY_DUMP
1963                                                       | PERL_PV_ESCAPE_NOCLEAR
1964                                                       | PERL_PV_ESCAPE_UNI_DETECT));
1965                         SvREFCNT_dec_NN(dsv);
1966                     }
1967                     else if (SvOK(sv)) {
1968                         useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", SVfARG(sv));
1969                     }
1970                     else
1971                         useless = "a constant (undef)";
1972                 }
1973             }
1974             op_null(o);         /* don't execute or even remember it */
1975             break;
1976
1977         case OP_POSTINC:
1978             CHANGE_TYPE(o, OP_PREINC);  /* pre-increment is faster */
1979             break;
1980
1981         case OP_POSTDEC:
1982             CHANGE_TYPE(o, OP_PREDEC);  /* pre-decrement is faster */
1983             break;
1984
1985         case OP_I_POSTINC:
1986             CHANGE_TYPE(o, OP_I_PREINC);        /* pre-increment is faster */
1987             break;
1988
1989         case OP_I_POSTDEC:
1990             CHANGE_TYPE(o, OP_I_PREDEC);        /* pre-decrement is faster */
1991             break;
1992
1993         case OP_SASSIGN: {
1994             OP *rv2gv;
1995             UNOP *refgen, *rv2cv;
1996             LISTOP *exlist;
1997
1998             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
1999                 break;
2000
2001             rv2gv = ((BINOP *)o)->op_last;
2002             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2003                 break;
2004
2005             refgen = (UNOP *)((BINOP *)o)->op_first;
2006
2007             if (!refgen || (refgen->op_type != OP_REFGEN
2008                             && refgen->op_type != OP_SREFGEN))
2009                 break;
2010
2011             exlist = (LISTOP *)refgen->op_first;
2012             if (!exlist || exlist->op_type != OP_NULL
2013                 || exlist->op_targ != OP_LIST)
2014                 break;
2015
2016             if (exlist->op_first->op_type != OP_PUSHMARK
2017                 && exlist->op_first != exlist->op_last)
2018                 break;
2019
2020             rv2cv = (UNOP*)exlist->op_last;
2021
2022             if (rv2cv->op_type != OP_RV2CV)
2023                 break;
2024
2025             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2026             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2027             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2028
2029             o->op_private |= OPpASSIGN_CV_TO_GV;
2030             rv2gv->op_private |= OPpDONT_INIT_GV;
2031             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2032
2033             break;
2034         }
2035
2036         case OP_AASSIGN: {
2037             inplace_aassign(o);
2038             break;
2039         }
2040
2041         case OP_OR:
2042         case OP_AND:
2043             kid = cLOGOPo->op_first;
2044             if (kid->op_type == OP_NOT
2045                 && (kid->op_flags & OPf_KIDS)) {
2046                 if (o->op_type == OP_AND) {
2047                     CHANGE_TYPE(o, OP_OR);
2048                 } else {
2049                     CHANGE_TYPE(o, OP_AND);
2050                 }
2051                 op_null(kid);
2052             }
2053             /* FALLTHROUGH */
2054
2055         case OP_DOR:
2056         case OP_COND_EXPR:
2057         case OP_ENTERGIVEN:
2058         case OP_ENTERWHEN:
2059             for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2060                 if (!(kid->op_flags & OPf_KIDS))
2061                     scalarvoid(kid);
2062                 else
2063                     DEFER_OP(kid);
2064         break;
2065
2066         case OP_NULL:
2067             if (o->op_flags & OPf_STACKED)
2068                 break;
2069             /* FALLTHROUGH */
2070         case OP_NEXTSTATE:
2071         case OP_DBSTATE:
2072         case OP_ENTERTRY:
2073         case OP_ENTER:
2074             if (!(o->op_flags & OPf_KIDS))
2075                 break;
2076             /* FALLTHROUGH */
2077         case OP_SCOPE:
2078         case OP_LEAVE:
2079         case OP_LEAVETRY:
2080         case OP_LEAVELOOP:
2081         case OP_LINESEQ:
2082         case OP_LEAVEGIVEN:
2083         case OP_LEAVEWHEN:
2084         kids:
2085             for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2086                 if (!(kid->op_flags & OPf_KIDS))
2087                     scalarvoid(kid);
2088                 else
2089                     DEFER_OP(kid);
2090             break;
2091         case OP_LIST:
2092             /* If the first kid after pushmark is something that the padrange
2093                optimisation would reject, then null the list and the pushmark.
2094             */
2095             if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2096                 && (  !(kid = OpSIBLING(kid))
2097                       || (  kid->op_type != OP_PADSV
2098                             && kid->op_type != OP_PADAV
2099                             && kid->op_type != OP_PADHV)
2100                       || kid->op_private & ~OPpLVAL_INTRO
2101                       || !(kid = OpSIBLING(kid))
2102                       || (  kid->op_type != OP_PADSV
2103                             && kid->op_type != OP_PADAV
2104                             && kid->op_type != OP_PADHV)
2105                       || kid->op_private & ~OPpLVAL_INTRO)
2106             ) {
2107                 op_null(cUNOPo->op_first); /* NULL the pushmark */
2108                 op_null(o); /* NULL the list */
2109             }
2110             goto kids;
2111         case OP_ENTEREVAL:
2112             scalarkids(o);
2113             break;
2114         case OP_SCALAR:
2115             scalar(o);
2116             break;
2117         }
2118
2119         if (useless_sv) {
2120             /* mortalise it, in case warnings are fatal.  */
2121             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2122                            "Useless use of %"SVf" in void context",
2123                            SVfARG(sv_2mortal(useless_sv)));
2124         }
2125         else if (useless) {
2126             if (useless_is_grep) {
2127                 Perl_ck_warner(aTHX_ packWARN(WARN_VOID_UNUSUAL),
2128                                "Unusual use of %s in void context",
2129                                useless);
2130             } else {
2131                 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2132                                "Useless use of %s in void context",
2133                                useless);
2134             }
2135         }
2136     } while ( (o = POP_DEFERRED_OP()) );
2137
2138     Safefree(defer_stack);
2139
2140     return arg;
2141 }
2142
2143 static OP *
2144 S_listkids(pTHX_ OP *o)
2145 {
2146     if (o && o->op_flags & OPf_KIDS) {
2147         OP *kid;
2148         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2149             list(kid);
2150     }
2151     return o;
2152 }
2153
2154 OP *
2155 Perl_list(pTHX_ OP *o)
2156 {
2157     OP *kid;
2158
2159     /* assumes no premature commitment */
2160     if (!o || (o->op_flags & OPf_WANT)
2161          || (PL_parser && PL_parser->error_count)
2162          || o->op_type == OP_RETURN)
2163     {
2164         return o;
2165     }
2166
2167     if ((o->op_private & OPpTARGET_MY)
2168         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2169     {
2170         return o;                               /* As if inside SASSIGN */
2171     }
2172
2173     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2174
2175     switch (o->op_type) {
2176     case OP_FLOP:
2177         list(cBINOPo->op_first);
2178         break;
2179     case OP_REPEAT:
2180         if (o->op_private & OPpREPEAT_DOLIST
2181          && !(o->op_flags & OPf_STACKED))
2182         {
2183             list(cBINOPo->op_first);
2184             kid = cBINOPo->op_last;
2185             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2186              && SvIVX(kSVOP_sv) == 1)
2187             {
2188                 op_null(o); /* repeat */
2189                 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2190                 /* const (rhs): */
2191                 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2192             }
2193         }
2194         break;
2195     case OP_OR:
2196     case OP_AND:
2197     case OP_COND_EXPR:
2198         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2199             list(kid);
2200         break;
2201     default:
2202     case OP_MATCH:
2203     case OP_QR:
2204     case OP_SUBST:
2205     case OP_NULL:
2206         if (!(o->op_flags & OPf_KIDS))
2207             break;
2208         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2209             list(cBINOPo->op_first);
2210             return gen_constant_list(o);
2211         }
2212         listkids(o);
2213         break;
2214     case OP_LIST:
2215         listkids(o);
2216         if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2217             op_null(cUNOPo->op_first); /* NULL the pushmark */
2218             op_null(o); /* NULL the list */
2219         }
2220         break;
2221     case OP_LEAVE:
2222     case OP_LEAVETRY:
2223         kid = cLISTOPo->op_first;
2224         list(kid);
2225         kid = OpSIBLING(kid);
2226     do_kids:
2227         while (kid) {
2228             OP *sib = OpSIBLING(kid);
2229             if (sib && kid->op_type != OP_LEAVEWHEN)
2230                 scalarvoid(kid);
2231             else
2232                 list(kid);
2233             kid = sib;
2234         }
2235         PL_curcop = &PL_compiling;
2236         break;
2237     case OP_SCOPE:
2238     case OP_LINESEQ:
2239         kid = cLISTOPo->op_first;
2240         goto do_kids;
2241     }
2242     return o;
2243 }
2244
2245 static OP *
2246 S_scalarseq(pTHX_ OP *o)
2247 {
2248     if (o) {
2249         const OPCODE type = o->op_type;
2250
2251         if (type == OP_LINESEQ || type == OP_SCOPE ||
2252             type == OP_LEAVE || type == OP_LEAVETRY)
2253         {
2254             OP *kid, *sib;
2255             for (kid = cLISTOPo->op_first; kid; kid = sib) {
2256                 if ((sib = OpSIBLING(kid))
2257                  && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2258                     || (  sib->op_targ != OP_NEXTSTATE
2259                        && sib->op_targ != OP_DBSTATE  )))
2260                 {
2261                     scalarvoid(kid);
2262                 }
2263             }
2264             PL_curcop = &PL_compiling;
2265         }
2266         o->op_flags &= ~OPf_PARENS;
2267         if (PL_hints & HINT_BLOCK_SCOPE)
2268             o->op_flags |= OPf_PARENS;
2269     }
2270     else
2271         o = newOP(OP_STUB, 0);
2272     return o;
2273 }
2274
2275 STATIC OP *
2276 S_modkids(pTHX_ OP *o, I32 type)
2277 {
2278     if (o && o->op_flags & OPf_KIDS) {
2279         OP *kid;
2280         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2281             op_lvalue(kid, type);
2282     }
2283     return o;
2284 }
2285
2286
2287 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2288  * const fields. Also, convert CONST keys to HEK-in-SVs.
2289  * rop is the op that retrieves the hash;
2290  * key_op is the first key
2291  */
2292
2293 void
2294 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op)
2295 {
2296     PADNAME *lexname;
2297     GV **fields;
2298     bool check_fields;
2299
2300     /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2301     if (rop) {
2302         if (rop->op_first->op_type == OP_PADSV)
2303             /* @$hash{qw(keys here)} */
2304             rop = (UNOP*)rop->op_first;
2305         else {
2306             /* @{$hash}{qw(keys here)} */
2307             if (rop->op_first->op_type == OP_SCOPE
2308                 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2309                 {
2310                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2311                 }
2312             else
2313                 rop = NULL;
2314         }
2315     }
2316
2317     lexname = NULL; /* just to silence compiler warnings */
2318     fields  = NULL; /* just to silence compiler warnings */
2319
2320     check_fields =
2321             rop
2322          && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2323              SvPAD_TYPED(lexname))
2324          && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2325          && isGV(*fields) && GvHV(*fields);
2326
2327     for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2328         SV **svp, *sv;
2329         if (key_op->op_type != OP_CONST)
2330             continue;
2331         svp = cSVOPx_svp(key_op);
2332
2333         /* Make the CONST have a shared SV */
2334         if (   !SvIsCOW_shared_hash(sv = *svp)
2335             && SvTYPE(sv) < SVt_PVMG
2336             && SvOK(sv)
2337             && !SvROK(sv))
2338         {
2339             SSize_t keylen;
2340             const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2341             SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2342             SvREFCNT_dec_NN(sv);
2343             *svp = nsv;
2344         }
2345
2346         if (   check_fields
2347             && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2348         {
2349             Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
2350                         "in variable %"PNf" of type %"HEKf,
2351                         SVfARG(*svp), PNfARG(lexname),
2352                         HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2353         }
2354     }
2355 }
2356
2357
2358 /*
2359 =for apidoc finalize_optree
2360
2361 This function finalizes the optree.  Should be called directly after
2362 the complete optree is built.  It does some additional
2363 checking which can't be done in the normal ck_xxx functions and makes
2364 the tree thread-safe.
2365
2366 =cut
2367 */
2368 void
2369 Perl_finalize_optree(pTHX_ OP* o)
2370 {
2371     PERL_ARGS_ASSERT_FINALIZE_OPTREE;
2372
2373     ENTER;
2374     SAVEVPTR(PL_curcop);
2375
2376     finalize_op(o);
2377
2378     LEAVE;
2379 }
2380
2381 #ifdef USE_ITHREADS
2382 /* Relocate sv to the pad for thread safety.
2383  * Despite being a "constant", the SV is written to,
2384  * for reference counts, sv_upgrade() etc. */
2385 PERL_STATIC_INLINE void
2386 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
2387 {
2388     PADOFFSET ix;
2389     PERL_ARGS_ASSERT_OP_RELOCATE_SV;
2390     if (!*svp) return;
2391     ix = pad_alloc(OP_CONST, SVf_READONLY);
2392     SvREFCNT_dec(PAD_SVl(ix));
2393     PAD_SETSV(ix, *svp);
2394     /* XXX I don't know how this isn't readonly already. */
2395     if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
2396     *svp = NULL;
2397     *targp = ix;
2398 }
2399 #endif
2400
2401
2402 STATIC void
2403 S_finalize_op(pTHX_ OP* o)
2404 {
2405     PERL_ARGS_ASSERT_FINALIZE_OP;
2406
2407
2408     switch (o->op_type) {
2409     case OP_NEXTSTATE:
2410     case OP_DBSTATE:
2411         PL_curcop = ((COP*)o);          /* for warnings */
2412         break;
2413     case OP_EXEC:
2414         if (OpHAS_SIBLING(o)) {
2415             OP *sib = OpSIBLING(o);
2416             if ((  sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
2417                 && ckWARN(WARN_EXEC)
2418                 && OpHAS_SIBLING(sib))
2419             {
2420                     const OPCODE type = OpSIBLING(sib)->op_type;
2421                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
2422                         const line_t oldline = CopLINE(PL_curcop);
2423                         CopLINE_set(PL_curcop, CopLINE((COP*)sib));
2424                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
2425                             "Statement unlikely to be reached");
2426                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
2427                             "\t(Maybe you meant system() when you said exec()?)\n");
2428                         CopLINE_set(PL_curcop, oldline);
2429                     }
2430             }
2431         }
2432         break;
2433
2434     case OP_GV:
2435         if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
2436             GV * const gv = cGVOPo_gv;
2437             if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
2438                 /* XXX could check prototype here instead of just carping */
2439                 SV * const sv = sv_newmortal();
2440                 gv_efullname3(sv, gv, NULL);
2441                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
2442                     "%"SVf"() called too early to check prototype",
2443                     SVfARG(sv));
2444             }
2445         }
2446         break;
2447
2448     case OP_CONST:
2449         if (cSVOPo->op_private & OPpCONST_STRICT)
2450             no_bareword_allowed(o);
2451         /* FALLTHROUGH */
2452 #ifdef USE_ITHREADS
2453     case OP_HINTSEVAL:
2454         op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
2455 #endif
2456         break;
2457
2458 #ifdef USE_ITHREADS
2459     /* Relocate all the METHOP's SVs to the pad for thread safety. */
2460     case OP_METHOD_NAMED:
2461     case OP_METHOD_SUPER:
2462     case OP_METHOD_REDIR:
2463     case OP_METHOD_REDIR_SUPER:
2464         op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
2465         break;
2466 #endif
2467
2468     case OP_HELEM: {
2469         UNOP *rop;
2470         SVOP *key_op;
2471         OP *kid;
2472
2473         if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
2474             break;
2475
2476         rop = (UNOP*)((BINOP*)o)->op_first;
2477
2478         goto check_keys;
2479
2480     case OP_HSLICE:
2481         S_scalar_slice_warning(aTHX_ o);
2482         /* FALLTHROUGH */
2483
2484     case OP_KVHSLICE:
2485         kid = OpSIBLING(cLISTOPo->op_first);
2486         if (/* I bet there's always a pushmark... */
2487             OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
2488             && OP_TYPE_ISNT_NN(kid, OP_CONST))
2489         {
2490             break;
2491         }
2492
2493         key_op = (SVOP*)(kid->op_type == OP_CONST
2494                                 ? kid
2495                                 : OpSIBLING(kLISTOP->op_first));
2496
2497         rop = (UNOP*)((LISTOP*)o)->op_last;
2498
2499       check_keys:
2500         if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
2501             rop = NULL;
2502         S_check_hash_fields_and_hekify(aTHX_ rop, key_op);
2503         break;
2504     }
2505     case OP_ASLICE:
2506         S_scalar_slice_warning(aTHX_ o);
2507         break;
2508
2509     case OP_SUBST: {
2510         if (cPMOPo->op_pmreplrootu.op_pmreplroot)
2511             finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
2512         break;
2513     }
2514     default:
2515         break;
2516     }
2517
2518     if (o->op_flags & OPf_KIDS) {
2519         OP *kid;
2520
2521 #ifdef DEBUGGING
2522         /* check that op_last points to the last sibling, and that
2523          * the last op_sibling field points back to the parent, and
2524          * that the only ops with KIDS are those which are entitled to
2525          * them */
2526         U32 type = o->op_type;
2527         U32 family;
2528         bool has_last;
2529
2530         if (type == OP_NULL) {
2531             type = o->op_targ;
2532             /* ck_glob creates a null UNOP with ex-type GLOB
2533              * (which is a list op. So pretend it wasn't a listop */
2534             if (type == OP_GLOB)
2535                 type = OP_NULL;
2536         }
2537         family = PL_opargs[type] & OA_CLASS_MASK;
2538
2539         has_last = (   family == OA_BINOP
2540                     || family == OA_LISTOP
2541                     || family == OA_PMOP
2542                     || family == OA_LOOP
2543                    );
2544         assert(  has_last /* has op_first and op_last, or ...
2545               ... has (or may have) op_first: */
2546               || family == OA_UNOP
2547               || family == OA_UNOP_AUX
2548               || family == OA_LOGOP
2549               || family == OA_BASEOP_OR_UNOP
2550               || family == OA_FILESTATOP
2551               || family == OA_LOOPEXOP
2552               || family == OA_METHOP
2553               /* I don't know why SASSIGN is tagged as OA_BASEOP - DAPM */
2554               || type == OP_SASSIGN
2555               || type == OP_CUSTOM
2556               || type == OP_NULL /* new_logop does this */
2557               );
2558
2559         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2560 #  ifdef PERL_OP_PARENT
2561             if (!OpHAS_SIBLING(kid)) {
2562                 if (has_last)
2563                     assert(kid == cLISTOPo->op_last);
2564                 assert(kid->op_sibling == o);
2565             }
2566 #  else
2567             if (OpHAS_SIBLING(kid)) {
2568                 assert(!kid->op_lastsib);
2569             }
2570             else {
2571                 assert(kid->op_lastsib);
2572                 if (has_last)
2573                     assert(kid == cLISTOPo->op_last);
2574             }
2575 #  endif
2576         }
2577 #endif
2578
2579         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
2580             finalize_op(kid);
2581     }
2582 }
2583
2584 /*
2585 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
2586
2587 Propagate lvalue ("modifiable") context to an op and its children.
2588 I<type> represents the context type, roughly based on the type of op that
2589 would do the modifying, although C<local()> is represented by OP_NULL,
2590 because it has no op type of its own (it is signalled by a flag on
2591 the lvalue op).
2592
2593 This function detects things that can't be modified, such as C<$x+1>, and
2594 generates errors for them.  For example, C<$x+1 = 2> would cause it to be
2595 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
2596
2597 It also flags things that need to behave specially in an lvalue context,
2598 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
2599
2600 =cut
2601 */
2602
2603 static void
2604 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
2605 {
2606     CV *cv = PL_compcv;
2607     PadnameLVALUE_on(pn);
2608     while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
2609         cv = CvOUTSIDE(cv);
2610         assert(cv);
2611         assert(CvPADLIST(cv));
2612         pn =
2613            PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
2614         assert(PadnameLEN(pn));
2615         PadnameLVALUE_on(pn);
2616     }
2617 }
2618
2619 static bool
2620 S_vivifies(const OPCODE type)
2621 {
2622     switch(type) {
2623     case OP_RV2AV:     case   OP_ASLICE:
2624     case OP_RV2HV:     case OP_KVASLICE:
2625     case OP_RV2SV:     case   OP_HSLICE:
2626     case OP_AELEMFAST: case OP_KVHSLICE:
2627     case OP_HELEM:
2628     case OP_AELEM:
2629         return 1;
2630     }
2631     return 0;
2632 }
2633
2634 static void
2635 S_lvref(pTHX_ OP *o, I32 type)
2636 {
2637     dVAR;
2638     OP *kid;
2639     switch (o->op_type) {
2640     case OP_COND_EXPR:
2641         for (kid = OpSIBLING(cUNOPo->op_first); kid;
2642              kid = OpSIBLING(kid))
2643             S_lvref(aTHX_ kid, type);
2644         /* FALLTHROUGH */
2645     case OP_PUSHMARK:
2646         return;
2647     case OP_RV2AV:
2648         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2649         o->op_flags |= OPf_STACKED;
2650         if (o->op_flags & OPf_PARENS) {
2651             if (o->op_private & OPpLVAL_INTRO) {
2652                  yyerror(Perl_form(aTHX_ "Can't modify reference to "
2653                       "localized parenthesized array in list assignment"));
2654                 return;
2655             }
2656           slurpy:
2657             CHANGE_TYPE(o, OP_LVAVREF);
2658             o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
2659             o->op_flags |= OPf_MOD|OPf_REF;
2660             return;
2661         }
2662         o->op_private |= OPpLVREF_AV;
2663         goto checkgv;
2664     case OP_RV2CV:
2665         kid = cUNOPo->op_first;
2666         if (kid->op_type == OP_NULL)
2667             kid = cUNOPx(kUNOP->op_first->op_sibling)
2668                 ->op_first;
2669         o->op_private = OPpLVREF_CV;
2670         if (kid->op_type == OP_GV)
2671             o->op_flags |= OPf_STACKED;
2672         else if (kid->op_type == OP_PADCV) {
2673             o->op_targ = kid->op_targ;
2674             kid->op_targ = 0;
2675             op_free(cUNOPo->op_first);
2676             cUNOPo->op_first = NULL;
2677             o->op_flags &=~ OPf_KIDS;
2678         }
2679         else goto badref;
2680         break;
2681     case OP_RV2HV:
2682         if (o->op_flags & OPf_PARENS) {
2683           parenhash:
2684             yyerror(Perl_form(aTHX_ "Can't modify reference to "
2685                                  "parenthesized hash in list assignment"));
2686                 return;
2687         }
2688         o->op_private |= OPpLVREF_HV;
2689         /* FALLTHROUGH */
2690     case OP_RV2SV:
2691       checkgv:
2692         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2693         o->op_flags |= OPf_STACKED;
2694         break;
2695     case OP_PADHV:
2696         if (o->op_flags & OPf_PARENS) goto parenhash;
2697         o->op_private |= OPpLVREF_HV;
2698         /* FALLTHROUGH */
2699     case OP_PADSV:
2700         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2701         break;
2702     case OP_PADAV:
2703         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2704         if (o->op_flags & OPf_PARENS) goto slurpy;
2705         o->op_private |= OPpLVREF_AV;
2706         break;
2707     case OP_AELEM:
2708     case OP_HELEM:
2709         o->op_private |= OPpLVREF_ELEM;
2710         o->op_flags   |= OPf_STACKED;
2711         break;
2712     case OP_ASLICE:
2713     case OP_HSLICE:
2714         CHANGE_TYPE(o, OP_LVREFSLICE);
2715         o->op_private &= OPpLVAL_INTRO|OPpLVREF_ELEM;
2716         return;
2717     case OP_NULL:
2718         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
2719             goto badref;
2720         else if (!(o->op_flags & OPf_KIDS))
2721             return;
2722         if (o->op_targ != OP_LIST) {
2723             S_lvref(aTHX_ cBINOPo->op_first, type);
2724             return;
2725         }
2726         /* FALLTHROUGH */
2727     case OP_LIST:
2728         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
2729             assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
2730             S_lvref(aTHX_ kid, type);
2731         }
2732         return;
2733     case OP_STUB:
2734         if (o->op_flags & OPf_PARENS)
2735             return;
2736         /* FALLTHROUGH */
2737     default:
2738       badref:
2739         /* diag_listed_as: Can't modify reference to %s in %s assignment */
2740         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
2741                      o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
2742                       ? "do block"
2743                       : OP_DESC(o),
2744                      PL_op_desc[type]));
2745         return;
2746     }
2747     CHANGE_TYPE(o, OP_LVREF);
2748     o->op_private &=
2749         OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
2750     if (type == OP_ENTERLOOP)
2751         o->op_private |= OPpLVREF_ITER;
2752 }
2753
2754 OP *
2755 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
2756 {
2757     dVAR;
2758     OP *kid;
2759     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2760     int localize = -1;
2761
2762     if (!o || (PL_parser && PL_parser->error_count))
2763         return o;
2764
2765     if ((o->op_private & OPpTARGET_MY)
2766         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2767     {
2768         return o;
2769     }
2770
2771     assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2772
2773     if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2774
2775     switch (o->op_type) {
2776     case OP_UNDEF:
2777         PL_modcount++;
2778         return o;
2779     case OP_STUB:
2780         if ((o->op_flags & OPf_PARENS))
2781             break;
2782         goto nomod;
2783     case OP_ENTERSUB:
2784         if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
2785             !(o->op_flags & OPf_STACKED)) {
2786             CHANGE_TYPE(o, OP_RV2CV);           /* entersub => rv2cv */
2787             assert(cUNOPo->op_first->op_type == OP_NULL);
2788             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
2789             break;
2790         }
2791         else {                          /* lvalue subroutine call */
2792             o->op_private |= OPpLVAL_INTRO;
2793             PL_modcount = RETURN_UNLIMITED_NUMBER;
2794             if (type == OP_GREPSTART || type == OP_ENTERSUB
2795              || type == OP_REFGEN    || type == OP_LEAVESUBLV) {
2796                 /* Potential lvalue context: */
2797                 o->op_private |= OPpENTERSUB_INARGS;
2798                 break;
2799             }
2800             else {                      /* Compile-time error message: */
2801                 OP *kid = cUNOPo->op_first;
2802                 CV *cv;
2803                 GV *gv;
2804
2805                 if (kid->op_type != OP_PUSHMARK) {
2806                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2807                         Perl_croak(aTHX_
2808                                 "panic: unexpected lvalue entersub "
2809                                 "args: type/targ %ld:%"UVuf,
2810                                 (long)kid->op_type, (UV)kid->op_targ);
2811                     kid = kLISTOP->op_first;
2812                 }
2813                 while (OpHAS_SIBLING(kid))
2814                     kid = OpSIBLING(kid);
2815                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
2816                     break;      /* Postpone until runtime */
2817                 }
2818
2819                 kid = kUNOP->op_first;
2820                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2821                     kid = kUNOP->op_first;
2822                 if (kid->op_type == OP_NULL)
2823                     Perl_croak(aTHX_
2824                                "Unexpected constant lvalue entersub "
2825                                "entry via type/targ %ld:%"UVuf,
2826                                (long)kid->op_type, (UV)kid->op_targ);
2827                 if (kid->op_type != OP_GV) {
2828                     break;
2829                 }
2830
2831                 gv = kGVOP_gv;
2832                 cv = isGV(gv)
2833                     ? GvCV(gv)
2834                     : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
2835                         ? MUTABLE_CV(SvRV(gv))
2836                         : NULL;
2837                 if (!cv)
2838                     break;
2839                 if (CvLVALUE(cv))
2840                     break;
2841             }
2842         }
2843         /* FALLTHROUGH */
2844     default:
2845       nomod:
2846         if (flags & OP_LVALUE_NO_CROAK) return NULL;
2847         /* grep, foreach, subcalls, refgen */
2848         if (type == OP_GREPSTART || type == OP_ENTERSUB
2849          || type == OP_REFGEN    || type == OP_LEAVESUBLV)
2850             break;
2851         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2852                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
2853                       ? "do block"
2854                       : (o->op_type == OP_ENTERSUB
2855                         ? "non-lvalue subroutine call"
2856                         : OP_DESC(o))),
2857                      type ? PL_op_desc[type] : "local"));
2858         return o;
2859
2860     case OP_PREINC:
2861     case OP_PREDEC:
2862     case OP_POW:
2863     case OP_MULTIPLY:
2864     case OP_DIVIDE:
2865     case OP_MODULO:
2866     case OP_ADD:
2867     case OP_SUBTRACT:
2868     case OP_CONCAT:
2869     case OP_LEFT_SHIFT:
2870     case OP_RIGHT_SHIFT:
2871     case OP_BIT_AND:
2872     case OP_BIT_XOR:
2873     case OP_BIT_OR:
2874     case OP_I_MULTIPLY:
2875     case OP_I_DIVIDE:
2876     case OP_I_MODULO:
2877     case OP_I_ADD:
2878     case OP_I_SUBTRACT:
2879         if (!(o->op_flags & OPf_STACKED))
2880             goto nomod;
2881         PL_modcount++;
2882         break;
2883
2884     case OP_REPEAT:
2885         if (o->op_flags & OPf_STACKED) {
2886             PL_modcount++;
2887             break;
2888         }
2889         if (!(o->op_private & OPpREPEAT_DOLIST))
2890             goto nomod;
2891         else {
2892             const I32 mods = PL_modcount;
2893             modkids(cBINOPo->op_first, type);
2894             if (type != OP_AASSIGN)
2895                 goto nomod;
2896             kid = cBINOPo->op_last;
2897             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
2898                 const IV iv = SvIV(kSVOP_sv);
2899                 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
2900                     PL_modcount =
2901                         mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
2902             }
2903             else
2904                 PL_modcount = RETURN_UNLIMITED_NUMBER;
2905         }
2906         break;
2907
2908     case OP_COND_EXPR:
2909         localize = 1;
2910         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2911             op_lvalue(kid, type);
2912         break;
2913
2914     case OP_RV2AV:
2915     case OP_RV2HV:
2916         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
2917            PL_modcount = RETURN_UNLIMITED_NUMBER;
2918             return o;           /* Treat \(@foo) like ordinary list. */
2919         }
2920         /* FALLTHROUGH */
2921     case OP_RV2GV:
2922         if (scalar_mod_type(o, type))
2923             goto nomod;
2924         ref(cUNOPo->op_first, o->op_type);
2925         /* FALLTHROUGH */
2926     case OP_ASLICE:
2927     case OP_HSLICE:
2928         localize = 1;
2929         /* FALLTHROUGH */
2930     case OP_AASSIGN:
2931         /* Do not apply the lvsub flag for rv2[ah]v in scalar context.  */
2932         if (type == OP_LEAVESUBLV && (
2933                 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
2934              || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2935            ))
2936             o->op_private |= OPpMAYBE_LVSUB;
2937         /* FALLTHROUGH */
2938     case OP_NEXTSTATE:
2939     case OP_DBSTATE:
2940        PL_modcount = RETURN_UNLIMITED_NUMBER;
2941         break;
2942     case OP_KVHSLICE:
2943     case OP_KVASLICE:
2944         if (type == OP_LEAVESUBLV)
2945             o->op_private |= OPpMAYBE_LVSUB;
2946         goto nomod;
2947     case OP_AV2ARYLEN:
2948         PL_hints |= HINT_BLOCK_SCOPE;
2949         if (type == OP_LEAVESUBLV)
2950             o->op_private |= OPpMAYBE_LVSUB;
2951         PL_modcount++;
2952         break;
2953     case OP_RV2SV:
2954         ref(cUNOPo->op_first, o->op_type);
2955         localize = 1;
2956         /* FALLTHROUGH */
2957     case OP_GV:
2958         PL_hints |= HINT_BLOCK_SCOPE;
2959         /* FALLTHROUGH */
2960     case OP_SASSIGN:
2961     case OP_ANDASSIGN:
2962     case OP_ORASSIGN:
2963     case OP_DORASSIGN:
2964         PL_modcount++;
2965         break;
2966
2967     case OP_AELEMFAST:
2968     case OP_AELEMFAST_LEX:
2969         localize = -1;
2970         PL_modcount++;
2971         break;
2972
2973     case OP_PADAV:
2974     case OP_PADHV:
2975        PL_modcount = RETURN_UNLIMITED_NUMBER;
2976         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
2977             return o;           /* Treat \(@foo) like ordinary list. */
2978         if (scalar_mod_type(o, type))
2979             goto nomod;
2980         if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2981           && type == OP_LEAVESUBLV)
2982             o->op_private |= OPpMAYBE_LVSUB;
2983         /* FALLTHROUGH */
2984     case OP_PADSV:
2985         PL_modcount++;
2986         if (!type) /* local() */
2987             Perl_croak(aTHX_ "Can't localize lexical variable %"PNf,
2988                               PNfARG(PAD_COMPNAME(o->op_targ)));
2989         if (!(o->op_private & OPpLVAL_INTRO)
2990          || (  type != OP_SASSIGN && type != OP_AASSIGN
2991             && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ))  ))
2992             S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
2993         break;
2994
2995     case OP_PUSHMARK:
2996         localize = 0;
2997         break;
2998
2999     case OP_KEYS:
3000     case OP_RKEYS:
3001         if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
3002             goto nomod;
3003         goto lvalue_func;
3004     case OP_SUBSTR:
3005         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
3006             goto nomod;
3007         /* FALLTHROUGH */
3008     case OP_POS:
3009     case OP_VEC:
3010       lvalue_func:
3011         if (type == OP_LEAVESUBLV)
3012             o->op_private |= OPpMAYBE_LVSUB;
3013         if (o->op_flags & OPf_KIDS)
3014             op_lvalue(OpSIBLING(cBINOPo->op_first), type);
3015         break;
3016
3017     case OP_AELEM:
3018     case OP_HELEM:
3019         ref(cBINOPo->op_first, o->op_type);
3020         if (type == OP_ENTERSUB &&
3021              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
3022             o->op_private |= OPpLVAL_DEFER;
3023         if (type == OP_LEAVESUBLV)
3024             o->op_private |= OPpMAYBE_LVSUB;
3025         localize = 1;
3026         PL_modcount++;
3027         break;
3028
3029     case OP_LEAVE:
3030     case OP_LEAVELOOP:
3031         o->op_private |= OPpLVALUE;
3032         /* FALLTHROUGH */
3033     case OP_SCOPE:
3034     case OP_ENTER:
3035     case OP_LINESEQ:
3036         localize = 0;
3037         if (o->op_flags & OPf_KIDS)
3038             op_lvalue(cLISTOPo->op_last, type);
3039         break;
3040
3041     case OP_NULL:
3042         localize = 0;
3043         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
3044             goto nomod;
3045         else if (!(o->op_flags & OPf_KIDS))
3046             break;
3047         if (o->op_targ != OP_LIST) {
3048             op_lvalue(cBINOPo->op_first, type);
3049             break;
3050         }
3051         /* FALLTHROUGH */
3052     case OP_LIST:
3053         localize = 0;
3054         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3055             /* elements might be in void context because the list is
3056                in scalar context or because they are attribute sub calls */
3057             if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
3058                 op_lvalue(kid, type);
3059         break;
3060
3061     case OP_COREARGS:
3062         return o;
3063
3064     case OP_AND:
3065     case OP_OR:
3066         if (type == OP_LEAVESUBLV
3067          || !S_vivifies(cLOGOPo->op_first->op_type))
3068             op_lvalue(cLOGOPo->op_first, type);
3069         if (type == OP_LEAVESUBLV
3070          || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
3071             op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
3072         goto nomod;
3073
3074     case OP_SREFGEN:
3075         if (type != OP_AASSIGN && type != OP_SASSIGN
3076          && type != OP_ENTERLOOP)
3077             goto nomod;
3078         /* Don’t bother applying lvalue context to the ex-list.  */
3079         kid = cUNOPx(cUNOPo->op_first)->op_first;
3080         assert (!OpHAS_SIBLING(kid));
3081         goto kid_2lvref;
3082     case OP_REFGEN:
3083         if (type != OP_AASSIGN) goto nomod;
3084         kid = cUNOPo->op_first;
3085       kid_2lvref:
3086         {
3087             const U8 ec = PL_parser ? PL_parser->error_count : 0;
3088             S_lvref(aTHX_ kid, type);
3089             if (!PL_parser || PL_parser->error_count == ec) {
3090                 if (!FEATURE_REFALIASING_IS_ENABLED)
3091                     Perl_croak(aTHX_
3092                        "Experimental aliasing via reference not enabled");
3093                 Perl_ck_warner_d(aTHX_
3094                                  packWARN(WARN_EXPERIMENTAL__REFALIASING),
3095                                 "Aliasing via reference is experimental");
3096             }
3097         }
3098         if (o->op_type == OP_REFGEN)
3099             op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
3100         op_null(o);
3101         return o;
3102
3103     case OP_SPLIT:
3104         kid = cLISTOPo->op_first;
3105         if (kid && kid->op_type == OP_PUSHRE &&
3106                 (  kid->op_targ
3107                 || o->op_flags & OPf_STACKED
3108 #ifdef USE_ITHREADS
3109                 || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
3110 #else
3111                 || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
3112 #endif
3113         )) {
3114             /* This is actually @array = split.  */
3115             PL_modcount = RETURN_UNLIMITED_NUMBER;
3116             break;
3117         }
3118         goto nomod;
3119
3120     case OP_SCALAR:
3121         op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
3122         goto nomod;
3123     }
3124
3125     /* [20011101.069] File test operators interpret OPf_REF to mean that
3126        their argument is a filehandle; thus \stat(".") should not set
3127        it. AMS 20011102 */
3128     if (type == OP_REFGEN &&
3129         PL_check[o->op_type] == Perl_ck_ftst)
3130         return o;
3131
3132     if (type != OP_LEAVESUBLV)
3133         o->op_flags |= OPf_MOD;
3134
3135     if (type == OP_AASSIGN || type == OP_SASSIGN)
3136         o->op_flags |= OPf_SPECIAL|OPf_REF;
3137     else if (!type) { /* local() */
3138         switch (localize) {
3139         case 1:
3140             o->op_private |= OPpLVAL_INTRO;
3141             o->op_flags &= ~OPf_SPECIAL;
3142             PL_hints |= HINT_BLOCK_SCOPE;
3143             break;
3144         case 0:
3145             break;
3146         case -1:
3147             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
3148                            "Useless localization of %s", OP_DESC(o));
3149         }
3150     }
3151     else if (type != OP_GREPSTART && type != OP_ENTERSUB
3152              && type != OP_LEAVESUBLV)
3153         o->op_flags |= OPf_REF;
3154     return o;
3155 }
3156
3157 STATIC bool
3158 S_scalar_mod_type(const OP *o, I32 type)
3159 {
3160     switch (type) {
3161     case OP_POS:
3162     case OP_SASSIGN:
3163         if (o && o->op_type == OP_RV2GV)
3164             return FALSE;
3165         /* FALLTHROUGH */
3166     case OP_PREINC:
3167     case OP_PREDEC:
3168     case OP_POSTINC:
3169     case OP_POSTDEC:
3170     case OP_I_PREINC:
3171     case OP_I_PREDEC:
3172     case OP_I_POSTINC:
3173     case OP_I_POSTDEC:
3174     case OP_POW:
3175     case OP_MULTIPLY:
3176     case OP_DIVIDE:
3177     case OP_MODULO:
3178     case OP_REPEAT:
3179     case OP_ADD:
3180     case OP_SUBTRACT:
3181     case OP_I_MULTIPLY:
3182     case OP_I_DIVIDE:
3183     case OP_I_MODULO:
3184     case OP_I_ADD:
3185     case OP_I_SUBTRACT:
3186     case OP_LEFT_SHIFT:
3187     case OP_RIGHT_SHIFT:
3188     case OP_BIT_AND:
3189     case OP_BIT_XOR:
3190     case OP_BIT_OR:
3191     case OP_CONCAT:
3192     case OP_SUBST:
3193     case OP_TRANS:
3194     case OP_TRANSR:
3195     case OP_READ:
3196     case OP_SYSREAD:
3197     case OP_RECV:
3198     case OP_ANDASSIGN:
3199     case OP_ORASSIGN:
3200     case OP_DORASSIGN:
3201         return TRUE;
3202     default:
3203         return FALSE;
3204     }
3205 }
3206
3207 STATIC bool
3208 S_is_handle_constructor(const OP *o, I32 numargs)
3209 {
3210     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
3211
3212     switch (o->op_type) {
3213     case OP_PIPE_OP:
3214     case OP_SOCKPAIR:
3215         if (numargs == 2)
3216             return TRUE;
3217         /* FALLTHROUGH */
3218     case OP_SYSOPEN:
3219     case OP_OPEN:
3220     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
3221     case OP_SOCKET:
3222     case OP_OPEN_DIR:
3223     case OP_ACCEPT:
3224         if (numargs == 1)
3225             return TRUE;
3226         /* FALLTHROUGH */
3227     default:
3228         return FALSE;
3229     }
3230 }
3231
3232 static OP *
3233 S_refkids(pTHX_ OP *o, I32 type)
3234 {
3235     if (o && o->op_flags & OPf_KIDS) {
3236         OP *kid;
3237         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3238             ref(kid, type);
3239     }
3240     return o;
3241 }
3242
3243 OP *
3244 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
3245 {
3246     dVAR;
3247     OP *kid;
3248
3249     PERL_ARGS_ASSERT_DOREF;
3250
3251     if (!o || (PL_parser && PL_parser->error_count))
3252         return o;
3253
3254     switch (o->op_type) {
3255     case OP_ENTERSUB:
3256         if ((type == OP_EXISTS || type == OP_DEFINED) &&
3257             !(o->op_flags & OPf_STACKED)) {
3258             CHANGE_TYPE(o, OP_RV2CV);             /* entersub => rv2cv */
3259             assert(cUNOPo->op_first->op_type == OP_NULL);
3260             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
3261             o->op_flags |= OPf_SPECIAL;
3262         }
3263         else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
3264             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3265                               : type == OP_RV2HV ? OPpDEREF_HV
3266                               : OPpDEREF_SV);
3267             o->op_flags |= OPf_MOD;
3268         }
3269
3270         break;
3271
3272     case OP_COND_EXPR:
3273         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
3274             doref(kid, type, set_op_ref);
3275         break;
3276     case OP_RV2SV:
3277         if (type == OP_DEFINED)
3278             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
3279         doref(cUNOPo->op_first, o->op_type, set_op_ref);
3280         /* FALLTHROUGH */
3281     case OP_PADSV:
3282         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3283             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3284                               : type == OP_RV2HV ? OPpDEREF_HV
3285                               : OPpDEREF_SV);
3286             o->op_flags |= OPf_MOD;
3287         }
3288         break;
3289
3290     case OP_RV2AV:
3291     case OP_RV2HV:
3292         if (set_op_ref)
3293             o->op_flags |= OPf_REF;
3294         /* FALLTHROUGH */
3295     case OP_RV2GV:
3296         if (type == OP_DEFINED)
3297             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
3298         doref(cUNOPo->op_first, o->op_type, set_op_ref);
3299         break;
3300
3301     case OP_PADAV:
3302     case OP_PADHV:
3303         if (set_op_ref)
3304             o->op_flags |= OPf_REF;
3305         break;
3306
3307     case OP_SCALAR:
3308     case OP_NULL:
3309         if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
3310             break;
3311         doref(cBINOPo->op_first, type, set_op_ref);
3312         break;
3313     case OP_AELEM:
3314     case OP_HELEM:
3315         doref(cBINOPo->op_first, o->op_type, set_op_ref);
3316         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3317             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3318                               : type == OP_RV2HV ? OPpDEREF_HV
3319                               : OPpDEREF_SV);
3320             o->op_flags |= OPf_MOD;
3321         }
3322         break;
3323
3324     case OP_SCOPE:
3325     case OP_LEAVE:
3326         set_op_ref = FALSE;
3327         /* FALLTHROUGH */
3328     case OP_ENTER:
3329     case OP_LIST:
3330         if (!(o->op_flags & OPf_KIDS))
3331             break;
3332         doref(cLISTOPo->op_last, type, set_op_ref);
3333         break;
3334     default:
3335         break;
3336     }
3337     return scalar(o);
3338
3339 }
3340
3341 STATIC OP *
3342 S_dup_attrlist(pTHX_ OP *o)
3343 {
3344     OP *rop;
3345
3346     PERL_ARGS_ASSERT_DUP_ATTRLIST;
3347
3348     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
3349      * where the first kid is OP_PUSHMARK and the remaining ones
3350      * are OP_CONST.  We need to push the OP_CONST values.
3351      */
3352     if (o->op_type == OP_CONST)
3353         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
3354     else {
3355         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
3356         rop = NULL;
3357         for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
3358             if (o->op_type == OP_CONST)
3359                 rop = op_append_elem(OP_LIST, rop,
3360                                   newSVOP(OP_CONST, o->op_flags,
3361                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
3362         }
3363     }
3364     return rop;
3365 }
3366
3367 STATIC void
3368 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
3369 {
3370     SV * const stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
3371
3372     PERL_ARGS_ASSERT_APPLY_ATTRS;
3373
3374     /* fake up C<use attributes $pkg,$rv,@attrs> */
3375
3376 #define ATTRSMODULE "attributes"
3377 #define ATTRSMODULE_PM "attributes.pm"
3378
3379     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3380                          newSVpvs(ATTRSMODULE),
3381                          NULL,
3382                          op_prepend_elem(OP_LIST,
3383                                       newSVOP(OP_CONST, 0, stashsv),
3384                                       op_prepend_elem(OP_LIST,
3385                                                    newSVOP(OP_CONST, 0,
3386                                                            newRV(target)),
3387                                                    dup_attrlist(attrs))));
3388 }
3389
3390 STATIC void
3391 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
3392 {
3393     OP *pack, *imop, *arg;
3394     SV *meth, *stashsv, **svp;
3395
3396     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
3397
3398     if (!attrs)
3399         return;
3400
3401     assert(target->op_type == OP_PADSV ||
3402            target->op_type == OP_PADHV ||
3403            target->op_type == OP_PADAV);
3404
3405     /* Ensure that attributes.pm is loaded. */
3406     /* Don't force the C<use> if we don't need it. */
3407     svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
3408     if (svp && *svp != &PL_sv_undef)
3409         NOOP;   /* already in %INC */
3410     else
3411         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
3412                                newSVpvs(ATTRSMODULE), NULL);
3413
3414     /* Need package name for method call. */
3415     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
3416
3417     /* Build up the real arg-list. */
3418     stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
3419
3420     arg = newOP(OP_PADSV, 0);
3421     arg->op_targ = target->op_targ;
3422     arg = op_prepend_elem(OP_LIST,
3423                        newSVOP(OP_CONST, 0, stashsv),
3424                        op_prepend_elem(OP_LIST,
3425                                     newUNOP(OP_REFGEN, 0,
3426                                             op_lvalue(arg, OP_REFGEN)),
3427                                     dup_attrlist(attrs)));
3428
3429     /* Fake up a method call to import */
3430     meth = newSVpvs_share("import");
3431     imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
3432                    op_append_elem(OP_LIST,
3433                                op_prepend_elem(OP_LIST, pack, arg),
3434                                newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
3435
3436     /* Combine the ops. */
3437     *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
3438 }
3439
3440 /*
3441 =notfor apidoc apply_attrs_string
3442
3443 Attempts to apply a list of attributes specified by the C<attrstr> and
3444 C<len> arguments to the subroutine identified by the C<cv> argument which
3445 is expected to be associated with the package identified by the C<stashpv>
3446 argument (see L<attributes>).  It gets this wrong, though, in that it
3447 does not correctly identify the boundaries of the individual attribute
3448 specifications within C<attrstr>.  This is not really intended for the
3449 public API, but has to be listed here for systems such as AIX which
3450 need an explicit export list for symbols.  (It's called from XS code
3451 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
3452 to respect attribute syntax properly would be welcome.
3453
3454 =cut
3455 */
3456
3457 void
3458 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
3459                         const char *attrstr, STRLEN len)
3460 {
3461     OP *attrs = NULL;
3462
3463     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
3464
3465     if (!len) {
3466         len = strlen(attrstr);
3467     }
3468
3469     while (len) {
3470         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
3471         if (len) {
3472             const char * const sstr = attrstr;
3473             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
3474             attrs = op_append_elem(OP_LIST, attrs,
3475                                 newSVOP(OP_CONST, 0,
3476                                         newSVpvn(sstr, attrstr-sstr)));
3477         }
3478     }
3479
3480     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3481                      newSVpvs(ATTRSMODULE),
3482                      NULL, op_prepend_elem(OP_LIST,
3483                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
3484                                   op_prepend_elem(OP_LIST,
3485                                                newSVOP(OP_CONST, 0,
3486                                                        newRV(MUTABLE_SV(cv))),
3487                                                attrs)));
3488 }
3489
3490 STATIC void
3491 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
3492 {
3493     OP *new_proto = NULL;
3494     STRLEN pvlen;
3495     char *pv;
3496     OP *o;
3497
3498     PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
3499
3500     if (!*attrs)
3501         return;
3502
3503     o = *attrs;
3504     if (o->op_type == OP_CONST) {
3505         pv = SvPV(cSVOPo_sv, pvlen);
3506         if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3507             SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3508             SV ** const tmpo = cSVOPx_svp(o);
3509             SvREFCNT_dec(cSVOPo_sv);
3510             *tmpo = tmpsv;
3511             new_proto = o;
3512             *attrs = NULL;
3513         }
3514     } else if (o->op_type == OP_LIST) {
3515         OP * lasto;
3516         assert(o->op_flags & OPf_KIDS);
3517         lasto = cLISTOPo->op_first;
3518         assert(lasto->op_type == OP_PUSHMARK);
3519         for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
3520             if (o->op_type == OP_CONST) {
3521                 pv = SvPV(cSVOPo_sv, pvlen);
3522                 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3523                     SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3524                     SV ** const tmpo = cSVOPx_svp(o);
3525                     SvREFCNT_dec(cSVOPo_sv);
3526                     *tmpo = tmpsv;
3527                     if (new_proto && ckWARN(WARN_MISC)) {
3528                         STRLEN new_len;
3529                         const char * newp = SvPV(cSVOPo_sv, new_len);
3530                         Perl_warner(aTHX_ packWARN(WARN_MISC),
3531                             "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub",
3532                             UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
3533                         op_free(new_proto);
3534                     }
3535                     else if (new_proto)
3536                         op_free(new_proto);
3537                     new_proto = o;
3538                     /* excise new_proto from the list */
3539                     op_sibling_splice(*attrs, lasto, 1, NULL);
3540                     o = lasto;
3541                     continue;
3542                 }
3543             }
3544             lasto = o;
3545         }
3546         /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
3547            would get pulled in with no real need */
3548         if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
3549             op_free(*attrs);
3550             *attrs = NULL;
3551         }
3552     }
3553
3554     if (new_proto) {
3555         SV *svname;
3556         if (isGV(name)) {
3557             svname = sv_newmortal();
3558             gv_efullname3(svname, name, NULL);
3559         }
3560         else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
3561             svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
3562         else
3563             svname = (SV *)name;
3564         if (ckWARN(WARN_ILLEGALPROTO))
3565             (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
3566         if (*proto && ckWARN(WARN_PROTOTYPE)) {
3567             STRLEN old_len, new_len;
3568             const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
3569             const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
3570
3571             Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3572                 "Prototype '%"UTF8f"' overridden by attribute 'prototype(%"UTF8f")'"
3573                 " in %"SVf,
3574                 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
3575                 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
3576                 SVfARG(svname));
3577         }
3578         if (*proto)
3579             op_free(*proto);
3580         *proto = new_proto;
3581     }
3582 }
3583
3584 static void
3585 S_cant_declare(pTHX_ OP *o)
3586 {
3587     if (o->op_type == OP_NULL
3588      && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
3589         o = cUNOPo->op_first;
3590     yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
3591                              o->op_type == OP_NULL
3592                                && o->op_flags & OPf_SPECIAL
3593                                  ? "do block"
3594                                  : OP_DESC(o),
3595                              PL_parser->in_my == KEY_our   ? "our"   :
3596                              PL_parser->in_my == KEY_state ? "state" :
3597                                                              "my"));
3598 }
3599
3600 STATIC OP *
3601 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
3602 {
3603     I32 type;
3604     const bool stately = PL_parser && PL_parser->in_my == KEY_state;
3605
3606     PERL_ARGS_ASSERT_MY_KID;
3607
3608     if (!o || (PL_parser && PL_parser->error_count))
3609         return o;
3610
3611     type = o->op_type;
3612
3613     if (type == OP_LIST) {
3614         OP *kid;
3615         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3616             my_kid(kid, attrs, imopsp);
3617         return o;
3618     } else if (type == OP_UNDEF || type == OP_STUB) {
3619         return o;
3620     } else if (type == OP_RV2SV ||      /* "our" declaration */
3621                type == OP_RV2AV ||
3622                type == OP_RV2HV) { /* XXX does this let anything illegal in? */
3623         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
3624             S_cant_declare(aTHX_ o);
3625         } else if (attrs) {
3626             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
3627             assert(PL_parser);
3628             PL_parser->in_my = FALSE;
3629             PL_parser->in_my_stash = NULL;
3630             apply_attrs(GvSTASH(gv),
3631                         (type == OP_RV2SV ? GvSV(gv) :
3632                          type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
3633                          type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
3634                         attrs);
3635         }
3636         o->op_private |= OPpOUR_INTRO;
3637         return o;
3638     }
3639     else if (type != OP_PADSV &&
3640              type != OP_PADAV &&
3641              type != OP_PADHV &&
3642              type != OP_PUSHMARK)
3643     {
3644         S_cant_declare(aTHX_ o);
3645         return o;
3646     }
3647     else if (attrs && type != OP_PUSHMARK) {
3648         HV *stash;
3649
3650         assert(PL_parser);
3651         PL_parser->in_my = FALSE;
3652         PL_parser->in_my_stash = NULL;
3653
3654         /* check for C<my Dog $spot> when deciding package */
3655         stash = PAD_COMPNAME_TYPE(o->op_targ);
3656         if (!stash)
3657             stash = PL_curstash;
3658         apply_attrs_my(stash, o, attrs, imopsp);
3659     }
3660     o->op_flags |= OPf_MOD;
3661     o->op_private |= OPpLVAL_INTRO;
3662     if (stately)
3663         o->op_private |= OPpPAD_STATE;
3664     return o;
3665 }
3666
3667 OP *
3668 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
3669 {
3670     OP *rops;
3671     int maybe_scalar = 0;
3672
3673     PERL_ARGS_ASSERT_MY_ATTRS;
3674
3675 /* [perl #17376]: this appears to be premature, and results in code such as
3676    C< our(%x); > executing in list mode rather than void mode */
3677 #if 0
3678     if (o->op_flags & OPf_PARENS)
3679         list(o);
3680     else
3681         maybe_scalar = 1;
3682 #else
3683     maybe_scalar = 1;
3684 #endif
3685     if (attrs)
3686         SAVEFREEOP(attrs);
3687     rops = NULL;
3688     o = my_kid(o, attrs, &rops);
3689     if (rops) {
3690         if (maybe_scalar && o->op_type == OP_PADSV) {
3691             o = scalar(op_append_list(OP_LIST, rops, o));
3692             o->op_private |= OPpLVAL_INTRO;
3693         }
3694         else {
3695             /* The listop in rops might have a pushmark at the beginning,
3696                which will mess up list assignment. */
3697             LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
3698             if (rops->op_type == OP_LIST &&
3699                 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
3700             {
3701                 OP * const pushmark = lrops->op_first;
3702                 /* excise pushmark */
3703                 op_sibling_splice(rops, NULL, 1, NULL);
3704                 op_free(pushmark);
3705             }
3706             o = op_append_list(OP_LIST, o, rops);
3707         }
3708     }
3709     PL_parser->in_my = FALSE;
3710     PL_parser->in_my_stash = NULL;
3711     return o;
3712 }
3713
3714 OP *
3715 Perl_sawparens(pTHX_ OP *o)
3716 {
3717     PERL_UNUSED_CONTEXT;
3718     if (o)
3719         o->op_flags |= OPf_PARENS;
3720     return o;
3721 }
3722
3723 OP *
3724 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
3725 {
3726     OP *o;
3727     bool ismatchop = 0;
3728     const OPCODE ltype = left->op_type;
3729     const OPCODE rtype = right->op_type;
3730
3731     PERL_ARGS_ASSERT_BIND_MATCH;
3732
3733     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
3734           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
3735     {
3736       const char * const desc
3737           = PL_op_desc[(
3738                           rtype == OP_SUBST || rtype == OP_TRANS
3739                        || rtype == OP_TRANSR
3740                        )
3741                        ? (int)rtype : OP_MATCH];
3742       const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
3743       SV * const name =
3744         S_op_varname(aTHX_ left);
3745       if (name)
3746         Perl_warner(aTHX_ packWARN(WARN_MISC),
3747              "Applying %s to %"SVf" will act on scalar(%"SVf")",
3748              desc, SVfARG(name), SVfARG(name));
3749       else {
3750         const char * const sample = (isary
3751              ? "@array" : "%hash");
3752         Perl_warner(aTHX_ packWARN(WARN_MISC),
3753              "Applying %s to %s will act on scalar(%s)",
3754              desc, sample, sample);
3755       }
3756     }
3757
3758     if (rtype == OP_CONST &&
3759         cSVOPx(right)->op_private & OPpCONST_BARE &&
3760         cSVOPx(right)->op_private & OPpCONST_STRICT)
3761     {
3762         no_bareword_allowed(right);
3763     }
3764
3765     /* !~ doesn't make sense with /r, so error on it for now */
3766     if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
3767         type == OP_NOT)
3768         /* diag_listed_as: Using !~ with %s doesn't make sense */
3769         yyerror("Using !~ with s///r doesn't make sense");
3770     if (rtype == OP_TRANSR && type == OP_NOT)
3771         /* diag_listed_as: Using !~ with %s doesn't make sense */
3772         yyerror("Using !~ with tr///r doesn't make sense");
3773
3774     ismatchop = (rtype == OP_MATCH ||
3775                  rtype == OP_SUBST ||
3776                  rtype == OP_TRANS || rtype == OP_TRANSR)
3777              && !(right->op_flags & OPf_SPECIAL);
3778     if (ismatchop && right->op_private & OPpTARGET_MY) {
3779         right->op_targ = 0;
3780         right->op_private &= ~OPpTARGET_MY;
3781     }
3782     if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
3783         if (left->op_type == OP_PADSV
3784          && !(left->op_private & OPpLVAL_INTRO))
3785         {
3786             right->op_targ = left->op_targ;
3787             op_free(left);
3788             o = right;
3789         }
3790         else {
3791             right->op_flags |= OPf_STACKED;
3792             if (rtype != OP_MATCH && rtype != OP_TRANSR &&
3793             ! (rtype == OP_TRANS &&
3794                right->op_private & OPpTRANS_IDENTICAL) &&
3795             ! (rtype == OP_SUBST &&
3796                (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3797                 left = op_lvalue(left, rtype);
3798             if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
3799                 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
3800             else
3801                 o = op_prepend_elem(rtype, scalar(left), right);
3802         }
3803         if (type == OP_NOT)
3804             return newUNOP(OP_NOT, 0, scalar(o));
3805         return o;
3806     }
3807     else
3808         return bind_match(type, left,
3809                 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
3810 }
3811
3812 OP *
3813 Perl_invert(pTHX_ OP *o)
3814 {
3815     if (!o)
3816         return NULL;
3817     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
3818 }
3819
3820 /*
3821 =for apidoc Amx|OP *|op_scope|OP *o
3822
3823 Wraps up an op tree with some additional ops so that at runtime a dynamic
3824 scope will be created.  The original ops run in the new dynamic scope,
3825 and then, provided that they exit normally, the scope will be unwound.
3826 The additional ops used to create and unwind the dynamic scope will
3827 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
3828 instead if the ops are simple enough to not need the full dynamic scope
3829 structure.
3830
3831 =cut
3832 */
3833
3834 OP *
3835 Perl_op_scope(pTHX_ OP *o)
3836 {
3837     dVAR;
3838     if (o) {
3839         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
3840             o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
3841             CHANGE_TYPE(o, OP_LEAVE);
3842         }
3843         else if (o->op_type == OP_LINESEQ) {
3844             OP *kid;
3845             CHANGE_TYPE(o, OP_SCOPE);
3846             kid = ((LISTOP*)o)->op_first;
3847             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
3848                 op_null(kid);
3849
3850                 /* The following deals with things like 'do {1 for 1}' */
3851                 kid = OpSIBLING(kid);
3852                 if (kid &&
3853                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
3854                     op_null(kid);
3855             }
3856         }
3857         else
3858             o = newLISTOP(OP_SCOPE, 0, o, NULL);
3859     }
3860     return o;
3861 }
3862
3863 OP *
3864 Perl_op_unscope(pTHX_ OP *o)
3865 {
3866     if (o && o->op_type == OP_LINESEQ) {
3867         OP *kid = cLISTOPo->op_first;
3868         for(; kid; kid = OpSIBLING(kid))
3869             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
3870                 op_null(kid);
3871     }
3872     return o;
3873 }
3874
3875 /*
3876 =for apidoc Am|int|block_start|int full
3877
3878 Handles compile-time scope entry.
3879 Arranges for hints to be restored on block
3880 exit and also handles pad sequence numbers to make lexical variables scope
3881 right.  Returns a savestack index for use with C<block_end>.
3882
3883 =cut
3884 */
3885
3886 int
3887 Perl_block_start(pTHX_ int full)
3888 {
3889     const int retval = PL_savestack_ix;
3890
3891     PL_compiling.cop_seq = PL_cop_seqmax;
3892     COP_SEQMAX_INC;
3893     pad_block_start(full);
3894     SAVEHINTS();
3895     PL_hints &= ~HINT_BLOCK_SCOPE;
3896     SAVECOMPILEWARNINGS();
3897     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
3898     SAVEI32(PL_compiling.cop_seq);
3899     PL_compiling.cop_seq = 0;
3900
3901     CALL_BLOCK_HOOKS(bhk_start, full);
3902
3903     return retval;
3904 }
3905
3906 /*
3907 =for apidoc Am|OP *|block_end|I32 floor|OP *seq
3908
3909 Handles compile-time scope exit.  I<floor>
3910 is the savestack index returned by
3911 C<block_start>, and I<seq> is the body of the block.  Returns the block,
3912 possibly modified.
3913
3914 =cut
3915 */
3916
3917 OP*
3918 Perl_block_end(pTHX_ I32 floor, OP *seq)
3919 {
3920     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
3921     OP* retval = scalarseq(seq);
3922     OP *o;
3923
3924     /* XXX Is the null PL_parser check necessary here? */
3925     assert(PL_parser); /* Let’s find out under debugging builds.  */
3926     if (PL_parser && PL_parser->parsed_sub) {
3927         o = newSTATEOP(0, NULL, NULL);
3928         op_null(o);
3929         retval = op_append_elem(OP_LINESEQ, retval, o);
3930     }
3931
3932     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
3933
3934     LEAVE_SCOPE(floor);
3935     if (needblockscope)
3936         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
3937     o = pad_leavemy();
3938
3939     if (o) {
3940         /* pad_leavemy has created a sequence of introcv ops for all my
3941            subs declared in the block.  We have to replicate that list with
3942            clonecv ops, to deal with this situation:
3943
3944                sub {
3945                    my sub s1;
3946                    my sub s2;
3947                    sub s1 { state sub foo { \&s2 } }
3948                }->()
3949
3950            Originally, I was going to have introcv clone the CV and turn
3951            off the stale flag.  Since &s1 is declared before &s2, the
3952            introcv op for &s1 is executed (on sub entry) before the one for
3953            &s2.  But the &foo sub inside &s1 (which is cloned when &s1 is
3954            cloned, since it is a state sub) closes over &s2 and expects
3955            to see it in its outer CV’s pad.  If the introcv op clones &s1,
3956            then &s2 is still marked stale.  Since &s1 is not active, and
3957            &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
3958            ble will not stay shared’ warning.  Because it is the same stub
3959            that will be used when the introcv op for &s2 is executed, clos-
3960            ing over it is safe.  Hence, we have to turn off the stale flag
3961            on all lexical subs in the block before we clone any of them.
3962            Hence, having introcv clone the sub cannot work.  So we create a
3963            list of ops like this:
3964
3965                lineseq
3966                   |
3967                   +-- introcv
3968                   |
3969                   +-- introcv
3970                   |
3971                   +-- introcv
3972                   |
3973                   .
3974                   .
3975                   .
3976                   |
3977                   +-- clonecv
3978                   |
3979                   +-- clonecv
3980                   |
3981                   +-- clonecv
3982                   |
3983                   .
3984                   .
3985                   .
3986          */
3987         OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
3988         OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
3989         for (;; kid = OpSIBLING(kid)) {
3990             OP *newkid = newOP(OP_CLONECV, 0);
3991             newkid->op_targ = kid->op_targ;
3992             o = op_append_elem(OP_LINESEQ, o, newkid);
3993             if (kid == last) break;
3994         }
3995         retval = op_prepend_elem(OP_LINESEQ, o, retval);
3996     }
3997
3998     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
3999
4000     return retval;
4001 }
4002
4003 /*
4004 =head1 Compile-time scope hooks
4005
4006 =for apidoc Aox||blockhook_register
4007
4008 Register a set of hooks to be called when the Perl lexical scope changes
4009 at compile time.  See L<perlguts/"Compile-time scope hooks">.
4010
4011 =cut
4012 */
4013
4014 void
4015 Perl_blockhook_register(pTHX_ BHK *hk)
4016 {
4017     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
4018
4019     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
4020 }
4021
4022 void
4023 Perl_newPROG(pTHX_ OP *o)
4024 {
4025     PERL_ARGS_ASSERT_NEWPROG;
4026
4027     if (PL_in_eval) {
4028         PERL_CONTEXT *cx;
4029         I32 i;
4030         if (PL_eval_root)
4031                 return;
4032         PL_eval_root = newUNOP(OP_LEAVEEVAL,
4033                                ((PL_in_eval & EVAL_KEEPERR)
4034                                 ? OPf_SPECIAL : 0), o);
4035
4036         cx = &cxstack[cxstack_ix];
4037         assert(CxTYPE(cx) == CXt_EVAL);
4038
4039         if ((cx->blk_gimme & G_WANT) == G_VOID)
4040             scalarvoid(PL_eval_root);
4041         else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
4042             list(PL_eval_root);
4043         else
4044             scalar(PL_eval_root);
4045
4046         PL_eval_start = op_linklist(PL_eval_root);
4047         PL_eval_root->op_private |= OPpREFCOUNTED;
4048         OpREFCNT_set(PL_eval_root, 1);
4049         PL_eval_root->op_next = 0;
4050         i = PL_savestack_ix;
4051         SAVEFREEOP(o);
4052         ENTER;
4053         CALL_PEEP(PL_eval_start);
4054         finalize_optree(PL_eval_root);
4055         S_prune_chain_head(&PL_eval_start);
4056         LEAVE;
4057         PL_savestack_ix = i;
4058     }
4059     else {
4060         if (o->op_type == OP_STUB) {
4061             /* This block is entered if nothing is compiled for the main
4062                program. This will be the case for an genuinely empty main
4063                program, or one which only has BEGIN blocks etc, so already
4064                run and freed.
4065
4066                Historically (5.000) the guard above was !o. However, commit
4067                f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
4068                c71fccf11fde0068, changed perly.y so that newPROG() is now
4069                called with the output of block_end(), which returns a new
4070                OP_STUB for the case of an empty optree. ByteLoader (and
4071                maybe other things) also take this path, because they set up
4072                PL_main_start and PL_main_root directly, without generating an
4073                optree.
4074
4075                If the parsing the main program aborts (due to parse errors,
4076                or due to BEGIN or similar calling exit), then newPROG()
4077                isn't even called, and hence this code path and its cleanups
4078                are skipped. This shouldn't make a make a difference:
4079                * a non-zero return from perl_parse is a failure, and
4080                  perl_destruct() should be called immediately.
4081                * however, if exit(0) is called during the parse, then
4082                  perl_parse() returns 0, and perl_run() is called. As
4083                  PL_main_start will be NULL, perl_run() will return
4084                  promptly, and the exit code will remain 0.
4085             */
4086
4087             PL_comppad_name = 0;
4088             PL_compcv = 0;
4089             S_op_destroy(aTHX_ o);
4090             return;
4091         }
4092         PL_main_root = op_scope(sawparens(scalarvoid(o)));
4093         PL_curcop = &PL_compiling;
4094         PL_main_start = LINKLIST(PL_main_root);
4095         PL_main_root->op_private |= OPpREFCOUNTED;
4096         OpREFCNT_set(PL_main_root, 1);
4097         PL_main_root->op_next = 0;
4098         CALL_PEEP(PL_main_start);
4099         finalize_optree(PL_main_root);
4100         S_prune_chain_head(&PL_main_start);
4101         cv_forget_slab(PL_compcv);
4102         PL_compcv = 0;
4103
4104         /* Register with debugger */
4105         if (PERLDB_INTER) {
4106             CV * const cv = get_cvs("DB::postponed", 0);
4107             if (cv) {
4108                 dSP;
4109                 PUSHMARK(SP);
4110                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
4111                 PUTBACK;
4112                 call_sv(MUTABLE_SV(cv), G_DISCARD);
4113             }
4114         }
4115     }
4116 }
4117
4118 OP *
4119 Perl_localize(pTHX_ OP *o, I32 lex)
4120 {
4121     PERL_ARGS_ASSERT_LOCALIZE;
4122
4123     if (o->op_flags & OPf_PARENS)
4124 /* [perl #17376]: this appears to be premature, and results in code such as
4125    C< our(%x); > executing in list mode rather than void mode */
4126 #if 0
4127         list(o);
4128 #else
4129         NOOP;
4130 #endif
4131     else {
4132         if ( PL_parser->bufptr > PL_parser->oldbufptr
4133             && PL_parser->bufptr[-1] == ','
4134             && ckWARN(WARN_PARENTHESIS))
4135         {
4136             char *s = PL_parser->bufptr;
4137             bool sigil = FALSE;
4138
4139             /* some heuristics to detect a potential error */
4140             while (*s && (strchr(", \t\n", *s)))
4141                 s++;
4142
4143             while (1) {
4144                 if (*s && strchr("@$%*", *s) && *++s
4145                        && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
4146                     s++;
4147                     sigil = TRUE;
4148                     while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
4149                         s++;
4150                     while (*s && (strchr(", \t\n", *s)))
4151                         s++;
4152                 }
4153                 else
4154                     break;
4155             }
4156             if (sigil && (*s == ';' || *s == '=')) {
4157                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
4158                                 "Parentheses missing around \"%s\" list",
4159                                 lex
4160                                     ? (PL_parser->in_my == KEY_our
4161                                         ? "our"
4162                                         : PL_parser->in_my == KEY_state
4163                                             ? "state"
4164                                             : "my")
4165                                     : "local");
4166             }
4167         }
4168     }
4169     if (lex)
4170         o = my(o);
4171     else
4172         o = op_lvalue(o, OP_NULL);              /* a bit kludgey */
4173     PL_parser->in_my = FALSE;
4174     PL_parser->in_my_stash = NULL;
4175     return o;
4176 }
4177
4178 OP *
4179 Perl_jmaybe(pTHX_ OP *o)
4180 {
4181     PERL_ARGS_ASSERT_JMAYBE;
4182
4183     if (o->op_type == OP_LIST) {
4184         OP * const o2
4185             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
4186         o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
4187     }
4188     return o;
4189 }
4190
4191 PERL_STATIC_INLINE OP *
4192 S_op_std_init(pTHX_ OP *o)
4193 {
4194     I32 type = o->op_type;
4195
4196     PERL_ARGS_ASSERT_OP_STD_INIT;
4197
4198     if (PL_opargs[type] & OA_RETSCALAR)
4199         scalar(o);
4200     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
4201         o->op_targ = pad_alloc(type, SVs_PADTMP);
4202
4203     return o;
4204 }
4205
4206 PERL_STATIC_INLINE OP *
4207 S_op_integerize(pTHX_ OP *o)
4208 {
4209     I32 type = o->op_type;
4210
4211     PERL_ARGS_ASSERT_OP_INTEGERIZE;
4212
4213     /* integerize op. */
4214     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
4215     {
4216         dVAR;
4217         o->op_ppaddr = PL_ppaddr[++(o->op_type)];
4218     }
4219
4220     if (type == OP_NEGATE)
4221         /* XXX might want a ck_negate() for this */
4222         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
4223
4224     return o;
4225 }
4226
4227 static OP *
4228 S_fold_constants(pTHX_ OP *o)
4229 {
4230     dVAR;
4231     OP * VOL curop;
4232     OP *newop;
4233     VOL I32 type = o->op_type;
4234     bool is_stringify;
4235     SV * VOL sv = NULL;
4236     int ret = 0;
4237     I32 oldscope;
4238     OP *old_next;
4239     SV * const oldwarnhook = PL_warnhook;
4240     SV * const olddiehook  = PL_diehook;
4241     COP not_compiling;
4242     U8 oldwarn = PL_dowarn;
4243     dJMPENV;
4244
4245     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
4246
4247     if (!(PL_opargs[type] & OA_FOLDCONST))
4248         goto nope;
4249
4250     switch (type) {
4251     case OP_UCFIRST:
4252     case OP_LCFIRST:
4253     case OP_UC:
4254     case OP_LC:
4255     case OP_FC:
4256 #ifdef USE_LOCALE_CTYPE
4257         if (IN_LC_COMPILETIME(LC_CTYPE))
4258             goto nope;
4259 #endif
4260         break;
4261     case OP_SLT:
4262     case OP_SGT:
4263     case OP_SLE:
4264     case OP_SGE:
4265     case OP_SCMP:
4266 #ifdef USE_LOCALE_COLLATE
4267         if (IN_LC_COMPILETIME(LC_COLLATE))
4268             goto nope;
4269 #endif
4270         break;
4271     case OP_SPRINTF:
4272         /* XXX what about the numeric ops? */
4273 #ifdef USE_LOCALE_NUMERIC
4274         if (IN_LC_COMPILETIME(LC_NUMERIC))
4275             goto nope;
4276 #endif
4277         break;
4278     case OP_PACK:
4279         if (!OpHAS_SIBLING(cLISTOPo->op_first)
4280           || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
4281             goto nope;
4282         {
4283             SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
4284             if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
4285             {
4286                 const char *s = SvPVX_const(sv);
4287                 while (s < SvEND(sv)) {
4288                     if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
4289                     s++;
4290                 }
4291             }
4292         }
4293         break;
4294     case OP_REPEAT:
4295         if (o->op_private & OPpREPEAT_DOLIST) goto nope;
4296         break;
4297     case OP_SREFGEN:
4298         if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
4299          || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
4300             goto nope;
4301     }
4302
4303     if (PL_parser && PL_parser->error_count)
4304         goto nope;              /* Don't try to run w/ errors */
4305
4306     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4307         const OPCODE type = curop->op_type;
4308         if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
4309             type != OP_LIST &&
4310             type != OP_SCALAR &&
4311             type != OP_NULL &&
4312             type != OP_PUSHMARK)
4313         {
4314             goto nope;
4315         }
4316     }
4317
4318     curop = LINKLIST(o);
4319     old_next = o->op_next;
4320     o->op_next = 0;
4321     PL_op = curop;
4322
4323     oldscope = PL_scopestack_ix;
4324     create_eval_scope(G_FAKINGEVAL);
4325
4326     /* Verify that we don't need to save it:  */
4327     assert(PL_curcop == &PL_compiling);
4328     StructCopy(&PL_compiling, &not_compiling, COP);
4329     PL_curcop = &not_compiling;
4330     /* The above ensures that we run with all the correct hints of the
4331        currently compiling COP, but that IN_PERL_RUNTIME is true. */
4332     assert(IN_PERL_RUNTIME);
4333     PL_warnhook = PERL_WARNHOOK_FATAL;
4334     PL_diehook  = NULL;
4335     JMPENV_PUSH(ret);
4336
4337     /* Effective $^W=1.  */
4338     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
4339         PL_dowarn |= G_WARN_ON;
4340
4341     switch (ret) {
4342     case 0:
4343         CALLRUNOPS(aTHX);
4344         sv = *(PL_stack_sp--);
4345         if (o->op_targ && sv == PAD_SV(o->op_targ)) {   /* grab pad temp? */
4346             pad_swipe(o->op_targ,  FALSE);
4347         }
4348         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
4349             SvREFCNT_inc_simple_void(sv);
4350             SvTEMP_off(sv);
4351         }
4352         else { assert(SvIMMORTAL(sv)); }
4353         break;
4354     case 3:
4355         /* Something tried to die.  Abandon constant folding.  */
4356         /* Pretend the error never happened.  */
4357         CLEAR_ERRSV();
4358         o->op_next = old_next;
4359         break;
4360     default:
4361         JMPENV_POP;
4362         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
4363         PL_warnhook = oldwarnhook;
4364         PL_diehook  = olddiehook;
4365         /* XXX note that this croak may fail as we've already blown away
4366          * the stack - eg any nested evals */
4367         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
4368     }
4369     JMPENV_POP;
4370     PL_dowarn   = oldwarn;
4371     PL_warnhook = oldwarnhook;
4372     PL_diehook  = olddiehook;
4373     PL_curcop = &PL_compiling;
4374
4375     if (PL_scopestack_ix > oldscope)
4376         delete_eval_scope();
4377
4378     if (ret)
4379         goto nope;
4380
4381     /* OP_STRINGIFY and constant folding are used to implement qq.
4382        Here the constant folding is an implementation detail that we
4383        want to hide.  If the stringify op is itself already marked
4384        folded, however, then it is actually a folded join.  */
4385     is_stringify = type == OP_STRINGIFY && !o->op_folded;
4386     op_free(o);
4387     assert(sv);
4388     if (is_stringify)
4389         SvPADTMP_off(sv);
4390     else if (!SvIMMORTAL(sv)) {
4391         SvPADTMP_on(sv);
4392         SvREADONLY_on(sv);
4393     }
4394     newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
4395     if (!is_stringify) newop->op_folded = 1;
4396     return newop;
4397
4398  nope:
4399     return o;
4400 }
4401
4402 static OP *
4403 S_gen_constant_list(pTHX_ OP *o)
4404 {
4405     dVAR;
4406     OP *curop;
4407     const SSize_t oldtmps_floor = PL_tmps_floor;
4408     SV **svp;
4409     AV *av;
4410
4411     list(o);
4412     if (PL_parser && PL_parser->error_count)
4413         return o;               /* Don't attempt to run with errors */
4414
4415     curop = LINKLIST(o);
4416     o->op_next = 0;
4417     CALL_PEEP(curop);
4418     S_prune_chain_head(&curop);
4419     PL_op = curop;
4420     Perl_pp_pushmark(aTHX);
4421     CALLRUNOPS(aTHX);
4422     PL_op = curop;
4423     assert (!(curop->op_flags & OPf_SPECIAL));
4424     assert(curop->op_type == OP_RANGE);
4425     Perl_pp_anonlist(aTHX);
4426     PL_tmps_floor = oldtmps_floor;
4427
4428     CHANGE_TYPE(o, OP_RV2AV);
4429     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
4430     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
4431     o->op_opt = 0;              /* needs to be revisited in rpeep() */
4432     av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
4433
4434     /* replace subtree with an OP_CONST */
4435     curop = ((UNOP*)o)->op_first;
4436     op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
4437     op_free(curop);
4438
4439     if (AvFILLp(av) != -1)
4440         for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
4441         {
4442             SvPADTMP_on(*svp);
4443             SvREADONLY_on(*svp);
4444         }
4445     LINKLIST(o);
4446     return list(o);
4447 }
4448
4449 /*
4450 =head1 Optree Manipulation Functions
4451 */
4452
4453 /* List constructors */
4454
4455 /*
4456 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
4457
4458 Append an item to the list of ops contained directly within a list-type
4459 op, returning the lengthened list.  I<first> is the list-type op,
4460 and I<last> is the op to append to the list.  I<optype> specifies the
4461 intended opcode for the list.  If I<first> is not already a list of the
4462 right type, it will be upgraded into one.  If either I<first> or I<last>
4463 is null, the other is returned unchanged.
4464
4465 =cut
4466 */
4467
4468 OP *
4469 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
4470 {
4471     if (!first)
4472         return last;
4473
4474     if (!last)
4475         return first;
4476
4477     if (first->op_type != (unsigned)type
4478         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
4479     {
4480         return newLISTOP(type, 0, first, last);
4481     }
4482
4483     op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
4484     first->op_flags |= OPf_KIDS;
4485     return first;
4486 }
4487
4488 /*
4489 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
4490
4491 Concatenate the lists of ops contained directly within two list-type ops,
4492 returning the combined list.  I<first> and I<last> are the list-type ops
4493 to concatenate.  I<optype> specifies the intended opcode for the list.
4494 If either I<first> or I<last> is not already a list of the right type,
4495 it will be upgraded into one.  If either I<first> or I<last> is null,
4496 the other is returned unchanged.
4497
4498 =cut
4499 */
4500
4501 OP *
4502 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
4503 {
4504     if (!first)
4505         return last;
4506
4507     if (!last)
4508         return first;
4509
4510     if (first->op_type != (unsigned)type)
4511         return op_prepend_elem(type, first, last);
4512
4513     if (last->op_type != (unsigned)type)
4514         return op_append_elem(type, first, last);
4515
4516     ((LISTOP*)first)->op_last->op_lastsib = 0;
4517     OpSIBLING_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
4518     ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
4519     ((LISTOP*)first)->op_last->op_lastsib = 1;
4520 #ifdef PERL_OP_PARENT
4521     ((LISTOP*)first)->op_last->op_sibling = first;
4522 #endif
4523     first->op_flags |= (last->op_flags & OPf_KIDS);
4524
4525
4526     S_op_destroy(aTHX_ last);
4527
4528     return first;
4529 }
4530
4531 /*
4532 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
4533
4534 Prepend an item to the list of ops contained directly within a list-type
4535 op, returning the lengthened list.  I<first> is the op to prepend to the
4536 list, and I<last> is the list-type op.  I<optype> specifies the intended
4537 opcode for the list.  If I<last> is not already a list of the right type,
4538 it will be upgraded into one.  If either I<first> or I<last> is null,
4539 the other is returned unchanged.
4540
4541 =cut
4542 */
4543
4544 OP *
4545 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
4546 {
4547     if (!first)
4548         return last;
4549
4550     if (!last)
4551         return first;
4552
4553     if (last->op_type == (unsigned)type) {
4554         if (type == OP_LIST) {  /* already a PUSHMARK there */
4555             /* insert 'first' after pushmark */
4556             op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
4557             if (!(first->op_flags & OPf_PARENS))
4558                 last->op_flags &= ~OPf_PARENS;
4559         }
4560         else
4561             op_sibling_splice(last, NULL, 0, first);
4562         last->op_flags |= OPf_KIDS;
4563         return last;
4564     }
4565
4566     return newLISTOP(type, 0, first, last);
4567 }
4568
4569 /*
4570 =for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
4571
4572 Converts I<o> into a list op if it is not one already, and then converts it
4573 into the specified I<type>, calling its check function, allocating a target if
4574 it needs one, and folding constants.
4575
4576 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
4577 C<op_prepend_elem> and C<op_append_elem>.  Then finally it is passed to
4578 C<op_convert_list> to make it the right type.
4579
4580 =cut
4581 */
4582
4583 OP *
4584 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
4585 {
4586     dVAR;
4587     if (type < 0) type = -type, flags |= OPf_SPECIAL;
4588     if (!o || o->op_type != OP_LIST)
4589         o = force_list(o, 0);
4590     else
4591         o->op_flags &= ~OPf_WANT;
4592
4593     if (!(PL_opargs[type] & OA_MARK))
4594         op_null(cLISTOPo->op_first);
4595     else {
4596         OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
4597         if (kid2 && kid2->op_type == OP_COREARGS) {
4598             op_null(cLISTOPo->op_first);
4599             kid2->op_private |= OPpCOREARGS_PUSHMARK;
4600         }
4601     }
4602
4603     CHANGE_TYPE(o, type);
4604     o->op_flags |= flags;
4605     if (flags & OPf_FOLDED)
4606         o->op_folded = 1;
4607
4608     o = CHECKOP(type, o);
4609     if (o->op_type != (unsigned)type)
4610         return o;
4611
4612     return fold_constants(op_integerize(op_std_init(o)));
4613 }
4614
4615 /* Constructors */
4616
4617
4618 /*
4619 =head1 Optree construction
4620
4621 =for apidoc Am|OP *|newNULLLIST
4622
4623 Constructs, checks, and returns a new C<stub> op, which represents an
4624 empty list expression.
4625
4626 =cut
4627 */
4628
4629 OP *
4630 Perl_newNULLLIST(pTHX)
4631 {
4632     return newOP(OP_STUB, 0);
4633 }
4634
4635 /* promote o and any siblings to be a list if its not already; i.e.
4636  *
4637  *  o - A - B
4638  *
4639  * becomes
4640  *
4641  *  list
4642  *    |
4643  *  pushmark - o - A - B
4644  *
4645  * If nullit it true, the list op is nulled.
4646  */
4647
4648 static OP *
4649 S_force_list(pTHX_ OP *o, bool nullit)
4650 {
4651     if (!o || o->op_type != OP_LIST) {
4652         OP *rest = NULL;
4653         if (o) {
4654             /* manually detach any siblings then add them back later */
4655             rest = OpSIBLING(o);
4656             OpSIBLING_set(o, NULL);
4657             o->op_lastsib = 1;
4658         }
4659         o = newLISTOP(OP_LIST, 0, o, NULL);
4660         if (rest)
4661             op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
4662     }
4663     if (nullit)
4664         op_null(o);
4665     return o;
4666 }
4667
4668 /*
4669 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
4670
4671 Constructs, checks, and returns an op of any list type.  I<type> is
4672 the opcode.  I<flags> gives the eight bits of C<op_flags>, except that
4673 C<OPf_KIDS> will be set automatically if required.  I<first> and I<last>
4674 supply up to two ops to be direct children of the list op; they are
4675 consumed by this function and become part of the constructed op tree.
4676
4677 For most list operators, the check function expects all the kid ops to be
4678 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.,) is not
4679 appropriate.  What you want to do in that case is create an op of type
4680 OP_LIST, append more children to it, and then call L</op_convert_list>.
4681 See L</op_convert_list> for more information.
4682
4683
4684 =cut
4685 */
4686
4687 OP *
4688 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4689 {
4690     dVAR;
4691     LISTOP *listop;
4692
4693     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
4694         || type == OP_CUSTOM);
4695
4696     NewOp(1101, listop, 1, LISTOP);
4697
4698     CHANGE_TYPE(listop, type);
4699     if (first || last)
4700         flags |= OPf_KIDS;
4701     listop->op_flags = (U8)flags;
4702
4703     if (!last && first)
4704         last = first;
4705     else if (!first && last)
4706         first = last;
4707     else if (first)
4708         OpSIBLING_set(first, last);
4709     listop->op_first = first;
4710     listop->op_last = last;
4711     if (type == OP_LIST) {
4712         OP* const pushop = newOP(OP_PUSHMARK, 0);
4713         pushop->op_lastsib = 0;
4714         OpSIBLING_set(pushop, first);
4715         listop->op_first = pushop;
4716         listop->op_flags |= OPf_KIDS;
4717         if (!last)
4718             listop->op_last = pushop;
4719     }
4720     if (first)
4721         first->op_lastsib = 0;
4722     if (listop->op_last) {
4723         listop->op_last->op_lastsib = 1;
4724 #ifdef PERL_OP_PARENT
4725         listop->op_last->op_sibling = (OP*)listop;
4726 #endif
4727     }
4728
4729     return CHECKOP(type, listop);
4730 }
4731
4732 /*
4733 =for apidoc Am|OP *|newOP|I32 type|I32 flags
4734
4735 Constructs, checks, and returns an op of any base type (any type that
4736 has no extra fields).  I<type> is the opcode.  I<flags> gives the
4737 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
4738 of C<op_private>.
4739
4740 =cut
4741 */
4742
4743 OP *
4744 Perl_newOP(pTHX_ I32 type, I32 flags)
4745 {
4746     dVAR;
4747     OP *o;
4748
4749     if (type == -OP_ENTEREVAL) {
4750         type = OP_ENTEREVAL;
4751         flags |= OPpEVAL_BYTES<<8;
4752     }
4753
4754     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
4755         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4756         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4757         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4758
4759     NewOp(1101, o, 1, OP);
4760     CHANGE_TYPE(o, type);
4761     o->op_flags = (U8)flags;
4762
4763     o->op_next = o;
4764     o->op_private = (U8)(0 | (flags >> 8));
4765     if (PL_opargs[type] & OA_RETSCALAR)
4766         scalar(o);
4767     if (PL_opargs[type] & OA_TARGET)
4768         o->op_targ = pad_alloc(type, SVs_PADTMP);
4769     return CHECKOP(type, o);
4770 }
4771
4772 /*
4773 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
4774
4775 Constructs, checks, and returns an op of any unary type.  I<type> is
4776 the opcode.  I<flags> gives the eight bits of C<op_flags>, except that
4777 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
4778 bits, the eight bits of C<op_private>, except that the bit with value 1
4779 is automatically set.  I<first> supplies an optional op to be the direct
4780 child of the unary op; it is consumed by this function and become part
4781 of the constructed op tree.
4782
4783 =cut
4784 */
4785
4786 OP *
4787 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
4788 {
4789     dVAR;
4790     UNOP *unop;
4791
4792     if (type == -OP_ENTEREVAL) {
4793         type = OP_ENTEREVAL;
4794         flags |= OPpEVAL_BYTES<<8;
4795     }
4796
4797     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
4798         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4799         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4800         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
4801         || type == OP_SASSIGN
4802         || type == OP_ENTERTRY
4803         || type == OP_CUSTOM
4804         || type == OP_NULL );
4805
4806     if (!first)
4807         first = newOP(OP_STUB, 0);
4808     if (PL_opargs[type] & OA_MARK)
4809         first = force_list(first, 1);
4810
4811     NewOp(1101, unop, 1, UNOP);
4812     CHANGE_TYPE(unop, type);
4813     unop->op_first = first;
4814     unop->op_flags = (U8)(flags | OPf_KIDS);
4815     unop->op_private = (U8)(1 | (flags >> 8));
4816
4817 #ifdef PERL_OP_PARENT
4818     if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
4819         first->op_sibling = (OP*)unop;
4820 #endif
4821
4822     unop = (UNOP*) CHECKOP(type, unop);
4823     if (unop->op_next)
4824         return (OP*)unop;
4825
4826     return fold_constants(op_integerize(op_std_init((OP *) unop)));
4827 }
4828
4829 /*
4830 =for apidoc newUNOP_AUX
4831
4832 Similar to C<newUNOP>, but creates an UNOP_AUX struct instead, with op_aux
4833 initialised to aux
4834
4835 =cut
4836 */
4837
4838 OP *
4839 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
4840 {
4841     dVAR;
4842     UNOP_AUX *unop;
4843
4844     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
4845         || type == OP_CUSTOM);
4846
4847     NewOp(1101, unop, 1, UNOP_AUX);
4848     unop->op_type = (OPCODE)type;
4849     unop->op_ppaddr = PL_ppaddr[type];
4850     unop->op_first = first;
4851     unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
4852     unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
4853     unop->op_aux = aux;
4854
4855 #ifdef PERL_OP_PARENT
4856     if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
4857         first->op_sibling = (OP*)unop;
4858 #endif
4859
4860     unop = (UNOP_AUX*) CHECKOP(type, unop);
4861
4862     return op_std_init((OP *) unop);
4863 }
4864
4865 /*
4866 =for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
4867
4868 Constructs, checks, and returns an op of method type with a method name
4869 evaluated at runtime.  I<type> is the opcode.  I<flags> gives the eight
4870 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
4871 and, shifted up eight bits, the eight bits of C<op_private>, except that
4872 the bit with value 1 is automatically set.  I<dynamic_meth> supplies an
4873 op which evaluates method name; it is consumed by this function and
4874 become part of the constructed op tree.
4875 Supported optypes: OP_METHOD.
4876
4877 =cut
4878 */
4879
4880 static OP*
4881 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
4882     dVAR;
4883     METHOP *methop;
4884
4885     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
4886         || type == OP_CUSTOM);
4887
4888     NewOp(1101, methop, 1, METHOP);
4889     if (dynamic_meth) {
4890         if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
4891         methop->op_flags = (U8)(flags | OPf_KIDS);
4892         methop->op_u.op_first = dynamic_meth;
4893         methop->op_private = (U8)(1 | (flags >> 8));
4894
4895 #ifdef PERL_OP_PARENT
4896         if (!OpHAS_SIBLING(dynamic_meth))
4897             dynamic_meth->op_sibling = (OP*)methop;
4898 #endif
4899     }
4900     else {
4901         assert(const_meth);
4902         methop->op_flags = (U8)(flags & ~OPf_KIDS);
4903         methop->op_u.op_meth_sv = const_meth;
4904         methop->op_private = (U8)(0 | (flags >> 8));
4905         methop->op_next = (OP*)methop;
4906     }
4907
4908 #ifdef USE_ITHREADS
4909     methop->op_rclass_targ = 0;
4910 #else
4911     methop->op_rclass_sv = NULL;
4912 #endif
4913
4914     CHANGE_TYPE(methop, type);
4915     return CHECKOP(type, methop);
4916 }
4917
4918 OP *
4919 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
4920     PERL_ARGS_ASSERT_NEWMETHOP;
4921     return newMETHOP_internal(type, flags, dynamic_meth, NULL);
4922 }
4923
4924 /*
4925 =for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
4926
4927 Constructs, checks, and returns an op of method type with a constant
4928 method name.  I<type> is the opcode.  I<flags> gives the eight bits of
4929 C<op_flags>, and, shifted up eight bits, the eight bits of
4930 C<op_private>.  I<const_meth> supplies a constant method name;
4931 it must be a shared COW string.
4932 Supported optypes: OP_METHOD_NAMED.
4933
4934 =cut
4935 */
4936
4937 OP *
4938 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
4939     PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
4940     return newMETHOP_internal(type, flags, NULL, const_meth);
4941 }
4942
4943 /*
4944 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
4945
4946 Constructs, checks, and returns an op of any binary type.  I<type>
4947 is the opcode.  I<flags> gives the eight bits of C<op_flags>, except
4948 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4949 the eight bits of C<op_private>, except that the bit with value 1 or
4950 2 is automatically set as required.  I<first> and I<last> supply up to
4951 two ops to be the direct children of the binary op; they are consumed
4952 by this function and become part of the constructed op tree.
4953
4954 =cut
4955 */
4956
4957 OP *
4958 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4959 {
4960     dVAR;
4961     BINOP *binop;
4962
4963     ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
4964         || type == OP_SASSIGN || type == OP_NULL || type == OP_CUSTOM);
4965
4966     NewOp(1101, binop, 1, BINOP);
4967
4968     if (!first)
4969         first = newOP(OP_NULL, 0);
4970
4971     CHANGE_TYPE(binop, type);
4972     binop->op_first = first;
4973     binop->op_flags = (U8)(flags | OPf_KIDS);
4974     if (!last) {
4975         last = first;
4976         binop->op_private = (U8)(1 | (flags >> 8));
4977     }
4978     else {
4979         binop->op_private = (U8)(2 | (flags >> 8));
4980         OpSIBLING_set(first, last);
4981         first->op_lastsib = 0;
4982     }
4983
4984 #ifdef PERL_OP_PARENT
4985     if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
4986         last->op_sibling = (OP*)binop;
4987 #endif
4988
4989     binop->op_last = OpSIBLING(binop->op_first);
4990 #ifdef PERL_OP_PARENT
4991     if (binop->op_last)
4992         binop->op_last->op_sibling = (OP*)binop;
4993 #endif
4994
4995     binop = (BINOP*)CHECKOP(type, binop);
4996     if (binop->op_next || binop->op_type != (OPCODE)type)
4997         return (OP*)binop;
4998
4999     return fold_constants(op_integerize(op_std_init((OP *)binop)));
5000 }
5001
5002 static int uvcompare(const void *a, const void *b)
5003     __attribute__nonnull__(1)
5004     __attribute__nonnull__(2)
5005     __attribute__pure__;
5006 static int uvcompare(const void *a, const void *b)
5007 {
5008     if (*((const UV *)a) < (*(const UV *)b))
5009         return -1;
5010     if (*((const UV *)a) > (*(const UV *)b))
5011         return 1;
5012     if (*((const UV *)a+1) < (*(const UV *)b+1))
5013         return -1;
5014     if (*((const UV *)a+1) > (*(const UV *)b+1))
5015         return 1;
5016     return 0;
5017 }
5018
5019 static OP *
5020 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
5021 {
5022     SV * const tstr = ((SVOP*)expr)->op_sv;
5023     SV * const rstr =
5024                               ((SVOP*)repl)->op_sv;
5025     STRLEN tlen;
5026     STRLEN rlen;
5027     const U8 *t = (U8*)SvPV_const(tstr, tlen);
5028     const U8 *r = (U8*)SvPV_const(rstr, rlen);
5029     I32 i;
5030     I32 j;
5031     I32 grows = 0;
5032     short *tbl;
5033
5034     const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
5035     const I32 squash     = o->op_private & OPpTRANS_SQUASH;
5036     I32 del              = o->op_private & OPpTRANS_DELETE;
5037     SV* swash;
5038
5039     PERL_ARGS_ASSERT_PMTRANS;
5040
5041     PL_hints |= HINT_BLOCK_SCOPE;
5042
5043     if (SvUTF8(tstr))
5044         o->op_private |= OPpTRANS_FROM_UTF;
5045
5046     if (SvUTF8(rstr))
5047         o->op_private |= OPpTRANS_TO_UTF;
5048
5049     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
5050         SV* const listsv = newSVpvs("# comment\n");
5051         SV* transv = NULL;
5052         const U8* tend = t + tlen;
5053         const U8* rend = r + rlen;
5054         STRLEN ulen;
5055         UV tfirst = 1;
5056         UV tlast = 0;
5057         IV tdiff;
5058         STRLEN tcount = 0;
5059         UV rfirst = 1;
5060         UV rlast = 0;
5061         IV rdiff;
5062         STRLEN rcount = 0;
5063         IV diff;
5064         I32 none = 0;
5065         U32 max = 0;
5066         I32 bits;
5067         I32 havefinal = 0;
5068         U32 final = 0;
5069         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
5070         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
5071         U8* tsave = NULL;
5072         U8* rsave = NULL;
5073         const U32 flags = UTF8_ALLOW_DEFAULT;
5074
5075         if (!from_utf) {
5076             STRLEN len = tlen;
5077             t = tsave = bytes_to_utf8(t, &len);
5078             tend = t + len;
5079         }
5080         if (!to_utf && rlen) {
5081             STRLEN len = rlen;
5082             r = rsave = bytes_to_utf8(r, &len);
5083             rend = r + len;
5084         }
5085
5086 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
5087  * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
5088  * odd.  */
5089
5090         if (complement) {
5091             U8 tmpbuf[UTF8_MAXBYTES+1];
5092             UV *cp;
5093             UV nextmin = 0;
5094             Newx(cp, 2*tlen, UV);
5095             i = 0;
5096             transv = newSVpvs("");
5097             while (t < tend) {
5098                 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
5099                 t += ulen;
5100                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
5101                     t++;
5102                     cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
5103                     t += ulen;
5104                 }
5105                 else {
5106                  cp[2*i+1] = cp[2*i];
5107                 }
5108                 i++;
5109             }
5110             qsort(cp, i, 2*sizeof(UV), uvcompare);
5111             for (j = 0; j < i; j++) {
5112                 UV  val = cp[2*j];
5113                 diff = val - nextmin;
5114                 if (diff > 0) {
5115                     t = uvchr_to_utf8(tmpbuf,nextmin);
5116                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5117                     if (diff > 1) {
5118                         U8  range_mark = ILLEGAL_UTF8_BYTE;
5119                         t = uvchr_to_utf8(tmpbuf, val - 1);
5120                         sv_catpvn(transv, (char *)&range_mark, 1);
5121                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5122                     }
5123                 }
5124                 val = cp[2*j+1];
5125                 if (val >= nextmin)
5126                     nextmin = val + 1;
5127             }
5128             t = uvchr_to_utf8(tmpbuf,nextmin);
5129             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5130             {
5131                 U8 range_mark = ILLEGAL_UTF8_BYTE;
5132                 sv_catpvn(transv, (char *)&range_mark, 1);
5133             }
5134             t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
5135             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5136             t = (const U8*)SvPVX_const(transv);
5137             tlen = SvCUR(transv);
5138             tend = t + tlen;
5139             Safefree(cp);
5140         }
5141         else if (!rlen && !del) {
5142             r = t; rlen = tlen; rend = tend;
5143         }
5144         if (!squash) {
5145                 if ((!rlen && !del) || t == r ||
5146                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
5147                 {
5148                     o->op_private |= OPpTRANS_IDENTICAL;
5149                 }
5150         }
5151
5152         while (t < tend || tfirst <= tlast) {
5153             /* see if we need more "t" chars */
5154             if (tfirst > tlast) {
5155                 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
5156                 t += ulen;
5157                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {      /* illegal utf8 val indicates range */
5158                     t++;
5159                     tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
5160                     t += ulen;
5161                 }
5162                 else
5163                     tlast = tfirst;
5164             }
5165
5166             /* now see if we need more "r" chars */
5167             if (rfirst > rlast) {
5168                 if (r < rend) {
5169                     rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
5170                     r += ulen;
5171                     if (r < rend && *r == ILLEGAL_UTF8_BYTE) {  /* illegal utf8 val indicates range */
5172                         r++;
5173                         rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
5174                         r += ulen;
5175                     }
5176                     else
5177                         rlast = rfirst;
5178                 }
5179                 else {
5180                     if (!havefinal++)
5181                         final = rlast;
5182                     rfirst = rlast = 0xffffffff;
5183                 }
5184             }
5185
5186             /* now see which range will peter our first, if either. */
5187             tdiff = tlast - tfirst;
5188             rdiff = rlast - rfirst;
5189             tcount += tdiff + 1;
5190             rcount += rdiff + 1;
5191
5192             if (tdiff <= rdiff)
5193                 diff = tdiff;
5194             else
5195                 diff = rdiff;
5196
5197             if (rfirst == 0xffffffff) {
5198                 diff = tdiff;   /* oops, pretend rdiff is infinite */
5199                 if (diff > 0)
5200                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
5201                                    (long)tfirst, (long)tlast);
5202                 else
5203                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
5204             }
5205             else {
5206                 if (diff > 0)
5207                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
5208                                    (long)tfirst, (long)(tfirst + diff),
5209                                    (long)rfirst);
5210                 else
5211                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
5212                                    (long)tfirst, (long)rfirst);
5213
5214                 if (rfirst + diff > max)
5215                     max = rfirst + diff;
5216                 if (!grows)
5217                     grows = (tfirst < rfirst &&
5218                              UNISKIP(tfirst) < UNISKIP(rfirst + diff));
5219                 rfirst += diff + 1;
5220             }
5221             tfirst += diff + 1;
5222         }
5223
5224         none = ++max;
5225         if (del)
5226             del = ++max;
5227
5228         if (max > 0xffff)
5229             bits = 32;
5230         else if (max > 0xff)
5231             bits = 16;
5232         else
5233             bits = 8;
5234
5235         swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
5236 #ifdef USE_ITHREADS
5237         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
5238         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
5239         PAD_SETSV(cPADOPo->op_padix, swash);
5240         SvPADTMP_on(swash);
5241         SvREADONLY_on(swash);
5242 #else
5243         cSVOPo->op_sv = swash;
5244 #endif
5245         SvREFCNT_dec(listsv);
5246         SvREFCNT_dec(transv);
5247
5248         if (!del && havefinal && rlen)
5249             (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
5250                            newSVuv((UV)final), 0);
5251
5252         Safefree(tsave);
5253         Safefree(rsave);
5254
5255         tlen = tcount;
5256         rlen = rcount;
5257         if (r < rend)
5258             rlen++;
5259         else if (rlast == 0xffffffff)
5260             rlen = 0;
5261
5262         goto warnins;
5263     }
5264
5265     tbl = (short*)PerlMemShared_calloc(
5266         (o->op_private & OPpTRANS_COMPLEMENT) &&
5267             !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
5268         sizeof(short));
5269     cPVOPo->op_pv = (char*)tbl;
5270     if (complement) {
5271         for (i = 0; i < (I32)tlen; i++)
5272             tbl[t[i]] = -1;
5273         for (i = 0, j = 0; i < 256; i++) {
5274             if (!tbl[i]) {
5275                 if (j >= (I32)rlen) {
5276                     if (del)
5277                         tbl[i] = -2;
5278                     else if (rlen)
5279                         tbl[i] = r[j-1];
5280                     else
5281                         tbl[i] = (short)i;
5282                 }
5283                 else {
5284                     if (i < 128 && r[j] >= 128)
5285                         grows = 1;
5286                     tbl[i] = r[j++];
5287                 }
5288             }
5289         }
5290         if (!del) {
5291             if (!rlen) {
5292                 j = rlen;
5293                 if (!squash)
5294                     o->op_private |= OPpTRANS_IDENTICAL;
5295             }
5296             else if (j >= (I32)rlen)
5297                 j = rlen - 1;
5298             else {
5299                 tbl =
5300                     (short *)
5301                     PerlMemShared_realloc(tbl,
5302                                           (0x101+rlen-j) * sizeof(short));
5303                 cPVOPo->op_pv = (char*)tbl;
5304             }
5305             tbl[0x100] = (short)(rlen - j);
5306             for (i=0; i < (I32)rlen - j; i++)
5307                 tbl[0x101+i] = r[j+i];
5308         }
5309     }
5310     else {
5311         if (!rlen && !del) {
5312             r = t; rlen = tlen;
5313             if (!squash)
5314                 o->op_private |= OPpTRANS_IDENTICAL;
5315         }
5316         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
5317             o->op_private |= OPpTRANS_IDENTICAL;
5318         }
5319         for (i = 0; i < 256; i++)
5320             tbl[i] = -1;
5321         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
5322             if (j >= (I32)rlen) {
5323                 if (del) {
5324                     if (tbl[t[i]] == -1)
5325                         tbl[t[i]] = -2;
5326                     continue;
5327                 }
5328                 --j;
5329             }
5330             if (tbl[t[i]] == -1) {
5331                 if (t[i] < 128 && r[j] >= 128)
5332                     grows = 1;
5333                 tbl[t[i]] = r[j];
5334             }
5335         }
5336     }
5337
5338   warnins:
5339     if(del && rlen == tlen) {
5340         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
5341     } else if(rlen > tlen && !complement) {
5342         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
5343     }
5344
5345     if (grows)
5346         o->op_private |= OPpTRANS_GROWS;
5347     op_free(expr);
5348     op_free(repl);
5349
5350     return o;
5351 }
5352
5353 /*
5354 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
5355
5356 Constructs, checks, and returns an op of any pattern matching type.
5357 I<type> is the opcode.  I<flags> gives the eight bits of C<op_flags>
5358 and, shifted up eight bits, the eight bits of C<op_private>.
5359
5360 =cut
5361 */
5362
5363 OP *
5364 Perl_newPMOP(pTHX_ I32 type, I32 flags)
5365 {
5366     dVAR;
5367     PMOP *pmop;
5368
5369     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
5370         || type == OP_CUSTOM);
5371
5372     NewOp(1101, pmop, 1, PMOP);
5373     CHANGE_TYPE(pmop, type);
5374     pmop->op_flags = (U8)flags;
5375     pmop->op_private = (U8)(0 | (flags >> 8));
5376     if (PL_opargs[type] & OA_RETSCALAR)
5377         scalar((OP *)pmop);
5378
5379     if (PL_hints & HINT_RE_TAINT)
5380         pmop->op_pmflags |= PMf_RETAINT;
5381 #ifdef USE_LOCALE_CTYPE
5382     if (IN_LC_COMPILETIME(LC_CTYPE)) {
5383         set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
5384     }
5385     else
5386 #endif
5387          if (IN_UNI_8_BIT) {
5388         set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
5389     }
5390     if (PL_hints & HINT_RE_FLAGS) {
5391         SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5392          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
5393         );
5394         if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
5395         reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5396          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
5397         );
5398         if (reflags && SvOK(reflags)) {
5399             set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
5400         }
5401     }
5402
5403
5404 #ifdef USE_ITHREADS
5405     assert(SvPOK(PL_regex_pad[0]));
5406     if (SvCUR(PL_regex_pad[0])) {
5407         /* Pop off the "packed" IV from the end.  */
5408         SV *const repointer_list = PL_regex_pad[0];
5409         const char *p = SvEND(repointer_list) - sizeof(IV);
5410         const IV offset = *((IV*)p);
5411
5412         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
5413
5414         SvEND_set(repointer_list, p);
5415
5416         pmop->op_pmoffset = offset;
5417         /* This slot should be free, so assert this:  */
5418         assert(PL_regex_pad[offset] == &PL_sv_undef);
5419     } else {
5420         SV * const repointer = &PL_sv_undef;
5421         av_push(PL_regex_padav, repointer);
5422         pmop->op_pmoffset = av_tindex(PL_regex_padav);
5423         PL_regex_pad = AvARRAY(PL_regex_padav);
5424     }
5425 #endif
5426
5427     return CHECKOP(type, pmop);
5428 }
5429
5430 static void
5431 S_set_haseval(pTHX)
5432 {
5433     PADOFFSET i = 1;
5434     PL_cv_has_eval = 1;
5435     /* Any pad names in scope are potentially lvalues.  */
5436     for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
5437         PADNAME *pn = PAD_COMPNAME_SV(i);
5438         if (!pn || !PadnameLEN(pn))
5439             continue;
5440         if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
5441             S_mark_padname_lvalue(aTHX_ pn);
5442     }
5443 }
5444
5445 /* Given some sort of match op o, and an expression expr containing a
5446  * pattern, either compile expr into a regex and attach it to o (if it's
5447  * constant), or convert expr into a runtime regcomp op sequence (if it's
5448  * not)
5449  *
5450  * isreg indicates that the pattern is part of a regex construct, eg
5451  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
5452  * split "pattern", which aren't. In the former case, expr will be a list
5453  * if the pattern contains more than one term (eg /a$b/).
5454  *
5455  * When the pattern has been compiled within a new anon CV (for
5456  * qr/(?{...})/ ), then floor indicates the savestack level just before
5457  * the new sub was created
5458  */
5459
5460 OP *
5461 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, bool isreg, I32 floor)
5462 {
5463     PMOP *pm;
5464     LOGOP *rcop;
5465     I32 repl_has_vars = 0;
5466     bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
5467     bool is_compiletime;
5468     bool has_code;
5469
5470     PERL_ARGS_ASSERT_PMRUNTIME;
5471
5472     if (is_trans) {
5473         return pmtrans(o, expr, repl);
5474     }
5475
5476     /* find whether we have any runtime or code elements;
5477      * at the same time, temporarily set the op_next of each DO block;
5478      * then when we LINKLIST, this will cause the DO blocks to be excluded
5479      * from the op_next chain (and from having LINKLIST recursively
5480      * applied to them). We fix up the DOs specially later */
5481
5482     is_compiletime = 1;
5483     has_code = 0;
5484     if (expr->op_type == OP_LIST) {
5485         OP *o;
5486         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
5487             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
5488                 has_code = 1;
5489                 assert(!o->op_next);
5490                 if (UNLIKELY(!OpHAS_SIBLING(o))) {
5491                     assert(PL_parser && PL_parser->error_count);
5492                     /* This can happen with qr/ (?{(^{})/.  Just fake up
5493                        the op we were expecting to see, to avoid crashing
5494                        elsewhere.  */
5495                     op_sibling_splice(expr, o, 0,
5496                                       newSVOP(OP_CONST, 0, &PL_sv_no));
5497                 }
5498                 o->op_next = OpSIBLING(o);
5499             }
5500             else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
5501                 is_compiletime = 0;
5502         }
5503     }
5504     else if (expr->op_type != OP_CONST)
5505         is_compiletime = 0;
5506
5507     LINKLIST(expr);
5508
5509     /* fix up DO blocks; treat each one as a separate little sub;
5510      * also, mark any arrays as LIST/REF */
5511
5512     if (expr->op_type == OP_LIST) {
5513         OP *o;
5514         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
5515
5516             if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
5517                 assert( !(o->op_flags  & OPf_WANT));
5518                 /* push the array rather than its contents. The regex
5519                  * engine will retrieve and join the elements later */
5520                 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
5521                 continue;
5522             }
5523
5524             if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
5525                 continue;
5526             o->op_next = NULL; /* undo temporary hack from above */
5527             scalar(o);
5528             LINKLIST(o);
5529             if (cLISTOPo->op_first->op_type == OP_LEAVE) {
5530                 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
5531                 /* skip ENTER */
5532                 assert(leaveop->op_first->op_type == OP_ENTER);
5533                 assert(OpHAS_SIBLING(leaveop->op_first));
5534                 o->op_next = OpSIBLING(leaveop->op_first);
5535                 /* skip leave */
5536                 assert(leaveop->op_flags & OPf_KIDS);
5537                 assert(leaveop->op_last->op_next == (OP*)leaveop);
5538                 leaveop->op_next = NULL; /* stop on last op */
5539                 op_null((OP*)leaveop);
5540             }
5541             else {
5542                 /* skip SCOPE */
5543                 OP *scope = cLISTOPo->op_first;
5544                 assert(scope->op_type == OP_SCOPE);
5545                 assert(scope->op_flags & OPf_KIDS);
5546                 scope->op_next = NULL; /* stop on last op */
5547                 op_null(scope);
5548             }
5549             /* have to peep the DOs individually as we've removed it from
5550              * the op_next chain */
5551             CALL_PEEP(o);
5552             S_prune_chain_head(&(o->op_next));
5553             if (is_compiletime)
5554                 /* runtime finalizes as part of finalizing whole tree */
5555                 finalize_optree(o);
5556         }
5557     }
5558     else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
5559         assert( !(expr->op_flags  & OPf_WANT));
5560         /* push the array rather than its contents. The regex
5561          * engine will retrieve and join the elements later */
5562         expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
5563     }
5564
5565     PL_hints |= HINT_BLOCK_SCOPE;
5566     pm = (PMOP*)o;
5567     assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
5568
5569     if (is_compiletime) {
5570         U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
5571         regexp_engine const *eng = current_re_engine();
5572
5573         if (o->op_flags & OPf_SPECIAL)
5574             rx_flags |= RXf_SPLIT;
5575
5576         if (!has_code || !eng->op_comp) {
5577             /* compile-time simple constant pattern */
5578
5579             if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
5580                 /* whoops! we guessed that a qr// had a code block, but we
5581                  * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
5582                  * that isn't required now. Note that we have to be pretty
5583                  * confident that nothing used that CV's pad while the
5584                  * regex was parsed, except maybe op targets for \Q etc.
5585                  * If there were any op targets, though, they should have
5586                  * been stolen by constant folding.
5587                  */
5588 #ifdef DEBUGGING
5589                 SSize_t i = 0;
5590                 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
5591                 while (++i <= AvFILLp(PL_comppad)) {
5592                     assert(!PL_curpad[i]);
5593                 }
5594 #endif
5595                 /* But we know that one op is using this CV's slab. */
5596                 cv_forget_slab(PL_compcv);
5597                 LEAVE_SCOPE(floor);
5598                 pm->op_pmflags &= ~PMf_HAS_CV;
5599             }
5600
5601             PM_SETRE(pm,
5602                 eng->op_comp
5603                     ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5604                                         rx_flags, pm->op_pmflags)
5605                     : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5606                                         rx_flags, pm->op_pmflags)
5607             );
5608             op_free(expr);
5609         }
5610         else {
5611             /* compile-time pattern that includes literal code blocks */
5612             REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5613                         rx_flags,
5614                         (pm->op_pmflags |
5615                             ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
5616                     );
5617             PM_SETRE(pm, re);
5618             if (pm->op_pmflags & PMf_HAS_CV) {
5619                 CV *cv;
5620                 /* this QR op (and the anon sub we embed it in) is never
5621                  * actually executed. It's just a placeholder where we can
5622                  * squirrel away expr in op_code_list without the peephole
5623                  * optimiser etc processing it for a second time */
5624                 OP *qr = newPMOP(OP_QR, 0);
5625                 ((PMOP*)qr)->op_code_list = expr;
5626
5627                 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
5628                 SvREFCNT_inc_simple_void(PL_compcv);
5629                 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
5630                 ReANY(re)->qr_anoncv = cv;
5631
5632                 /* attach the anon CV to the pad so that
5633                  * pad_fixup_inner_anons() can find it */
5634                 (void)pad_add_anon(cv, o->op_type);
5635                 SvREFCNT_inc_simple_void(cv);
5636             }
5637             else {
5638                 pm->op_code_list = expr;
5639             }
5640         }
5641     }
5642     else {
5643         /* runtime pattern: build chain of regcomp etc ops */
5644         bool reglist;
5645         PADOFFSET cv_targ = 0;
5646
5647         reglist = isreg && expr->op_type == OP_LIST;
5648         if (reglist)
5649             op_null(expr);
5650
5651         if (has_code) {
5652             pm->op_code_list = expr;
5653             /* don't free op_code_list; its ops are embedded elsewhere too */
5654             pm->op_pmflags |= PMf_CODELIST_PRIVATE;
5655         }
5656
5657         if (o->op_flags & OPf_SPECIAL)
5658             pm->op_pmflags |= PMf_SPLIT;
5659
5660         /* the OP_REGCMAYBE is a placeholder in the non-threaded case
5661          * to allow its op_next to be pointed past the regcomp and
5662          * preceding stacking ops;
5663          * OP_REGCRESET is there to reset taint before executing the
5664          * stacking ops */
5665         if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
5666             expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
5667
5668         if (pm->op_pmflags & PMf_HAS_CV) {
5669             /* we have a runtime qr with literal code. This means
5670              * that the qr// has been wrapped in a new CV, which
5671              * means that runtime consts, vars etc will have been compiled
5672              * against a new pad. So... we need to execute those ops
5673              * within the environment of the new CV. So wrap them in a call
5674              * to a new anon sub. i.e. for
5675              *
5676              *     qr/a$b(?{...})/,
5677              *
5678              * we build an anon sub that looks like
5679              *
5680              *     sub { "a", $b, '(?{...})' }
5681              *
5682              * and call it, passing the returned list to regcomp.
5683              * Or to put it another way, the list of ops that get executed
5684              * are:
5685              *
5686              *     normal              PMf_HAS_CV
5687              *     ------              -------------------
5688              *                         pushmark (for regcomp)
5689              *                         pushmark (for entersub)
5690              *                         anoncode
5691              *                         srefgen
5692              *                         entersub
5693              *     regcreset                  regcreset
5694              *     pushmark                   pushmark
5695              *     const("a")                 const("a")
5696              *     gvsv(b)                    gvsv(b)
5697              *     const("(?{...})")          const("(?{...})")
5698              *                                leavesub
5699              *     regcomp             regcomp
5700              */
5701
5702             SvREFCNT_inc_simple_void(PL_compcv);
5703             CvLVALUE_on(PL_compcv);
5704             /* these lines are just an unrolled newANONATTRSUB */
5705             expr = newSVOP(OP_ANONCODE, 0,
5706                     MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
5707             cv_targ = expr->op_targ;
5708             expr = newUNOP(OP_REFGEN, 0, expr);
5709
5710             expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
5711         }
5712
5713         rcop = S_alloc_LOGOP(aTHX_ OP_REGCOMP, scalar(expr), o);
5714         rcop->op_flags |=  ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
5715                            | (reglist ? OPf_STACKED : 0);
5716         rcop->op_targ = cv_targ;
5717
5718         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
5719         if (PL_hints & HINT_RE_EVAL)
5720             S_set_haseval(aTHX);
5721
5722         /* establish postfix order */
5723         if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
5724             LINKLIST(expr);
5725             rcop->op_next = expr;
5726             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
5727         }
5728         else {
5729             rcop->op_next = LINKLIST(expr);
5730             expr->op_next = (OP*)rcop;
5731         }
5732
5733         op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
5734     }
5735
5736     if (repl) {
5737         OP *curop = repl;
5738         bool konst;
5739         /* If we are looking at s//.../e with a single statement, get past
5740            the implicit do{}. */
5741         if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
5742              && cUNOPx(curop)->op_first->op_type == OP_SCOPE
5743              && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
5744          {
5745             OP *sib;
5746             OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
5747             if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
5748              && !OpHAS_SIBLING(sib))
5749                 curop = sib;
5750         }
5751         if (curop->op_type == OP_CONST)
5752             konst = TRUE;
5753         else if (( (curop->op_type == OP_RV2SV ||
5754                     curop->op_type == OP_RV2AV ||
5755                     curop->op_type == OP_RV2HV ||
5756                     curop->op_type == OP_RV2GV)
5757                    && cUNOPx(curop)->op_first
5758                    && cUNOPx(curop)->op_first->op_type == OP_GV )
5759                 || curop->op_type == OP_PADSV
5760                 || curop->op_type == OP_PADAV
5761                 || curop->op_type == OP_PADHV
5762                 || curop->op_type == OP_PADANY) {
5763             repl_has_vars = 1;
5764             konst = TRUE;
5765         }
5766         else konst = FALSE;
5767         if (konst
5768             && !(repl_has_vars
5769                  && (!PM_GETRE(pm)
5770                      || !RX_PRELEN(PM_GETRE(pm))
5771                      || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
5772         {
5773             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
5774             op_prepend_elem(o->op_type, scalar(repl), o);
5775         }
5776         else {
5777             rcop = S_alloc_LOGOP(aTHX_ OP_SUBSTCONT, scalar(repl), o);
5778             rcop->op_private = 1;
5779
5780             /* establish postfix order */
5781             rcop->op_next = LINKLIST(repl);
5782             repl->op_next = (OP*)rcop;
5783
5784             pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
5785             assert(!(pm->op_pmflags & PMf_ONCE));
5786             pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
5787             rcop->op_next = 0;
5788         }
5789     }
5790
5791     return (OP*)pm;
5792 }
5793
5794 /*
5795 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
5796
5797 Constructs, checks, and returns an op of any type that involves an
5798 embedded SV.  I<type> is the opcode.  I<flags> gives the eight bits
5799 of C<op_flags>.  I<sv> gives the SV to embed in the op; this function
5800 takes ownership of one reference to it.
5801
5802 =cut
5803 */
5804
5805 OP *
5806 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
5807 {
5808     dVAR;
5809     SVOP *svop;
5810
5811     PERL_ARGS_ASSERT_NEWSVOP;
5812
5813     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5814         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5815         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5816         || type == OP_CUSTOM);
5817
5818     NewOp(1101, svop, 1, SVOP);
5819     CHANGE_TYPE(svop, type);
5820     svop->op_sv = sv;
5821     svop->op_next = (OP*)svop;
5822     svop->op_flags = (U8)flags;
5823     svop->op_private = (U8)(0 | (flags >> 8));
5824     if (PL_opargs[type] & OA_RETSCALAR)
5825         scalar((OP*)svop);
5826     if (PL_opargs[type] & OA_TARGET)
5827         svop->op_targ = pad_alloc(type, SVs_PADTMP);
5828     return CHECKOP(type, svop);
5829 }
5830
5831 /*
5832 =for apidoc Am|OP *|newDEFSVOP|
5833
5834 Constructs and returns an op to access C<$_>, either as a lexical
5835 variable (if declared as C<my $_>) in the current scope, or the
5836 global C<$_>.
5837
5838 =cut
5839 */
5840
5841 OP *
5842 Perl_newDEFSVOP(pTHX)
5843 {
5844     const PADOFFSET offset = pad_findmy_pvs("$_", 0);
5845     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5846         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
5847     }
5848     else {
5849         OP * const o = newOP(OP_PADSV, 0);
5850         o->op_targ = offset;
5851         return o;
5852     }
5853 }
5854
5855 #ifdef USE_ITHREADS
5856
5857 /*
5858 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
5859
5860 Constructs, checks, and returns an op of any type that involves a
5861 reference to a pad element.  I<type> is the opcode.  I<flags> gives the
5862 eight bits of C<op_flags>.  A pad slot is automatically allocated, and
5863 is populated with I<sv>; this function takes ownership of one reference
5864 to it.
5865
5866 This function only exists if Perl has been compiled to use ithreads.
5867
5868 =cut
5869 */
5870
5871 OP *
5872 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
5873 {
5874     dVAR;
5875     PADOP *padop;
5876
5877     PERL_ARGS_ASSERT_NEWPADOP;
5878
5879     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5880         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5881         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5882         || type == OP_CUSTOM);
5883
5884     NewOp(1101, padop, 1, PADOP);
5885     CHANGE_TYPE(padop, type);
5886     padop->op_padix =
5887         pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
5888     SvREFCNT_dec(PAD_SVl(padop->op_padix));
5889     PAD_SETSV(padop->op_padix, sv);
5890     assert(sv);
5891     padop->op_next = (OP*)padop;
5892     padop->op_flags = (U8)flags;
5893     if (PL_opargs[type] & OA_RETSCALAR)
5894         scalar((OP*)padop);
5895     if (PL_opargs[type] & OA_TARGET)
5896         padop->op_targ = pad_alloc(type, SVs_PADTMP);
5897     return CHECKOP(type, padop);
5898 }
5899
5900 #endif /* USE_ITHREADS */
5901
5902 /*
5903 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
5904
5905 Constructs, checks, and returns an op of any type that involves an
5906 embedded reference to a GV.  I<type> is the opcode.  I<flags> gives the
5907 eight bits of C<op_flags>.  I<gv> identifies the GV that the op should
5908 reference; calling this function does not transfer ownership of any
5909 reference to it.
5910
5911 =cut
5912 */
5913
5914 OP *
5915 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
5916 {
5917     PERL_ARGS_ASSERT_NEWGVOP;
5918
5919 #ifdef USE_ITHREADS
5920     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5921 #else
5922     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5923 #endif
5924 }
5925
5926 /*
5927 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
5928
5929 Constructs, checks, and returns an op of any type that involves an
5930 embedded C-level pointer (PV).  I<type> is the opcode.  I<flags> gives
5931 the eight bits of C<op_flags>.  I<pv> supplies the C-level pointer, which
5932 must have been allocated using C<PerlMemShared_malloc>; the memory will
5933 be freed when the op is destroyed.
5934
5935 =cut
5936 */
5937
5938 OP *
5939 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
5940 {
5941     dVAR;
5942     const bool utf8 = cBOOL(flags & SVf_UTF8);
5943     PVOP *pvop;
5944
5945     flags &= ~SVf_UTF8;
5946
5947     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5948         || type == OP_RUNCV || type == OP_CUSTOM
5949         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5950
5951     NewOp(1101, pvop, 1, PVOP);
5952     CHANGE_TYPE(pvop, type);
5953     pvop->op_pv = pv;
5954     pvop->op_next = (OP*)pvop;
5955     pvop->op_flags = (U8)flags;
5956     pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
5957     if (PL_opargs[type] & OA_RETSCALAR)
5958         scalar((OP*)pvop);
5959     if (PL_opargs[type] & OA_TARGET)
5960         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
5961     return CHECKOP(type, pvop);
5962 }
5963
5964 void
5965 Perl_package(pTHX_ OP *o)
5966 {
5967     SV *const sv = cSVOPo->op_sv;
5968
5969     PERL_ARGS_ASSERT_PACKAGE;
5970
5971     SAVEGENERICSV(PL_curstash);
5972     save_item(PL_curstname);
5973
5974     PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
5975
5976     sv_setsv(PL_curstname, sv);
5977
5978     PL_hints |= HINT_BLOCK_SCOPE;
5979     PL_parser->copline = NOLINE;
5980
5981     op_free(o);
5982 }
5983
5984 void
5985 Perl_package_version( pTHX_ OP *v )
5986 {
5987     U32 savehints = PL_hints;
5988     PERL_ARGS_ASSERT_PACKAGE_VERSION;
5989     PL_hints &= ~HINT_STRICT_VARS;
5990     sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
5991     PL_hints = savehints;
5992     op_free(v);
5993 }
5994
5995 void
5996 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
5997 {
5998     OP *pack;
5999     OP *imop;
6000     OP *veop;
6001     SV *use_version = NULL;
6002
6003     PERL_ARGS_ASSERT_UTILIZE;
6004
6005     if (idop->op_type != OP_CONST)
6006         Perl_croak(aTHX_ "Module name must be constant");
6007
6008     veop = NULL;
6009
6010     if (version) {
6011         SV * const vesv = ((SVOP*)version)->op_sv;
6012
6013         if (!arg && !SvNIOKp(vesv)) {
6014             arg = version;
6015         }
6016         else {
6017             OP *pack;
6018             SV *meth;
6019
6020             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
6021                 Perl_croak(aTHX_ "Version number must be a constant number");
6022
6023             /* Make copy of idop so we don't free it twice */
6024             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
6025
6026             /* Fake up a method call to VERSION */
6027             meth = newSVpvs_share("VERSION");
6028             veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
6029                             op_append_elem(OP_LIST,
6030                                         op_prepend_elem(OP_LIST, pack, version),
6031                                         newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
6032         }
6033     }
6034
6035     /* Fake up an import/unimport */
6036     if (arg && arg->op_type == OP_STUB) {
6037         imop = arg;             /* no import on explicit () */
6038     }
6039     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
6040         imop = NULL;            /* use 5.0; */
6041         if (aver)
6042             use_version = ((SVOP*)idop)->op_sv;
6043         else
6044             idop->op_private |= OPpCONST_NOVER;
6045     }
6046     else {
6047         SV *meth;
6048
6049         /* Make copy of idop so we don't free it twice */
6050         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
6051
6052         /* Fake up a method call to import/unimport */
6053         meth = aver
6054             ? newSVpvs_share("import") : newSVpvs_share("unimport");
6055         imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
6056                        op_append_elem(OP_LIST,
6057                                    op_prepend_elem(OP_LIST, pack, arg),
6058                                    newMETHOP_named(OP_METHOD_NAMED, 0, meth)
6059                        ));
6060     }
6061
6062     /* Fake up the BEGIN {}, which does its thing immediately. */
6063     newATTRSUB(floor,
6064         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
6065         NULL,
6066         NULL,
6067         op_append_elem(OP_LINESEQ,
6068             op_append_elem(OP_LINESEQ,
6069                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
6070                 newSTATEOP(0, NULL, veop)),
6071             newSTATEOP(0, NULL, imop) ));
6072
6073     if (use_version) {
6074         /* Enable the
6075          * feature bundle that corresponds to the required version. */
6076         use_version = sv_2mortal(new_version(use_version));
6077         S_enable_feature_bundle(aTHX_ use_version);
6078
6079         /* If a version >= 5.11.0 is requested, strictures are on by default! */
6080         if (vcmp(use_version,
6081                  sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
6082             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
6083                 PL_hints |= HINT_STRICT_REFS;
6084             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
6085                 PL_hints |= HINT_STRICT_SUBS;
6086             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
6087                 PL_hints |= HINT_STRICT_VARS;
6088         }
6089         /* otherwise they are off */
6090         else {
6091             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
6092                 PL_hints &= ~HINT_STRICT_REFS;
6093             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
6094                 PL_hints &= ~HINT_STRICT_SUBS;
6095             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
6096                 PL_hints &= ~HINT_STRICT_VARS;
6097         }
6098     }
6099
6100     /* The "did you use incorrect case?" warning used to be here.
6101      * The problem is that on case-insensitive filesystems one
6102      * might get false positives for "use" (and "require"):
6103      * "use Strict" or "require CARP" will work.  This causes
6104      * portability problems for the script: in case-strict
6105      * filesystems the script will stop working.
6106      *
6107      * The "incorrect case" warning checked whether "use Foo"
6108      * imported "Foo" to your namespace, but that is wrong, too:
6109      * there is no requirement nor promise in the language that
6110      * a Foo.pm should or would contain anything in package "Foo".
6111      *
6112      * There is very little Configure-wise that can be done, either:
6113      * the case-sensitivity of the build filesystem of Perl does not
6114      * help in guessing the case-sensitivity of the runtime environment.
6115      */
6116
6117     PL_hints |= HINT_BLOCK_SCOPE;
6118     PL_parser->copline = NOLINE;
6119     COP_SEQMAX_INC; /* Purely for B::*'s benefit */
6120 }
6121
6122 /*
6123 =head1 Embedding Functions
6124
6125 =for apidoc load_module
6126
6127 Loads the module whose name is pointed to by the string part of name.
6128 Note that the actual module name, not its filename, should be given.
6129 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
6130 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
6131 (or 0 for no flags).  ver, if specified
6132 and not NULL, provides version semantics
6133 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
6134 arguments can be used to specify arguments to the module's import()
6135 method, similar to C<use Foo::Bar VERSION LIST>.  They must be
6136 terminated with a final NULL pointer.  Note that this list can only
6137 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
6138 Otherwise at least a single NULL pointer to designate the default
6139 import list is required.
6140
6141 The reference count for each specified C<SV*> parameter is decremented.
6142
6143 =cut */
6144
6145 void
6146 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
6147 {
6148     va_list args;
6149
6150     PERL_ARGS_ASSERT_LOAD_MODULE;
6151
6152     va_start(args, ver);
6153     vload_module(flags, name, ver, &args);
6154     va_end(args);
6155 }
6156
6157 #ifdef PERL_IMPLICIT_CONTEXT
6158 void
6159 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
6160 {
6161     dTHX;
6162     va_list args;
6163     PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
6164     va_start(args, ver);
6165     vload_module(flags, name, ver, &args);
6166     va_end(args);
6167 }
6168 #endif
6169
6170 void
6171 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
6172 {
6173     OP *veop, *imop;
6174     OP * const modname = newSVOP(OP_CONST, 0, name);
6175
6176     PERL_ARGS_ASSERT_VLOAD_MODULE;
6177
6178     modname->op_private |= OPpCONST_BARE;
6179     if (ver) {
6180         veop = newSVOP(OP_CONST, 0, ver);
6181     }
6182     else
6183         veop = NULL;
6184     if (flags & PERL_LOADMOD_NOIMPORT) {
6185         imop = sawparens(newNULLLIST());
6186     }
6187     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
6188         imop = va_arg(*args, OP*);
6189     }
6190     else {
6191         SV *sv;
6192         imop = NULL;
6193         sv = va_arg(*args, SV*);
6194         while (sv) {
6195             imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
6196             sv = va_arg(*args, SV*);
6197         }
6198     }
6199
6200     /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
6201      * that it has a PL_parser to play with while doing that, and also
6202      * that it doesn't mess with any existing parser, by creating a tmp
6203      * new parser with lex_start(). This won't actually be used for much,
6204      * since pp_require() will create another parser for the real work.
6205      * The ENTER/LEAVE pair protect callers from any side effects of use.  */
6206
6207     ENTER;
6208     SAVEVPTR(PL_curcop);
6209     lex_start(NULL, NULL, LEX_START_SAME_FILTER);
6210     utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
6211             veop, modname, imop);
6212     LEAVE;
6213 }
6214
6215 PERL_STATIC_INLINE OP *
6216 S_new_entersubop(pTHX_ GV *gv, OP *arg)
6217 {
6218     return newUNOP(OP_ENTERSUB, OPf_STACKED,
6219                    newLISTOP(OP_LIST, 0, arg,
6220                              newUNOP(OP_RV2CV, 0,
6221                                      newGVOP(OP_GV, 0, gv))));
6222 }
6223
6224 OP *
6225 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
6226 {
6227     OP *doop;
6228     GV *gv;
6229
6230     PERL_ARGS_ASSERT_DOFILE;
6231
6232     if (!force_builtin && (gv = gv_override("do", 2))) {
6233         doop = S_new_entersubop(aTHX_ gv, term);
6234     }
6235     else {
6236         doop = newUNOP(OP_DOFILE, 0, scalar(term));
6237     }
6238     return doop;
6239 }
6240
6241 /*
6242 =head1 Optree construction
6243
6244 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
6245
6246 Constructs, checks, and returns an C<lslice> (list slice) op.  I<flags>
6247 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
6248 be set automatically, and, shifted up eight bits, the eight bits of
6249 C<op_private>, except that the bit with value 1 or 2 is automatically
6250 set as required.  I<listval> and I<subscript> supply the parameters of
6251 the slice; they are consumed by this function and become part of the
6252 constructed op tree.
6253
6254 =cut
6255 */
6256
6257 OP *
6258 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
6259 {
6260     return newBINOP(OP_LSLICE, flags,
6261             list(force_list(subscript, 1)),
6262             list(force_list(listval,   1)) );
6263 }
6264
6265 #define ASSIGN_LIST   1
6266 #define ASSIGN_REF    2
6267
6268 STATIC I32
6269 S_assignment_type(pTHX_ const OP *o)
6270 {
6271     unsigned type;
6272     U8 flags;
6273     U8 ret;
6274
6275     if (!o)
6276         return TRUE;
6277
6278     if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
6279         o = cUNOPo->op_first;
6280
6281     flags = o->op_flags;
6282     type = o->op_type;
6283     if (type == OP_COND_EXPR) {
6284         OP * const sib = OpSIBLING(cLOGOPo->op_first);
6285         const I32 t = assignment_type(sib);
6286         const I32 f = assignment_type(OpSIBLING(sib));
6287
6288         if (t == ASSIGN_LIST && f == ASSIGN_LIST)
6289             return ASSIGN_LIST;
6290         if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
6291             yyerror("Assignment to both a list and a scalar");
6292         return FALSE;
6293     }
6294
6295     if (type == OP_SREFGEN)
6296     {
6297         OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
6298         type = kid->op_type;
6299         flags |= kid->op_flags;
6300         if (!(flags & OPf_PARENS)
6301           && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
6302               kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
6303             return ASSIGN_REF;
6304         ret = ASSIGN_REF;
6305     }
6306     else ret = 0;
6307
6308     if (type == OP_LIST &&
6309         (flags & OPf_WANT) == OPf_WANT_SCALAR &&
6310         o->op_private & OPpLVAL_INTRO)
6311         return ret;
6312
6313     if (type == OP_LIST || flags & OPf_PARENS ||
6314         type == OP_RV2AV || type == OP_RV2HV ||
6315         type == OP_ASLICE || type == OP_HSLICE ||
6316         type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
6317         return TRUE;
6318
6319     if (type == OP_PADAV || type == OP_PADHV)
6320         return TRUE;
6321
6322     if (type == OP_RV2SV)
6323         return ret;
6324
6325     return ret;
6326 }
6327
6328 /*
6329   Helper function for newASSIGNOP to detect commonality between the
6330   lhs and the rhs.  (It is actually called very indirectly.  newASSIGNOP
6331   flags the op and the peephole optimizer calls this helper function
6332   if the flag is set.)  Marks all variables with PL_generation.  If it
6333   returns TRUE the assignment must be able to handle common variables.
6334
6335   PL_generation sorcery:
6336   An assignment like ($a,$b) = ($c,$d) is easier than
6337   ($a,$b) = ($c,$a), since there is no need for temporary vars.
6338   To detect whether there are common vars, the global var
6339   PL_generation is incremented for each assign op we compile.
6340   Then, while compiling the assign op, we run through all the
6341   variables on both sides of the assignment, setting a spare slot
6342   in each of them to PL_generation.  If any of them already have
6343   that value, we know we've got commonality.  Also, if the
6344   generation number is already set to PERL_INT_MAX, then
6345   the variable is involved in aliasing, so we also have
6346   potential commonality in that case.  We could use a
6347   single bit marker, but then we'd have to make 2 passes, first
6348   to clear the flag, then to test and set it.  And that
6349   wouldn't help with aliasing, either.  To find somewhere
6350   to store these values, evil chicanery is done with SvUVX().
6351 */
6352 PERL_STATIC_INLINE bool
6353 S_aassign_common_vars(pTHX_ OP* o)
6354 {
6355     OP *curop;
6356     for (curop = cUNOPo->op_first; curop; curop = OpSIBLING(curop)) {
6357         if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
6358             if (curop->op_type == OP_GV || curop->op_type == OP_GVSV
6359              || curop->op_type == OP_AELEMFAST) {
6360                 GV *gv = cGVOPx_gv(curop);
6361                 if (gv == PL_defgv
6362                     || (int)GvASSIGN_GENERATION(gv) == PL_generation)
6363                     return TRUE;
6364                 GvASSIGN_GENERATION_set(gv, PL_generation);
6365             }
6366             else if (curop->op_type == OP_PADSV ||
6367                 curop->op_type == OP_PADAV ||
6368                 curop->op_type == OP_PADHV ||
6369                 curop->op_type == OP_AELEMFAST_LEX ||
6370                 curop->op_type == OP_PADANY)
6371                 {
6372                   padcheck:
6373                     if (PAD_COMPNAME_GEN(curop->op_targ)
6374                         == (STRLEN)PL_generation
6375                      || PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX)
6376                         return TRUE;
6377                     PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
6378
6379                 }
6380             else if (curop->op_type == OP_RV2CV)
6381                 return TRUE;
6382             else if (curop->op_type == OP_RV2SV ||
6383                 curop->op_type == OP_RV2AV ||
6384                 curop->op_type == OP_RV2HV ||
6385                 curop->op_type == OP_RV2GV) {
6386                 if (cUNOPx(curop)->op_first->op_type != OP_GV)  /* funny deref? */
6387                     return TRUE;
6388             }
6389             else if (curop->op_type == OP_PUSHRE) {
6390                 GV *const gv =
6391 #ifdef USE_ITHREADS
6392                     ((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff
6393                         ? MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff))
6394                         : NULL;
6395 #else
6396                     ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
6397 #endif
6398                 if (gv) {
6399                     if (gv == PL_defgv
6400                         || (int)GvASSIGN_GENERATION(gv) == PL_generation)
6401                         return TRUE;
6402                     GvASSIGN_GENERATION_set(gv, PL_generation);
6403                 }
6404                 else if (curop->op_targ)
6405                     goto padcheck;
6406             }
6407             else if (curop->op_type == OP_PADRANGE)
6408                 /* Ignore padrange; checking its siblings is sufficient. */
6409                 continue;
6410             else
6411                 return TRUE;
6412         }
6413         else if (PL_opargs[curop->op_type] & OA_TARGLEX
6414               && curop->op_private & OPpTARGET_MY)
6415             goto padcheck;
6416
6417         if (curop->op_flags & OPf_KIDS) {
6418             if (aassign_common_vars(curop))
6419                 return TRUE;
6420         }
6421     }
6422     return FALSE;
6423 }
6424
6425 /* This variant only handles lexical aliases.  It is called when
6426    newASSIGNOP decides that we don’t have any common vars, as lexical ali-
6427    ases trump that decision.  */
6428 PERL_STATIC_INLINE bool
6429 S_aassign_common_vars_aliases_only(pTHX_ OP *o)
6430 {
6431     OP *curop;
6432     for (curop = cUNOPo->op_first; curop; curop = OpSIBLING(curop)) {
6433         if ((curop->op_type == OP_PADSV ||
6434              curop->op_type == OP_PADAV ||
6435              curop->op_type == OP_PADHV ||
6436              curop->op_type == OP_AELEMFAST_LEX ||
6437              curop->op_type == OP_PADANY ||
6438              (  PL_opargs[curop->op_type] & OA_TARGLEX
6439              && curop->op_private & OPpTARGET_MY  ))
6440            && PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX)
6441             return TRUE;
6442
6443         if (curop->op_type == OP_PUSHRE && curop->op_targ
6444          && PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX)
6445             return TRUE;
6446
6447         if (curop->op_flags & OPf_KIDS) {
6448             if (S_aassign_common_vars_aliases_only(aTHX_ curop))
6449                 return TRUE;
6450         }
6451     }
6452     return FALSE;
6453 }
6454
6455 /*
6456 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
6457
6458 Constructs, checks, and returns an assignment op.  I<left> and I<right>
6459 supply the parameters of the assignment; they are consumed by this
6460 function and become part of the constructed op tree.
6461
6462 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
6463 a suitable conditional optree is constructed.  If I<optype> is the opcode
6464 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
6465 performs the binary operation and assigns the result to the left argument.
6466 Either way, if I<optype> is non-zero then I<flags> has no effect.
6467
6468 If I<optype> is zero, then a plain scalar or list assignment is
6469 constructed.  Which type of assignment it is is automatically determined.
6470 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6471 will be set automatically, and, shifted up eight bits, the eight bits
6472 of C<op_private>, except that the bit with value 1 or 2 is automatically
6473 set as required.
6474
6475 =cut
6476 */
6477
6478 OP *
6479 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
6480 {
6481     OP *o;
6482     I32 assign_type;
6483
6484     if (optype) {
6485         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
6486             return newLOGOP(optype, 0,
6487                 op_lvalue(scalar(left), optype),
6488                 newUNOP(OP_SASSIGN, 0, scalar(right)));
6489         }
6490         else {
6491             return newBINOP(optype, OPf_STACKED,
6492                 op_lvalue(scalar(left), optype), scalar(right));
6493         }
6494     }
6495
6496     if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
6497         static const char no_list_state[] = "Initialization of state variables"
6498             " in list context currently forbidden";
6499         OP *curop;
6500         bool maybe_common_vars = TRUE;
6501
6502         if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
6503             left->op_private &= ~ OPpSLICEWARNING;
6504
6505         PL_modcount = 0;
6506         left = op_lvalue(left, OP_AASSIGN);
6507         curop = list(force_list(left, 1));
6508         o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
6509         o->op_private = (U8)(0 | (flags >> 8));
6510
6511         if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
6512         {
6513             OP* lop = ((LISTOP*)left)->op_first;
6514             maybe_common_vars = FALSE;
6515             while (lop) {
6516                 if (lop->op_type == OP_PADSV ||
6517                     lop->op_type == OP_PADAV ||
6518                     lop->op_type == OP_PADHV ||
6519                     lop->op_type == OP_PADANY) {
6520                     if (!(lop->op_private & OPpLVAL_INTRO))
6521                         maybe_common_vars = TRUE;
6522
6523                     if (lop->op_private & OPpPAD_STATE) {
6524                         if (left->op_private & OPpLVAL_INTRO) {
6525                             /* Each variable in state($a, $b, $c) = ... */
6526                         }
6527                         else {
6528                             /* Each state variable in
6529                                (state $a, my $b, our $c, $d, undef) = ... */
6530                         }
6531                         yyerror(no_list_state);
6532                     } else {
6533                         /* Each my variable in
6534                            (state $a, my $b, our $c, $d, undef) = ... */
6535                     }
6536                 } else if (lop->op_type == OP_UNDEF ||
6537                            OP_TYPE_IS_OR_WAS(lop, OP_PUSHMARK)) {
6538                     /* undef may be interesting in
6539                        (state $a, undef, state $c) */
6540                 } else {
6541                     /* Other ops in the list. */
6542                     maybe_common_vars = TRUE;
6543                 }
6544                 lop = OpSIBLING(lop);
6545             }
6546         }
6547         else if ((left->op_private & OPpLVAL_INTRO)
6548                 && (   left->op_type == OP_PADSV
6549                     || left->op_type == OP_PADAV
6550                     || left->op_type == OP_PADHV
6551                     || left->op_type == OP_PADANY))
6552         {
6553             if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
6554             if (left->op_private & OPpPAD_STATE) {
6555                 /* All single variable list context state assignments, hence
6556                    state ($a) = ...
6557                    (state $a) = ...
6558                    state @a = ...
6559                    state (@a) = ...
6560                    (state @a) = ...
6561                    state %a = ...
6562                    state (%a) = ...
6563                    (state %a) = ...
6564                 */
6565                 yyerror(no_list_state);
6566             }
6567         }
6568
6569         if (maybe_common_vars) {
6570                 /* The peephole optimizer will do the full check and pos-
6571                    sibly turn this off.  */
6572                 o->op_private |= OPpASSIGN_COMMON;
6573         }
6574
6575         if (right && right->op_type == OP_SPLIT
6576          && !(right->op_flags & OPf_STACKED)) {
6577             OP* tmpop = ((LISTOP*)right)->op_first;
6578             PMOP * const pm = (PMOP*)tmpop;
6579             assert (tmpop && (tmpop->op_type == OP_PUSHRE));
6580             if (
6581 #ifdef USE_ITHREADS
6582                     !pm->op_pmreplrootu.op_pmtargetoff
6583 #else
6584                     !pm->op_pmreplrootu.op_pmtargetgv
6585 #endif
6586                  && !pm->op_targ
6587                 ) {
6588                     if (!(left->op_private & OPpLVAL_INTRO) &&
6589                         ( (left->op_type == OP_RV2AV &&
6590                           (tmpop=((UNOP*)left)->op_first)->op_type==OP_GV)
6591                         || left->op_type == OP_PADAV )
6592                         ) {
6593                         if (tmpop != (OP *)pm) {
6594 #ifdef USE_ITHREADS
6595                           pm->op_pmreplrootu.op_pmtargetoff
6596                             = cPADOPx(tmpop)->op_padix;
6597                           cPADOPx(tmpop)->op_padix = 0; /* steal it */
6598 #else
6599                           pm->op_pmreplrootu.op_pmtargetgv
6600                             = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
6601                           cSVOPx(tmpop)->op_sv = NULL;  /* steal it */
6602 #endif
6603                           right->op_private |=
6604                             left->op_private & OPpOUR_INTRO;
6605                         }
6606                         else {
6607                             pm->op_targ = left->op_targ;
6608                             left->op_targ = 0; /* filch it */
6609                         }
6610                       detach_split:
6611                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
6612                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
6613                         /* detach rest of siblings from o subtree,
6614                          * and free subtree */
6615                         op_sibling_splice(cUNOPo->op_first, tmpop, -1, NULL);
6616                         op_free(o);                     /* blow off assign */
6617                         right->op_flags &= ~OPf_WANT;
6618                                 /* "I don't know and I don't care." */
6619                         return right;
6620                     }
6621                     else if (left->op_type == OP_RV2AV
6622                           || left->op_type == OP_PADAV)
6623                     {
6624                         /* Detach the array.  */
6625 #ifdef DEBUGGING
6626                         OP * const ary =
6627 #endif
6628                         op_sibling_splice(cBINOPo->op_last,
6629                                           cUNOPx(cBINOPo->op_last)
6630                                                 ->op_first, 1, NULL);
6631                         assert(ary == left);
6632                         /* Attach it to the split.  */
6633                         op_sibling_splice(right, cLISTOPx(right)->op_last,
6634                                           0, left);
6635                         right->op_flags |= OPf_STACKED;
6636                         /* Detach split and expunge aassign as above.  */
6637                         goto detach_split;
6638                     }
6639                     else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
6640                             ((LISTOP*)right)->op_last->op_type == OP_CONST)
6641                     {
6642                         SV ** const svp =
6643                             &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
6644                         SV * const sv = *svp;
6645                         if (SvIOK(sv) && SvIVX(sv) == 0)
6646                         {
6647                           if (right->op_private & OPpSPLIT_IMPLIM) {
6648                             /* our own SV, created in ck_split */
6649                             SvREADONLY_off(sv);
6650                             sv_setiv(sv, PL_modcount+1);
6651                           }
6652                           else {
6653                             /* SV may belong to someone else */
6654                             SvREFCNT_dec(sv);
6655                             *svp = newSViv(PL_modcount+1);
6656                           }
6657                         }
6658                     }
6659             }
6660         }
6661         return o;
6662     }
6663     if (assign_type == ASSIGN_REF)
6664         return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
6665     if (!right)
6666         right = newOP(OP_UNDEF, 0);
6667     if (right->op_type == OP_READLINE) {
6668         right->op_flags |= OPf_STACKED;
6669         return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
6670                 scalar(right));
6671     }
6672     else {
6673         o = newBINOP(OP_SASSIGN, flags,
6674             scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
6675     }
6676     return o;
6677 }
6678
6679 /*
6680 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
6681
6682 Constructs a state op (COP).  The state op is normally a C<nextstate> op,
6683 but will be a C<dbstate> op if debugging is enabled for currently-compiled
6684 code.  The state op is populated from C<PL_curcop> (or C<PL_compiling>).
6685 If I<label> is non-null, it supplies the name of a label to attach to
6686 the state op; this function takes ownership of the memory pointed at by
6687 I<label>, and will free it.  I<flags> gives the eight bits of C<op_flags>
6688 for the state op.
6689
6690 If I<o> is null, the state op is returned.  Otherwise the state op is
6691 combined with I<o> into a C<lineseq> list op, which is returned.  I<o>
6692 is consumed by this function and becomes part of the returned op tree.
6693
6694 =cut
6695 */
6696
6697 OP *
6698 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
6699 {
6700     dVAR;
6701     const U32 seq = intro_my();
6702     const U32 utf8 = flags & SVf_UTF8;
6703     COP *cop;
6704
6705     PL_parser->parsed_sub = 0;
6706
6707     flags &= ~SVf_UTF8;
6708
6709     NewOp(1101, cop, 1, COP);
6710     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
6711         CHANGE_TYPE(cop, OP_DBSTATE);
6712     }
6713     else {
6714         CHANGE_TYPE(cop, OP_NEXTSTATE);
6715     }
6716     cop->op_flags = (U8)flags;
6717     CopHINTS_set(cop, PL_hints);
6718 #ifdef VMS
6719     if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
6720 #endif
6721     cop->op_next = (OP*)cop;
6722
6723     cop->cop_seq = seq;
6724     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
6725     CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
6726     if (label) {
6727         Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
6728
6729         PL_hints |= HINT_BLOCK_SCOPE;
6730         /* It seems that we need to defer freeing this pointer, as other parts
6731            of the grammar end up wanting to copy it after this op has been
6732            created. */
6733         SAVEFREEPV(label);
6734     }
6735
6736     if (PL_parser->preambling != NOLINE) {
6737         CopLINE_set(cop, PL_parser->preambling);
6738         PL_parser->copline = NOLINE;
6739     }
6740     else if (PL_parser->copline == NOLINE)
6741         CopLINE_set(cop, CopLINE(PL_curcop));
6742     else {
6743         CopLINE_set(cop, PL_parser->copline);
6744         PL_parser->copline = NOLINE;
6745     }
6746 #ifdef USE_ITHREADS
6747     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
6748 #else
6749     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
6750 #endif
6751     CopSTASH_set(cop, PL_curstash);
6752
6753     if (cop->op_type == OP_DBSTATE) {
6754         /* this line can have a breakpoint - store the cop in IV */
6755         AV *av = CopFILEAVx(PL_curcop);
6756         if (av) {
6757             SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
6758             if (svp && *svp != &PL_sv_undef ) {
6759                 (void)SvIOK_on(*svp);
6760                 SvIV_set(*svp, PTR2IV(cop));
6761             }
6762         }
6763     }
6764
6765     if (flags & OPf_SPECIAL)
6766         op_null((OP*)cop);
6767     return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
6768 }
6769
6770 /*
6771 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
6772
6773 Constructs, checks, and returns a logical (flow control) op.  I<type>
6774 is the opcode.  I<flags> gives the eight bits of C<op_flags>, except
6775 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6776 the eight bits of C<op_private>, except that the bit with value 1 is
6777 automatically set.  I<first> supplies the expression controlling the
6778 flow, and I<other> supplies the side (alternate) chain of ops; they are
6779 consumed by this function and become part of the constructed op tree.
6780
6781 =cut
6782 */
6783
6784 OP *
6785 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
6786 {
6787     PERL_ARGS_ASSERT_NEWLOGOP;
6788
6789     return new_logop(type, flags, &first, &other);
6790 }
6791
6792 STATIC OP *
6793 S_search_const(pTHX_ OP *o)
6794 {
6795     PERL_ARGS_ASSERT_SEARCH_CONST;
6796
6797     switch (o->op_type) {
6798         case OP_CONST:
6799             return o;
6800         case OP_NULL:
6801             if (o->op_flags & OPf_KIDS)
6802                 return search_const(cUNOPo->op_first);
6803             break;
6804         case OP_LEAVE:
6805         case OP_SCOPE:
6806         case OP_LINESEQ:
6807         {
6808             OP *kid;
6809             if (!(o->op_flags & OPf_KIDS))
6810                 return NULL;
6811             kid = cLISTOPo->op_first;
6812             do {
6813                 switch (kid->op_type) {
6814                     case OP_ENTER:
6815                     case OP_NULL:
6816                     case OP_NEXTSTATE:
6817                         kid = OpSIBLING(kid);
6818                         break;
6819                     default:
6820                         if (kid != cLISTOPo->op_last)
6821                             return NULL;
6822                         goto last;
6823                 }
6824             } while (kid);
6825             if (!kid)
6826                 kid = cLISTOPo->op_last;
6827 last:
6828             return search_const(kid);
6829         }
6830     }
6831
6832     return NULL;
6833 }
6834
6835 STATIC OP *
6836 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
6837 {
6838     dVAR;
6839     LOGOP *logop;
6840     OP *o;
6841     OP *first;
6842     OP *other;
6843     OP *cstop = NULL;
6844     int prepend_not = 0;
6845
6846     PERL_ARGS_ASSERT_NEW_LOGOP;
6847
6848     first = *firstp;
6849     other = *otherp;
6850
6851     /* [perl #59802]: Warn about things like "return $a or $b", which
6852        is parsed as "(return $a) or $b" rather than "return ($a or
6853        $b)".  NB: This also applies to xor, which is why we do it
6854        here.
6855      */
6856     switch (first->op_type) {
6857     case OP_NEXT:
6858     case OP_LAST:
6859     case OP_REDO:
6860         /* XXX: Perhaps we should emit a stronger warning for these.
6861            Even with the high-precedence operator they don't seem to do
6862            anything sensible.
6863
6864            But until we do, fall through here.
6865          */
6866     case OP_RETURN:
6867     case OP_EXIT:
6868     case OP_DIE:
6869     case OP_GOTO:
6870         /* XXX: Currently we allow people to "shoot themselves in the
6871            foot" by explicitly writing "(return $a) or $b".
6872
6873            Warn unless we are looking at the result from folding or if
6874            the programmer explicitly grouped the operators like this.
6875            The former can occur with e.g.
6876
6877                 use constant FEATURE => ( $] >= ... );
6878                 sub { not FEATURE and return or do_stuff(); }
6879          */
6880         if (!first->op_folded && !(first->op_flags & OPf_PARENS))
6881             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6882                            "Possible precedence issue with control flow operator");
6883         /* XXX: Should we optimze this to "return $a;" (i.e. remove
6884            the "or $b" part)?
6885         */
6886         break;
6887     }
6888
6889     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
6890         return newBINOP(type, flags, scalar(first), scalar(other));
6891
6892     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
6893         || type == OP_CUSTOM);
6894
6895     scalarboolean(first);
6896     /* optimize AND and OR ops that have NOTs as children */
6897     if (first->op_type == OP_NOT
6898         && (first->op_flags & OPf_KIDS)
6899         && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
6900             || (other->op_type == OP_NOT))  /* if (!$x && !$y) { } */
6901         ) {
6902         if (type == OP_AND || type == OP_OR) {
6903             if (type == OP_AND)
6904                 type = OP_OR;
6905             else
6906                 type = OP_AND;
6907             op_null(first);
6908             if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
6909                 op_null(other);
6910                 prepend_not = 1; /* prepend a NOT op later */
6911             }
6912         }
6913     }
6914     /* search for a constant op that could let us fold the test */
6915     if ((cstop = search_const(first))) {
6916         if (cstop->op_private & OPpCONST_STRICT)
6917             no_bareword_allowed(cstop);
6918         else if ((cstop->op_private & OPpCONST_BARE))
6919                 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
6920         if ((type == OP_AND &&  SvTRUE(((SVOP*)cstop)->op_sv)) ||
6921             (type == OP_OR  && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
6922             (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
6923             *firstp = NULL;
6924             if (other->op_type == OP_CONST)
6925                 other->op_private |= OPpCONST_SHORTCIRCUIT;
6926             op_free(first);
6927             if (other->op_type == OP_LEAVE)
6928                 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
6929             else if (other->op_type == OP_MATCH
6930                   || other->op_type == OP_SUBST
6931                   || other->op_type == OP_TRANSR
6932                   || other->op_type == OP_TRANS)
6933                 /* Mark the op as being unbindable with =~ */
6934                 other->op_flags |= OPf_SPECIAL;
6935
6936             other->op_folded = 1;
6937             return other;
6938         }
6939         else {
6940             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
6941             const OP *o2 = other;
6942             if ( ! (o2->op_type == OP_LIST
6943                     && (( o2 = cUNOPx(o2)->op_first))
6944                     && o2->op_type == OP_PUSHMARK
6945                     && (( o2 = OpSIBLING(o2))) )
6946             )
6947                 o2 = other;
6948             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
6949                         || o2->op_type == OP_PADHV)
6950                 && o2->op_private & OPpLVAL_INTRO
6951                 && !(o2->op_private & OPpPAD_STATE))
6952             {
6953                 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6954                                  "Deprecated use of my() in false conditional");
6955             }
6956
6957             *otherp = NULL;
6958             if (cstop->op_type == OP_CONST)
6959                 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
6960                 op_free(other);
6961             return first;
6962         }
6963     }
6964     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
6965         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
6966     {
6967         const OP * const k1 = ((UNOP*)first)->op_first;
6968         const OP * const k2 = OpSIBLING(k1);
6969         OPCODE warnop = 0;
6970         switch (first->op_type)
6971         {
6972         case OP_NULL:
6973             if (k2 && k2->op_type == OP_READLINE
6974                   && (k2->op_flags & OPf_STACKED)
6975                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6976             {
6977                 warnop = k2->op_type;
6978             }
6979             break;
6980
6981         case OP_SASSIGN:
6982             if (k1->op_type == OP_READDIR
6983                   || k1->op_type == OP_GLOB
6984                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6985                  || k1->op_type == OP_EACH
6986                  || k1->op_type == OP_AEACH)
6987             {
6988                 warnop = ((k1->op_type == OP_NULL)
6989                           ? (OPCODE)k1->op_targ : k1->op_type);
6990             }
6991             break;
6992         }
6993         if (warnop) {
6994             const line_t oldline = CopLINE(PL_curcop);
6995             /* This ensures that warnings are reported at the first line
6996                of the construction, not the last.  */
6997             CopLINE_set(PL_curcop, PL_parser->copline);
6998             Perl_warner(aTHX_ packWARN(WARN_MISC),
6999                  "Value of %s%s can be \"0\"; test with defined()",
7000                  PL_op_desc[warnop],
7001                  ((warnop == OP_READLINE || warnop == OP_GLOB)
7002                   ? " construct" : "() operator"));
7003             CopLINE_set(PL_curcop, oldline);
7004         }
7005     }
7006
7007     if (!other)
7008         return first;
7009
7010     if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
7011         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
7012
7013     logop = S_alloc_LOGOP(aTHX_ type, first, LINKLIST(other));
7014     logop->op_flags |= (U8)flags;
7015     logop->op_private = (U8)(1 | (flags >> 8));
7016
7017     /* establish postfix order */
7018     logop->op_next = LINKLIST(first);
7019     first->op_next = (OP*)logop;
7020     assert(!OpHAS_SIBLING(first));
7021     op_sibling_splice((OP*)logop, first, 0, other);
7022
7023     CHECKOP(type,logop);
7024
7025     o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
7026                 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
7027                 (OP*)logop);
7028     other->op_next = o;
7029
7030     return o;
7031 }
7032
7033 /*
7034 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
7035
7036 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
7037 op.  I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
7038 will be set automatically, and, shifted up eight bits, the eight bits of
7039 C<op_private>, except that the bit with value 1 is automatically set.
7040 I<first> supplies the expression selecting between the two branches,
7041 and I<trueop> and I<falseop> supply the branches; they are consumed by
7042 this function and become part of the constructed op tree.
7043
7044 =cut
7045 */
7046
7047 OP *
7048 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
7049 {
7050     dVAR;
7051     LOGOP *logop;
7052     OP *start;
7053     OP *o;
7054     OP *cstop;
7055
7056     PERL_ARGS_ASSERT_NEWCONDOP;
7057
7058     if (!falseop)
7059         return newLOGOP(OP_AND, 0, first, trueop);
7060     if (!trueop)
7061         return newLOGOP(OP_OR, 0, first, falseop);
7062
7063     scalarboolean(first);
7064     if ((cstop = search_const(first))) {
7065         /* Left or right arm of the conditional?  */
7066         const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
7067         OP *live = left ? trueop : falseop;
7068         OP *const dead = left ? falseop : trueop;
7069         if (cstop->op_private & OPpCONST_BARE &&
7070             cstop->op_private & OPpCONST_STRICT) {
7071             no_bareword_allowed(cstop);
7072         }
7073         op_free(first);
7074         op_free(dead);
7075         if (live->op_type == OP_LEAVE)
7076             live = newUNOP(OP_NULL, OPf_SPECIAL, live);
7077         else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
7078               || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
7079             /* Mark the op as being unbindable with =~ */
7080             live->op_flags |= OPf_SPECIAL;
7081         live->op_folded = 1;
7082         return live;
7083     }
7084     logop = S_alloc_LOGOP(aTHX_ OP_COND_EXPR, first, LINKLIST(trueop));
7085     logop->op_flags |= (U8)flags;
7086     logop->op_private = (U8)(1 | (flags >> 8));
7087     logop->op_next = LINKLIST(falseop);
7088
7089     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
7090             logop);
7091
7092     /* establish postfix order */
7093     start = LINKLIST(first);
7094     first->op_next = (OP*)logop;
7095
7096     /* make first, trueop, falseop siblings */
7097     op_sibling_splice((OP*)logop, first,  0, trueop);
7098     op_sibling_splice((OP*)logop, trueop, 0, falseop);
7099
7100     o = newUNOP(OP_NULL, 0, (OP*)logop);
7101
7102     trueop->op_next = falseop->op_next = o;
7103
7104     o->op_next = start;
7105     return o;
7106 }
7107
7108 /*
7109 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
7110
7111 Constructs and returns a C<range> op, with subordinate C<flip> and
7112 C<flop> ops.  I<flags> gives the eight bits of C<op_flags> for the
7113 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
7114 for both the C<flip> and C<range> ops, except that the bit with value
7115 1 is automatically set.  I<left> and I<right> supply the expressions
7116 controlling the endpoints of the range; they are consumed by this function
7117 and become part of the constructed op tree.
7118
7119 =cut
7120 */
7121
7122 OP *
7123 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
7124 {
7125     LOGOP *range;
7126     OP *flip;
7127     OP *flop;
7128     OP *leftstart;
7129     OP *o;
7130
7131     PERL_ARGS_ASSERT_NEWRANGE;
7132
7133     range = S_alloc_LOGOP(aTHX_ OP_RANGE, left, LINKLIST(right));
7134     range->op_flags = OPf_KIDS;
7135     leftstart = LINKLIST(left);
7136     range->op_private = (U8)(1 | (flags >> 8));
7137
7138     /* make left and right siblings */
7139     op_sibling_splice((OP*)range, left, 0, right);
7140
7141     range->op_next = (OP*)range;
7142     flip = newUNOP(OP_FLIP, flags, (OP*)range);
7143     flop = newUNOP(OP_FLOP, 0, flip);
7144     o = newUNOP(OP_NULL, 0, flop);
7145     LINKLIST(flop);
7146     range->op_next = leftstart;
7147
7148     left->op_next = flip;
7149     right->op_next = flop;
7150
7151     range->op_targ =
7152         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
7153     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
7154     flip->op_targ =
7155         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
7156     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
7157     SvPADTMP_on(PAD_SV(flip->op_targ));
7158
7159     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
7160     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
7161
7162     /* check barewords before they might be optimized aways */
7163     if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
7164         no_bareword_allowed(left);
7165     if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
7166         no_bareword_allowed(right);
7167
7168     flip->op_next = o;
7169     if (!flip->op_private || !flop->op_private)
7170         LINKLIST(o);            /* blow off optimizer unless constant */
7171
7172     return o;
7173 }
7174
7175 /*
7176 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
7177
7178 Constructs, checks, and returns an op tree expressing a loop.  This is
7179 only a loop in the control flow through the op tree; it does not have
7180 the heavyweight loop structure that allows exiting the loop by C<last>
7181 and suchlike.  I<flags> gives the eight bits of C<op_flags> for the
7182 top-level op, except that some bits will be set automatically as required.
7183 I<expr> supplies the expression controlling loop iteration, and I<block>
7184 supplies the body of the loop; they are consumed by this function and
7185 become part of the constructed op tree.  I<debuggable> is currently
7186 unused and should always be 1.
7187
7188 =cut
7189 */
7190
7191 OP *
7192 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
7193 {
7194     OP* listop;
7195     OP* o;
7196     const bool once = block && block->op_flags & OPf_SPECIAL &&
7197                       block->op_type == OP_NULL;
7198
7199     PERL_UNUSED_ARG(debuggable);
7200
7201     if (expr) {
7202         if (once && (
7203               (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
7204            || (  expr->op_type == OP_NOT
7205               && cUNOPx(expr)->op_first->op_type == OP_CONST
7206               && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
7207               )
7208            ))
7209             /* Return the block now, so that S_new_logop does not try to
7210                fold it away. */
7211             return block;       /* do {} while 0 does once */
7212         if (expr->op_type == OP_READLINE
7213             || expr->op_type == OP_READDIR
7214             || expr->op_type == OP_GLOB
7215             || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
7216             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
7217             expr = newUNOP(OP_DEFINED, 0,
7218                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
7219         } else if (expr->op_flags & OPf_KIDS) {
7220             const OP * const k1 = ((UNOP*)expr)->op_first;
7221             const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
7222             switch (expr->op_type) {
7223               case OP_NULL:
7224                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
7225                       && (k2->op_flags & OPf_STACKED)
7226                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7227                     expr = newUNOP(OP_DEFINED, 0, expr);
7228                 break;
7229
7230               case OP_SASSIGN:
7231                 if (k1 && (k1->op_type == OP_READDIR
7232                       || k1->op_type == OP_GLOB
7233                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7234                      || k1->op_type == OP_EACH
7235                      || k1->op_type == OP_AEACH))
7236                     expr = newUNOP(OP_DEFINED, 0, expr);
7237                 break;
7238             }
7239         }
7240     }
7241
7242     /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
7243      * op, in listop. This is wrong. [perl #27024] */
7244     if (!block)
7245         block = newOP(OP_NULL, 0);
7246     listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
7247     o = new_logop(OP_AND, 0, &expr, &listop);
7248
7249     if (once) {
7250         ASSUME(listop);
7251     }
7252
7253     if (listop)
7254         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
7255
7256     if (once && o != listop)
7257     {
7258         assert(cUNOPo->op_first->op_type == OP_AND
7259             || cUNOPo->op_first->op_type == OP_OR);
7260         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
7261     }
7262
7263     if (o == listop)
7264         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
7265
7266     o->op_flags |= flags;
7267     o = op_scope(o);
7268     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
7269     return o;
7270 }
7271
7272 /*
7273 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
7274
7275 Constructs, checks, and returns an op tree expressing a C<while> loop.
7276 This is a heavyweight loop, with structure that allows exiting the loop
7277 by C<last> and suchlike.
7278
7279 I<loop> is an optional preconstructed C<enterloop> op to use in the
7280 loop; if it is null then a suitable op will be constructed automatically.
7281 I<expr> supplies the loop's controlling expression.  I<block> supplies the
7282 main body of the loop, and I<cont> optionally supplies a C<continue> block
7283 that operates as a second half of the body.  All of these optree inputs
7284 are consumed by this function and become part of the constructed op tree.
7285
7286 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7287 op and, shifted up eight bits, the eight bits of C<op_private> for
7288 the C<leaveloop> op, except that (in both cases) some bits will be set
7289 automatically.  I<debuggable> is currently unused and should always be 1.
7290 I<has_my> can be supplied as true to force the
7291 loop body to be enclosed in its own scope.
7292
7293 =cut
7294 */
7295
7296 OP *
7297 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
7298         OP *expr, OP *block, OP *cont, I32 has_my)
7299 {
7300     dVAR;
7301     OP *redo;
7302     OP *next = NULL;
7303     OP *listop;
7304     OP *o;
7305     U8 loopflags = 0;
7306
7307     PERL_UNUSED_ARG(debuggable);
7308
7309     if (expr) {
7310         if (expr->op_type == OP_READLINE
7311          || expr->op_type == OP_READDIR
7312          || expr->op_type == OP_GLOB
7313          || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
7314                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
7315             expr = newUNOP(OP_DEFINED, 0,
7316                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
7317         } else if (expr->op_flags & OPf_KIDS) {
7318             const OP * const k1 = ((UNOP*)expr)->op_first;
7319             const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
7320             switch (expr->op_type) {
7321               case OP_NULL:
7322                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
7323                       && (k2->op_flags & OPf_STACKED)
7324                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7325                     expr = newUNOP(OP_DEFINED, 0, expr);
7326                 break;
7327
7328               case OP_SASSIGN:
7329                 if (k1 && (k1->op_type == OP_READDIR
7330                       || k1->op_type == OP_GLOB
7331                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7332                      || k1->op_type == OP_EACH
7333                      || k1->op_type == OP_AEACH))
7334                     expr = newUNOP(OP_DEFINED, 0, expr);
7335                 break;
7336             }
7337         }
7338     }
7339
7340     if (!block)
7341         block = newOP(OP_NULL, 0);
7342     else if (cont || has_my) {
7343         block = op_scope(block);
7344     }
7345
7346     if (cont) {
7347         next = LINKLIST(cont);
7348     }
7349     if (expr) {
7350         OP * const unstack = newOP(OP_UNSTACK, 0);
7351         if (!next)
7352             next = unstack;
7353         cont = op_append_elem(OP_LINESEQ, cont, unstack);
7354     }
7355
7356     assert(block);
7357     listop = op_append_list(OP_LINESEQ, block, cont);
7358     assert(listop);
7359     redo = LINKLIST(listop);
7360
7361     if (expr) {
7362         scalar(listop);
7363         o = new_logop(OP_AND, 0, &expr, &listop);
7364         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
7365             op_free((OP*)loop);
7366             return expr;                /* listop already freed by new_logop */
7367         }
7368         if (listop)
7369             ((LISTOP*)listop)->op_last->op_next =
7370                 (o == listop ? redo : LINKLIST(o));
7371     }
7372     else
7373         o = listop;
7374
7375     if (!loop) {
7376         NewOp(1101,loop,1,LOOP);
7377         CHANGE_TYPE(loop, OP_ENTERLOOP);
7378         loop->op_private = 0;
7379         loop->op_next = (OP*)loop;
7380     }
7381
7382     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
7383
7384     loop->op_redoop = redo;
7385     loop->op_lastop = o;
7386     o->op_private |= loopflags;
7387
7388     if (next)
7389         loop->op_nextop = next;
7390     else
7391         loop->op_nextop = o;
7392
7393     o->op_flags |= flags;
7394     o->op_private |= (flags >> 8);
7395     return o;
7396 }
7397
7398 /*
7399 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
7400
7401 Constructs, checks, and returns an op tree expressing a C<foreach>
7402 loop (iteration through a list of values).  This is a heavyweight loop,
7403 with structure that allows exiting the loop by C<last> and suchlike.
7404
7405 I<sv> optionally supplies the variable that will be aliased to each
7406 item in turn; if null, it defaults to C<$_> (either lexical or global).
7407 I<expr> supplies the list of values to iterate over.  I<block> supplies
7408 the main body of the loop, and I<cont> optionally supplies a C<continue>
7409 block that operates as a second half of the body.  All of these optree
7410 inputs are consumed by this function and become part of the constructed
7411 op tree.
7412
7413 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7414 op and, shifted up eight bits, the eight bits of C<op_private> for
7415 the C<leaveloop> op, except that (in both cases) some bits will be set
7416 automatically.
7417
7418 =cut
7419 */
7420
7421 OP *
7422 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
7423 {
7424     dVAR;
7425     LOOP *loop;
7426     OP *wop;
7427     PADOFFSET padoff = 0;
7428     I32 iterflags = 0;
7429     I32 iterpflags = 0;
7430
7431     PERL_ARGS_ASSERT_NEWFOROP;
7432
7433     if (sv) {
7434         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
7435             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
7436             CHANGE_TYPE(sv, OP_RV2GV);
7437
7438             /* The op_type check is needed to prevent a possible segfault
7439              * if the loop variable is undeclared and 'strict vars' is in
7440              * effect. This is illegal but is nonetheless parsed, so we
7441              * may reach this point with an OP_CONST where we're expecting
7442              * an OP_GV.
7443              */
7444             if (cUNOPx(sv)->op_first->op_type == OP_GV
7445              && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
7446                 iterpflags |= OPpITER_DEF;
7447         }
7448         else if (sv->op_type == OP_PADSV) { /* private variable */
7449             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
7450             padoff = sv->op_targ;
7451             sv->op_targ = 0;
7452             op_free(sv);
7453             sv = NULL;
7454             PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
7455         }
7456         else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
7457             NOOP;
7458         else
7459             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
7460         if (padoff) {
7461             PADNAME * const pn = PAD_COMPNAME(padoff);
7462             const char * const name = PadnamePV(pn);
7463
7464             if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
7465                 iterpflags |= OPpITER_DEF;
7466         }
7467     }
7468     else {
7469         const PADOFFSET offset = pad_findmy_pvs("$_", 0);
7470         if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7471             sv = newGVOP(OP_GV, 0, PL_defgv);
7472         }
7473         else {
7474             padoff = offset;
7475         }
7476         iterpflags |= OPpITER_DEF;
7477     }
7478
7479     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
7480         expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
7481         iterflags |= OPf_STACKED;
7482     }
7483     else if (expr->op_type == OP_NULL &&
7484              (expr->op_flags & OPf_KIDS) &&
7485              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
7486     {
7487         /* Basically turn for($x..$y) into the same as for($x,$y), but we
7488          * set the STACKED flag to indicate that these values are to be
7489          * treated as min/max values by 'pp_enteriter'.
7490          */
7491         const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
7492         LOGOP* const range = (LOGOP*) flip->op_first;
7493         OP* const left  = range->op_first;
7494         OP* const right = OpSIBLING(left);
7495         LISTOP* listop;
7496
7497         range->op_flags &= ~OPf_KIDS;
7498         /* detach range's children */
7499         op_sibling_splice((OP*)range, NULL, -1, NULL);
7500
7501         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
7502         listop->op_first->op_next = range->op_next;
7503         left->op_next = range->op_other;
7504         right->op_next = (OP*)listop;
7505         listop->op_next = listop->op_first;
7506
7507         op_free(expr);
7508         expr = (OP*)(listop);
7509         op_null(expr);
7510         iterflags |= OPf_STACKED;
7511     }
7512     else {
7513         expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
7514     }
7515
7516     loop = (LOOP*)list(op_convert_list(OP_ENTERITER, iterflags,
7517                                op_append_elem(OP_LIST, expr, scalar(sv))));
7518     assert(!loop->op_next);
7519     /* for my  $x () sets OPpLVAL_INTRO;
7520      * for our $x () sets OPpOUR_INTRO */
7521     loop->op_private = (U8)iterpflags;
7522     if (loop->op_slabbed
7523      && DIFF(loop, OpSLOT(loop)->opslot_next)
7524          < SIZE_TO_PSIZE(sizeof(LOOP)))
7525     {
7526         LOOP *tmp;
7527         NewOp(1234,tmp,1,LOOP);
7528         Copy(loop,tmp,1,LISTOP);
7529 #ifdef PERL_OP_PARENT
7530         assert(loop->op_last->op_sibling == (OP*)loop);
7531         loop->op_last->op_sibling = (OP*)tmp; /*point back to new parent */
7532 #endif
7533         S_op_destroy(aTHX_ (OP*)loop);
7534         loop = tmp;
7535     }
7536     else if (!loop->op_slabbed)
7537     {
7538         loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
7539 #ifdef PERL_OP_PARENT
7540         loop->op_last->op_sibling = (OP *)loop;
7541 #endif
7542     }
7543     loop->op_targ = padoff;
7544     wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
7545     return wop;
7546 }
7547
7548 /*
7549 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
7550
7551 Constructs, checks, and returns a loop-exiting op (such as C<goto>
7552 or C<last>).  I<type> is the opcode.  I<label> supplies the parameter
7553 determining the target of the op; it is consumed by this function and
7554 becomes part of the constructed op tree.
7555
7556 =cut
7557 */
7558
7559 OP*
7560 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
7561 {
7562     OP *o = NULL;
7563
7564     PERL_ARGS_ASSERT_NEWLOOPEX;
7565
7566     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
7567         || type == OP_CUSTOM);
7568
7569     if (type != OP_GOTO) {
7570         /* "last()" means "last" */
7571         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
7572             o = newOP(type, OPf_SPECIAL);
7573         }
7574     }
7575     else {
7576         /* Check whether it's going to be a goto &function */
7577         if (label->op_type == OP_ENTERSUB
7578                 && !(label->op_flags & OPf_STACKED))
7579             label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
7580     }
7581
7582     /* Check for a constant argument */
7583     if (label->op_type == OP_CONST) {
7584             SV * const sv = ((SVOP *)label)->op_sv;
7585             STRLEN l;
7586             const char *s = SvPV_const(sv,l);
7587             if (l == strlen(s)) {
7588                 o = newPVOP(type,
7589                             SvUTF8(((SVOP*)label)->op_sv),
7590                             savesharedpv(
7591                                 SvPV_nolen_const(((SVOP*)label)->op_sv)));
7592             }
7593     }
7594
7595     /* If we have already created an op, we do not need the label. */
7596     if (o)
7597                 op_free(label);
7598     else o = newUNOP(type, OPf_STACKED, label);
7599
7600     PL_hints |= HINT_BLOCK_SCOPE;
7601     return o;
7602 }
7603
7604 /* if the condition is a literal array or hash
7605    (or @{ ... } etc), make a reference to it.
7606  */
7607 STATIC OP *
7608 S_ref_array_or_hash(pTHX_ OP *cond)
7609 {
7610     if (cond
7611     && (cond->op_type == OP_RV2AV
7612     ||  cond->op_type == OP_PADAV
7613     ||  cond->op_type == OP_RV2HV
7614     ||  cond->op_type == OP_PADHV))
7615
7616         return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
7617
7618     else if(cond
7619     && (cond->op_type == OP_ASLICE
7620     ||  cond->op_type == OP_KVASLICE
7621     ||  cond->op_type == OP_HSLICE
7622     ||  cond->op_type == OP_KVHSLICE)) {
7623
7624         /* anonlist now needs a list from this op, was previously used in
7625          * scalar context */
7626         cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
7627         cond->op_flags |= OPf_WANT_LIST;
7628
7629         return newANONLIST(op_lvalue(cond, OP_ANONLIST));
7630     }
7631
7632     else
7633         return cond;
7634 }
7635
7636 /* These construct the optree fragments representing given()
7637    and when() blocks.
7638
7639    entergiven and enterwhen are LOGOPs; the op_other pointer
7640    points up to the associated leave op. We need this so we
7641    can put it in the context and make break/continue work.
7642    (Also, of course, pp_enterwhen will jump straight to
7643    op_other if the match fails.)
7644  */
7645
7646 STATIC OP *
7647 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
7648                    I32 enter_opcode, I32 leave_opcode,
7649                    PADOFFSET entertarg)
7650 {
7651     dVAR;
7652     LOGOP *enterop;
7653     OP *o;
7654
7655     PERL_ARGS_ASSERT_NEWGIVWHENOP;
7656
7657     enterop = S_alloc_LOGOP(aTHX_ enter_opcode, block, NULL);
7658     enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
7659     enterop->op_private = 0;
7660
7661     o = newUNOP(leave_opcode, 0, (OP *) enterop);
7662
7663     if (cond) {
7664         /* prepend cond if we have one */
7665         op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
7666
7667         o->op_next = LINKLIST(cond);
7668         cond->op_next = (OP *) enterop;
7669     }
7670     else {
7671         /* This is a default {} block */
7672         enterop->op_flags |= OPf_SPECIAL;
7673         o      ->op_flags |= OPf_SPECIAL;
7674
7675         o->op_next = (OP *) enterop;
7676     }
7677
7678     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
7679                                        entergiven and enterwhen both
7680                                        use ck_null() */
7681
7682     enterop->op_next = LINKLIST(block);
7683     block->op_next = enterop->op_other = o;
7684
7685     return o;
7686 }
7687
7688 /* Does this look like a boolean operation? For these purposes
7689    a boolean operation is:
7690      - a subroutine call [*]
7691      - a logical connective
7692      - a comparison operator
7693      - a filetest operator, with the exception of -s -M -A -C
7694      - defined(), exists() or eof()
7695      - /$re/ or $foo =~ /$re/
7696
7697    [*] possibly surprising
7698  */
7699 STATIC bool
7700 S_looks_like_bool(pTHX_ const OP *o)
7701 {
7702     PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
7703
7704     switch(o->op_type) {
7705         case OP_OR:
7706         case OP_DOR:
7707             return looks_like_bool(cLOGOPo->op_first);
7708
7709         case OP_AND:
7710         {
7711             OP* sibl = OpSIBLING(cLOGOPo->op_first);
7712             ASSUME(sibl);
7713             return (
7714                 looks_like_bool(cLOGOPo->op_first)
7715              && looks_like_bool(sibl));
7716         }
7717
7718         case OP_NULL:
7719         case OP_SCALAR:
7720             return (
7721                 o->op_flags & OPf_KIDS
7722             && looks_like_bool(cUNOPo->op_first));
7723
7724         case OP_ENTERSUB:
7725
7726         case OP_NOT:    case OP_XOR:
7727
7728         case OP_EQ:     case OP_NE:     case OP_LT:
7729         case OP_GT:     case OP_LE:     case OP_GE:
7730
7731         case OP_I_EQ:   case OP_I_NE:   case OP_I_LT:
7732         case OP_I_GT:   case OP_I_LE:   case OP_I_GE:
7733
7734         case OP_SEQ:    case OP_SNE:    case OP_SLT:
7735         case OP_SGT:    case OP_SLE:    case OP_SGE:
7736
7737         case OP_SMARTMATCH:
7738
7739         case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
7740         case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
7741         case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
7742         case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
7743         case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
7744         case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
7745         case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
7746         case OP_FTTEXT:   case OP_FTBINARY:
7747
7748         case OP_DEFINED: case OP_EXISTS:
7749         case OP_MATCH:   case OP_EOF:
7750
7751         case OP_FLOP:
7752
7753             return TRUE;
7754
7755         case OP_CONST:
7756             /* Detect comparisons that have been optimized away */
7757             if (cSVOPo->op_sv == &PL_sv_yes
7758             ||  cSVOPo->op_sv == &PL_sv_no)
7759
7760                 return TRUE;
7761             else
7762                 return FALSE;
7763
7764         /* FALLTHROUGH */
7765         default:
7766             return FALSE;
7767     }
7768 }
7769
7770 /*
7771 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
7772
7773 Constructs, checks, and returns an op tree expressing a C<given> block.
7774 I<cond> supplies the expression that will be locally assigned to a lexical
7775 variable, and I<block> supplies the body of the C<given> construct; they
7776 are consumed by this function and become part of the constructed op tree.
7777 I<defsv_off> is the pad offset of the scalar lexical variable that will
7778 be affected.  If it is 0, the global $_ will be used.
7779
7780 =cut
7781 */
7782
7783 OP *
7784 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
7785 {
7786     PERL_ARGS_ASSERT_NEWGIVENOP;
7787     return newGIVWHENOP(
7788         ref_array_or_hash(cond),
7789         block,
7790         OP_ENTERGIVEN, OP_LEAVEGIVEN,
7791         defsv_off);
7792 }
7793
7794 /*
7795 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
7796
7797 Constructs, checks, and returns an op tree expressing a C<when> block.
7798 I<cond> supplies the test expression, and I<block> supplies the block
7799 that will be executed if the test evaluates to true; they are consumed
7800 by this function and become part of the constructed op tree.  I<cond>
7801 will be interpreted DWIMically, often as a comparison against C<$_>,
7802 and may be null to generate a C<default> block.
7803
7804 =cut
7805 */
7806
7807 OP *
7808 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
7809 {
7810     const bool cond_llb = (!cond || looks_like_bool(cond));
7811     OP *cond_op;
7812
7813     PERL_ARGS_ASSERT_NEWWHENOP;
7814
7815     if (cond_llb)
7816         cond_op = cond;
7817     else {
7818         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
7819                 newDEFSVOP(),
7820                 scalar(ref_array_or_hash(cond)));
7821     }
7822
7823     return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
7824 }
7825
7826 /* must not conflict with SVf_UTF8 */
7827 #define CV_CKPROTO_CURSTASH     0x1
7828
7829 void
7830 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
7831                     const STRLEN len, const U32 flags)
7832 {
7833     SV *name = NULL, *msg;
7834     const char * cvp = SvROK(cv)
7835                         ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
7836                            ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
7837                            : ""
7838                         : CvPROTO(cv);
7839     STRLEN clen = CvPROTOLEN(cv), plen = len;
7840
7841     PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
7842
7843     if (p == NULL && cvp == NULL)
7844         return;
7845
7846     if (!ckWARN_d(WARN_PROTOTYPE))
7847         return;
7848
7849     if (p && cvp) {
7850         p = S_strip_spaces(aTHX_ p, &plen);
7851         cvp = S_strip_spaces(aTHX_ cvp, &clen);
7852         if ((flags & SVf_UTF8) == SvUTF8(cv)) {
7853             if (plen == clen && memEQ(cvp, p, plen))
7854                 return;
7855         } else {
7856             if (flags & SVf_UTF8) {
7857                 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
7858                     return;
7859             }
7860             else {
7861                 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
7862                     return;
7863             }
7864         }
7865     }
7866
7867     msg = sv_newmortal();
7868
7869     if (gv)
7870     {
7871         if (isGV(gv))
7872             gv_efullname3(name = sv_newmortal(), gv, NULL);
7873         else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
7874             name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
7875         else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
7876             name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
7877             sv_catpvs(name, "::");
7878             if (SvROK(gv)) {
7879                 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
7880                 assert (CvNAMED(SvRV_const(gv)));
7881                 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
7882             }
7883             else sv_catsv(name, (SV *)gv);
7884         }
7885         else name = (SV *)gv;
7886     }
7887     sv_setpvs(msg, "Prototype mismatch:");
7888     if (name)
7889         Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
7890     if (cvp)
7891         Perl_sv_catpvf(aTHX_ msg, " (%"UTF8f")",
7892             UTF8fARG(SvUTF8(cv),clen,cvp)
7893         );
7894     else
7895         sv_catpvs(msg, ": none");
7896     sv_catpvs(msg, " vs ");
7897     if (p)
7898         Perl_sv_catpvf(aTHX_ msg, "(%"UTF8f")", UTF8fARG(flags & SVf_UTF8,len,p));
7899     else
7900         sv_catpvs(msg, "none");
7901     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
7902 }
7903
7904 static void const_sv_xsub(pTHX_ CV* cv);
7905 static void const_av_xsub(pTHX_ CV* cv);
7906
7907 /*
7908
7909 =head1 Optree Manipulation Functions
7910
7911 =for apidoc cv_const_sv
7912
7913 If C<cv> is a constant sub eligible for inlining, returns the constant
7914 value returned by the sub.  Otherwise, returns NULL.
7915
7916 Constant subs can be created with C<newCONSTSUB> or as described in
7917 L<perlsub/"Constant Functions">.
7918
7919 =cut
7920 */
7921 SV *
7922 Perl_cv_const_sv(const CV *const cv)
7923 {
7924     SV *sv;
7925     if (!cv)
7926         return NULL;
7927     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
7928         return NULL;
7929     sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7930     if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
7931     return sv;
7932 }
7933
7934 SV *
7935 Perl_cv_const_sv_or_av(const CV * const cv)
7936 {
7937     if (!cv)
7938         return NULL;
7939     if (SvROK(cv)) return SvRV((SV *)cv);
7940     assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
7941     return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7942 }
7943
7944 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
7945  * Can be called in 2 ways:
7946  *
7947  * !allow_lex
7948  *      look for a single OP_CONST with attached value: return the value
7949  *
7950  * allow_lex && !CvCONST(cv);
7951  *
7952  *      examine the clone prototype, and if contains only a single
7953  *      OP_CONST, return the value; or if it contains a single PADSV ref-
7954  *      erencing an outer lexical, turn on CvCONST to indicate the CV is
7955  *      a candidate for "constizing" at clone time, and return NULL.
7956  */
7957
7958 static SV *
7959 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
7960 {
7961     SV *sv = NULL;
7962     bool padsv = FALSE;
7963
7964     assert(o);
7965     assert(cv);
7966
7967     for (; o; o = o->op_next) {
7968         const OPCODE type = o->op_type;
7969
7970         if (type == OP_NEXTSTATE || type == OP_LINESEQ
7971              || type == OP_NULL
7972              || type == OP_PUSHMARK)
7973                 continue;
7974         if (type == OP_DBSTATE)
7975                 continue;
7976         if (type == OP_LEAVESUB)
7977             break;
7978         if (sv)
7979             return NULL;
7980         if (type == OP_CONST && cSVOPo->op_sv)
7981             sv = cSVOPo->op_sv;
7982         else if (type == OP_UNDEF && !o->op_private) {
7983             sv = newSV(0);
7984             SAVEFREESV(sv);
7985         }
7986         else if (allow_lex && type == OP_PADSV) {
7987                 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
7988                 {
7989                     sv = &PL_sv_undef; /* an arbitrary non-null value */
7990                     padsv = TRUE;
7991                 }
7992                 else
7993                     return NULL;
7994         }
7995         else {
7996             return NULL;
7997         }
7998     }
7999     if (padsv) {
8000         CvCONST_on(cv);
8001         return NULL;
8002     }
8003     return sv;
8004 }
8005
8006 static bool
8007 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
8008                         PADNAME * const name, SV ** const const_svp)
8009 {
8010     assert (cv);
8011     assert (o || name);
8012     assert (const_svp);
8013     if ((!block
8014          )) {
8015         if (CvFLAGS(PL_compcv)) {
8016             /* might have had built-in attrs applied */
8017             const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
8018             if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
8019              && ckWARN(WARN_MISC))
8020             {
8021                 /* protect against fatal warnings leaking compcv */
8022                 SAVEFREESV(PL_compcv);
8023                 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
8024                 SvREFCNT_inc_simple_void_NN(PL_compcv);
8025             }
8026             CvFLAGS(cv) |=
8027                 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
8028                   & ~(CVf_LVALUE * pureperl));
8029         }
8030         return FALSE;
8031     }
8032
8033     /* redundant check for speed: */
8034     if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
8035         const line_t oldline = CopLINE(PL_curcop);
8036         SV *namesv = o
8037             ? cSVOPo->op_sv
8038             : sv_2mortal(newSVpvn_utf8(
8039                 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
8040               ));
8041         if (PL_parser && PL_parser->copline != NOLINE)
8042             /* This ensures that warnings are reported at the first
8043                line of a redefinition, not the last.  */
8044             CopLINE_set(PL_curcop, PL_parser->copline);
8045         /* protect against fatal warnings leaking compcv */
8046         SAVEFREESV(PL_compcv);
8047         report_redefined_cv(namesv, cv, const_svp);
8048         SvREFCNT_inc_simple_void_NN(PL_compcv);
8049         CopLINE_set(PL_curcop, oldline);
8050     }
8051     SAVEFREESV(cv);
8052     return TRUE;
8053 }
8054
8055 CV *
8056 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
8057 {
8058     CV **spot;
8059     SV **svspot;
8060     const char *ps;
8061     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
8062     U32 ps_utf8 = 0;
8063     CV *cv = NULL;
8064     CV *compcv = PL_compcv;
8065     SV *const_sv;
8066     PADNAME *name;
8067     PADOFFSET pax = o->op_targ;
8068     CV *outcv = CvOUTSIDE(PL_compcv);
8069     CV *clonee = NULL;
8070     HEK *hek = NULL;
8071     bool reusable = FALSE;
8072     OP *start = NULL;
8073 #ifdef PERL_DEBUG_READONLY_OPS
8074     OPSLAB *slab = NULL;
8075 #endif
8076
8077     PERL_ARGS_ASSERT_NEWMYSUB;
8078
8079     /* Find the pad slot for storing the new sub.
8080        We cannot use PL_comppad, as it is the pad owned by the new sub.  We
8081        need to look in CvOUTSIDE and find the pad belonging to the enclos-
8082        ing sub.  And then we need to dig deeper if this is a lexical from
8083        outside, as in:
8084            my sub foo; sub { sub foo { } }
8085      */
8086    redo:
8087     name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
8088     if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
8089         pax = PARENT_PAD_INDEX(name);
8090         outcv = CvOUTSIDE(outcv);
8091         assert(outcv);
8092         goto redo;
8093     }
8094     svspot =
8095         &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
8096                         [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
8097     spot = (CV **)svspot;
8098
8099     if (!(PL_parser && PL_parser->error_count))
8100         move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name));
8101
8102     if (proto) {
8103         assert(proto->op_type == OP_CONST);
8104         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
8105         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
8106     }
8107     else
8108         ps = NULL;
8109
8110     if (proto)
8111         SAVEFREEOP(proto);
8112     if (attrs)
8113         SAVEFREEOP(attrs);
8114
8115     if (PL_parser && PL_parser->error_count) {
8116         op_free(block);
8117         SvREFCNT_dec(PL_compcv);
8118         PL_compcv = 0;
8119         goto done;
8120     }
8121
8122     if (CvDEPTH(outcv) && CvCLONE(compcv)) {
8123         cv = *spot;
8124         svspot = (SV **)(spot = &clonee);
8125     }
8126     else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
8127         cv = *spot;
8128     else {
8129         assert (SvTYPE(*spot) == SVt_PVCV);
8130         if (CvNAMED(*spot))
8131             hek = CvNAME_HEK(*spot);
8132         else {
8133             dVAR;
8134             U32 hash;
8135             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
8136             CvNAME_HEK_set(*spot, hek =
8137                 share_hek(
8138                     PadnamePV(name)+1,
8139                     (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
8140                     hash
8141                 )
8142             );
8143             CvLEXICAL_on(*spot);
8144         }
8145         cv = PadnamePROTOCV(name);
8146         svspot = (SV **)(spot = &PadnamePROTOCV(name));
8147     }
8148
8149     if (block) {
8150         /* This makes sub {}; work as expected.  */
8151         if (block->op_type == OP_STUB) {
8152             const line_t l = PL_parser->copline;
8153             op_free(block);
8154             block = newSTATEOP(0, NULL, 0);
8155             PL_parser->copline = l;
8156         }
8157         block = CvLVALUE(compcv)
8158              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
8159                    ? newUNOP(OP_LEAVESUBLV, 0,
8160                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
8161                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
8162         start = LINKLIST(block);
8163         block->op_next = 0;
8164     }
8165
8166     if (!block || !ps || *ps || attrs
8167         || CvLVALUE(compcv)
8168         )
8169         const_sv = NULL;
8170     else
8171         const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
8172
8173     if (cv) {
8174         const bool exists = CvROOT(cv) || CvXSUB(cv);
8175
8176         /* if the subroutine doesn't exist and wasn't pre-declared
8177          * with a prototype, assume it will be AUTOLOADed,
8178          * skipping the prototype check
8179          */
8180         if (exists || SvPOK(cv))
8181             cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
8182                                  ps_utf8);
8183         /* already defined? */
8184         if (exists) {
8185             if (S_already_defined(aTHX_ cv,block,NULL,name,&const_sv))
8186                 cv = NULL;
8187             else {
8188                 if (attrs) goto attrs;
8189                 /* just a "sub foo;" when &foo is already defined */
8190                 SAVEFREESV(compcv);
8191                 goto done;
8192             }
8193         }
8194         else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
8195             cv = NULL;
8196             reusable = TRUE;
8197         }
8198     }
8199     if (const_sv) {
8200         SvREFCNT_inc_simple_void_NN(const_sv);
8201         SvFLAGS(const_sv) |= SVs_PADTMP;
8202         if (cv) {
8203             assert(!CvROOT(cv) && !CvCONST(cv));
8204             cv_forget_slab(cv);
8205         }
8206         else {
8207             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8208             CvFILE_set_from_cop(cv, PL_curcop);
8209             CvSTASH_set(cv, PL_curstash);
8210             *spot = cv;
8211         }
8212         sv_setpvs(MUTABLE_SV(cv), "");  /* prototype is "" */
8213         CvXSUBANY(cv).any_ptr = const_sv;
8214         CvXSUB(cv) = const_sv_xsub;
8215         CvCONST_on(cv);
8216         CvISXSUB_on(cv);
8217         PoisonPADLIST(cv);
8218         CvFLAGS(cv) |= CvMETHOD(compcv);
8219         op_free(block);
8220         SvREFCNT_dec(compcv);
8221         PL_compcv = NULL;
8222         goto setname;
8223     }
8224     /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
8225        determine whether this sub definition is in the same scope as its
8226        declaration.  If this sub definition is inside an inner named pack-
8227        age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
8228        the package sub.  So check PadnameOUTER(name) too.
8229      */
8230     if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
8231         assert(!CvWEAKOUTSIDE(compcv));
8232         SvREFCNT_dec(CvOUTSIDE(compcv));
8233         CvWEAKOUTSIDE_on(compcv);
8234     }
8235     /* XXX else do we have a circular reference? */
8236     if (cv) {   /* must reuse cv in case stub is referenced elsewhere */
8237         /* transfer PL_compcv to cv */
8238         if (block
8239         ) {
8240             cv_flags_t preserved_flags =
8241                 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
8242             PADLIST *const temp_padl = CvPADLIST(cv);
8243             CV *const temp_cv = CvOUTSIDE(cv);
8244             const cv_flags_t other_flags =
8245                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8246             OP * const cvstart = CvSTART(cv);
8247
8248             SvPOK_off(cv);
8249             CvFLAGS(cv) =
8250                 CvFLAGS(compcv) | preserved_flags;
8251             CvOUTSIDE(cv) = CvOUTSIDE(compcv);
8252             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
8253             CvPADLIST_set(cv, CvPADLIST(compcv));
8254             CvOUTSIDE(compcv) = temp_cv;
8255             CvPADLIST_set(compcv, temp_padl);
8256             CvSTART(cv) = CvSTART(compcv);
8257             CvSTART(compcv) = cvstart;
8258             CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8259             CvFLAGS(compcv) |= other_flags;
8260
8261             if (CvFILE(cv) && CvDYNFILE(cv)) {
8262                 Safefree(CvFILE(cv));
8263             }
8264
8265             /* inner references to compcv must be fixed up ... */
8266             pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
8267             if (PERLDB_INTER)/* Advice debugger on the new sub. */
8268               ++PL_sub_generation;
8269         }
8270         else {
8271             /* Might have had built-in attributes applied -- propagate them. */
8272             CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
8273         }
8274         /* ... before we throw it away */
8275         SvREFCNT_dec(compcv);
8276         PL_compcv = compcv = cv;
8277     }
8278     else {
8279         cv = compcv;
8280         *spot = cv;
8281     }
8282    setname:
8283     CvLEXICAL_on(cv);
8284     if (!CvNAME_HEK(cv)) {
8285         if (hek) (void)share_hek_hek(hek);
8286         else {
8287             dVAR;
8288             U32 hash;
8289             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
8290             hek = share_hek(PadnamePV(name)+1,
8291                       (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
8292                       hash);
8293         }
8294         CvNAME_HEK_set(cv, hek);
8295     }
8296     if (const_sv) goto clone;
8297
8298     CvFILE_set_from_cop(cv, PL_curcop);
8299     CvSTASH_set(cv, PL_curstash);
8300
8301     if (ps) {
8302         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8303         if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
8304     }
8305
8306     if (!block)
8307         goto attrs;
8308
8309     /* If we assign an optree to a PVCV, then we've defined a subroutine that
8310        the debugger could be able to set a breakpoint in, so signal to
8311        pp_entereval that it should not throw away any saved lines at scope
8312        exit.  */
8313
8314     PL_breakable_sub_gen++;
8315     CvROOT(cv) = block;
8316     CvROOT(cv)->op_private |= OPpREFCOUNTED;
8317     OpREFCNT_set(CvROOT(cv), 1);
8318     /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8319        itself has a refcount. */
8320     CvSLABBED_off(cv);
8321     OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8322 #ifdef PERL_DEBUG_READONLY_OPS
8323     slab = (OPSLAB *)CvSTART(cv);
8324 #endif
8325     CvSTART(cv) = start;
8326     CALL_PEEP(start);
8327     finalize_optree(CvROOT(cv));
8328     S_prune_chain_head(&CvSTART(cv));
8329
8330     /* now that optimizer has done its work, adjust pad values */
8331
8332     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8333
8334   attrs:
8335     if (attrs) {
8336         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8337         apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
8338     }
8339
8340     if (block) {
8341         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8342             SV * const tmpstr = sv_newmortal();
8343             GV * const db_postponed = gv_fetchpvs("DB::postponed",
8344                                                   GV_ADDMULTI, SVt_PVHV);
8345             HV *hv;
8346             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8347                                           CopFILE(PL_curcop),
8348                                           (long)PL_subline,
8349                                           (long)CopLINE(PL_curcop));
8350             if (HvNAME_HEK(PL_curstash)) {
8351                 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
8352                 sv_catpvs(tmpstr, "::");
8353             }
8354             else sv_setpvs(tmpstr, "__ANON__::");
8355             sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
8356                             PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
8357             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8358                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8359             hv = GvHVn(db_postponed);
8360             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8361                 CV * const pcv = GvCV(db_postponed);
8362                 if (pcv) {
8363                     dSP;
8364                     PUSHMARK(SP);
8365                     XPUSHs(tmpstr);
8366                     PUTBACK;
8367                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
8368                 }
8369             }
8370         }
8371     }
8372
8373   clone:
8374     if (clonee) {
8375         assert(CvDEPTH(outcv));
8376         spot = (CV **)
8377             &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
8378         if (reusable) cv_clone_into(clonee, *spot);
8379         else *spot = cv_clone(clonee);
8380         SvREFCNT_dec_NN(clonee);
8381         cv = *spot;
8382     }
8383     if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
8384         PADOFFSET depth = CvDEPTH(outcv);
8385         while (--depth) {
8386             SV *oldcv;
8387             svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
8388             oldcv = *svspot;
8389             *svspot = SvREFCNT_inc_simple_NN(cv);
8390             SvREFCNT_dec(oldcv);
8391         }
8392     }
8393
8394   done:
8395     if (PL_parser)
8396         PL_parser->copline = NOLINE;
8397     LEAVE_SCOPE(floor);
8398 #ifdef PERL_DEBUG_READONLY_OPS
8399     if (slab)
8400         Slab_to_ro(slab);
8401 #endif
8402     if (o) op_free(o);
8403     return cv;
8404 }
8405
8406 /* _x = extended */
8407 CV *
8408 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
8409                             OP *block, bool o_is_gv)
8410 {
8411     GV *gv;
8412     const char *ps;
8413     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
8414     U32 ps_utf8 = 0;
8415     CV *cv = NULL;
8416     SV *const_sv;
8417     const bool ec = PL_parser && PL_parser->error_count;
8418     /* If the subroutine has no body, no attributes, and no builtin attributes
8419        then it's just a sub declaration, and we may be able to get away with
8420        storing with a placeholder scalar in the symbol table, rather than a
8421        full CV.  If anything is present then it will take a full CV to
8422        store it.  */
8423     const I32 gv_fetch_flags
8424         = ec ? GV_NOADD_NOINIT :
8425         (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
8426         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
8427     STRLEN namlen = 0;
8428     const char * const name =
8429          o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
8430     bool has_name;
8431     bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
8432     bool evanescent = FALSE;
8433     OP *start = NULL;
8434 #ifdef PERL_DEBUG_READONLY_OPS
8435     OPSLAB *slab = NULL;
8436 #endif
8437
8438     if (o_is_gv) {
8439         gv = (GV*)o;
8440         o = NULL;
8441         has_name = TRUE;
8442     } else if (name) {
8443         /* Try to optimise and avoid creating a GV.  Instead, the CV’s name
8444            hek and CvSTASH pointer together can imply the GV.  If the name
8445            contains a package name, then GvSTASH(CvGV(cv)) may differ from
8446            CvSTASH, so forego the optimisation if we find any.
8447            Also, we may be called from load_module at run time, so
8448            PL_curstash (which sets CvSTASH) may not point to the stash the
8449            sub is stored in.  */
8450         const I32 flags =
8451            ec ? GV_NOADD_NOINIT
8452               :   PL_curstash != CopSTASH(PL_curcop)
8453                || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
8454                     ? gv_fetch_flags
8455                     : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
8456         gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
8457         has_name = TRUE;
8458     } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
8459         SV * const sv = sv_newmortal();
8460         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
8461                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
8462                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
8463         gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
8464         has_name = TRUE;
8465     } else if (PL_curstash) {
8466         gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
8467         has_name = FALSE;
8468     } else {
8469         gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
8470         has_name = FALSE;
8471     }
8472     if (!ec)
8473         move_proto_attr(&proto, &attrs,
8474                         isGV(gv) ? gv : (GV *)cSVOPo->op_sv);
8475
8476     if (proto) {
8477         assert(proto->op_type == OP_CONST);
8478         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
8479         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
8480     }
8481     else
8482         ps = NULL;
8483
8484     if (o)
8485         SAVEFREEOP(o);
8486     if (proto)
8487         SAVEFREEOP(proto);
8488     if (attrs)
8489         SAVEFREEOP(attrs);
8490
8491     if (ec) {
8492         op_free(block);
8493         if (name) SvREFCNT_dec(PL_compcv);
8494         else cv = PL_compcv;
8495         PL_compcv = 0;
8496         if (name && block) {
8497             const char *s = strrchr(name, ':');
8498             s = s ? s+1 : name;
8499             if (strEQ(s, "BEGIN")) {
8500                 if (PL_in_eval & EVAL_KEEPERR)
8501                     Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
8502                 else {
8503                     SV * const errsv = ERRSV;
8504                     /* force display of errors found but not reported */
8505                     sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
8506                     Perl_croak_nocontext("%"SVf, SVfARG(errsv));
8507                 }
8508             }
8509         }
8510         goto done;
8511     }
8512
8513     if (!block && SvTYPE(gv) != SVt_PVGV) {
8514       /* If we are not defining a new sub and the existing one is not a
8515          full GV + CV... */
8516       if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
8517         /* We are applying attributes to an existing sub, so we need it
8518            upgraded if it is a constant.  */
8519         if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
8520             gv_init_pvn(gv, PL_curstash, name, namlen,
8521                         SVf_UTF8 * name_is_utf8);
8522       }
8523       else {                    /* Maybe prototype now, and had at maximum
8524                                    a prototype or const/sub ref before.  */
8525         if (SvTYPE(gv) > SVt_NULL) {
8526             cv_ckproto_len_flags((const CV *)gv,
8527                                  o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8528                                  ps_len, ps_utf8);
8529         }
8530         if (!SvROK(gv)) {
8531           if (ps) {
8532             sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
8533             if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
8534           }
8535           else
8536             sv_setiv(MUTABLE_SV(gv), -1);
8537         }
8538
8539         SvREFCNT_dec(PL_compcv);
8540         cv = PL_compcv = NULL;
8541         goto done;
8542       }
8543     }
8544
8545     cv = (!name || (isGV(gv) && GvCVGEN(gv)))
8546         ? NULL
8547         : isGV(gv)
8548             ? GvCV(gv)
8549             : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
8550                 ? (CV *)SvRV(gv)
8551                 : NULL;
8552
8553     if (block) {
8554         /* This makes sub {}; work as expected.  */
8555         if (block->op_type == OP_STUB) {
8556             const line_t l = PL_parser->copline;
8557             op_free(block);
8558             block = newSTATEOP(0, NULL, 0);
8559             PL_parser->copline = l;
8560         }
8561         block = CvLVALUE(PL_compcv)
8562              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
8563                     && (!isGV(gv) || !GvASSUMECV(gv)))
8564                    ? newUNOP(OP_LEAVESUBLV, 0,
8565                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
8566                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
8567         start = LINKLIST(block);
8568         block->op_next = 0;
8569     }
8570
8571     if (!block || !ps || *ps || attrs
8572         || CvLVALUE(PL_compcv)
8573         )
8574         const_sv = NULL;
8575     else
8576         const_sv =
8577             S_op_const_sv(aTHX_ start, PL_compcv, cBOOL(CvCLONE(PL_compcv)));
8578
8579     if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
8580         assert (block);
8581         cv_ckproto_len_flags((const CV *)gv,
8582                              o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8583                              ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
8584         if (SvROK(gv)) {
8585             /* All the other code for sub redefinition warnings expects the
8586                clobbered sub to be a CV.  Instead of making all those code
8587                paths more complex, just inline the RV version here.  */
8588             const line_t oldline = CopLINE(PL_curcop);
8589             assert(IN_PERL_COMPILETIME);
8590             if (PL_parser && PL_parser->copline != NOLINE)
8591                 /* This ensures that warnings are reported at the first
8592                    line of a redefinition, not the last.  */
8593                 CopLINE_set(PL_curcop, PL_parser->copline);
8594             /* protect against fatal warnings leaking compcv */
8595             SAVEFREESV(PL_compcv);
8596
8597             if (ckWARN(WARN_REDEFINE)
8598              || (  ckWARN_d(WARN_REDEFINE)
8599                 && (  !const_sv || SvRV(gv) == const_sv
8600                    || sv_cmp(SvRV(gv), const_sv)  )))
8601                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8602                           "Constant subroutine %"SVf" redefined",
8603                           SVfARG(cSVOPo->op_sv));
8604
8605             SvREFCNT_inc_simple_void_NN(PL_compcv);
8606             CopLINE_set(PL_curcop, oldline);
8607             SvREFCNT_dec(SvRV(gv));
8608         }
8609     }
8610
8611     if (cv) {
8612         const bool exists = CvROOT(cv) || CvXSUB(cv);
8613
8614         /* if the subroutine doesn't exist and wasn't pre-declared
8615          * with a prototype, assume it will be AUTOLOADed,
8616          * skipping the prototype check
8617          */
8618         if (exists || SvPOK(cv))
8619             cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
8620         /* already defined (or promised)? */
8621         if (exists || (isGV(gv) && GvASSUMECV(gv))) {
8622             if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv))
8623                 cv = NULL;
8624             else {
8625                 if (attrs) goto attrs;
8626                 /* just a "sub foo;" when &foo is already defined */
8627                 SAVEFREESV(PL_compcv);
8628                 goto done;
8629             }
8630         }
8631     }
8632     if (const_sv) {
8633         SvREFCNT_inc_simple_void_NN(const_sv);
8634         SvFLAGS(const_sv) |= SVs_PADTMP;
8635         if (cv) {
8636             assert(!CvROOT(cv) && !CvCONST(cv));
8637             cv_forget_slab(cv);
8638             sv_setpvs(MUTABLE_SV(cv), "");  /* prototype is "" */
8639             CvXSUBANY(cv).any_ptr = const_sv;
8640             CvXSUB(cv) = const_sv_xsub;
8641             CvCONST_on(cv);
8642             CvISXSUB_on(cv);
8643             PoisonPADLIST(cv);
8644             CvFLAGS(cv) |= CvMETHOD(PL_compcv);
8645         }
8646         else {
8647             if (isGV(gv) || CvMETHOD(PL_compcv)) {
8648                 if (name && isGV(gv))
8649                     GvCV_set(gv, NULL);
8650                 cv = newCONSTSUB_flags(
8651                     NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
8652                     const_sv
8653                 );
8654                 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
8655             }
8656             else {
8657                 if (!SvROK(gv)) {
8658                     SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8659                     prepare_SV_for_RV((SV *)gv);
8660                     SvOK_off((SV *)gv);
8661                     SvROK_on(gv);
8662                 }
8663                 SvRV_set(gv, const_sv);
8664             }
8665         }
8666         op_free(block);
8667         SvREFCNT_dec(PL_compcv);
8668         PL_compcv = NULL;
8669         goto done;
8670     }
8671     if (cv) {                           /* must reuse cv if autoloaded */
8672         /* transfer PL_compcv to cv */
8673         if (block
8674         ) {
8675             cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
8676             PADLIST *const temp_av = CvPADLIST(cv);
8677             CV *const temp_cv = CvOUTSIDE(cv);
8678             const cv_flags_t other_flags =
8679                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8680             OP * const cvstart = CvSTART(cv);
8681
8682             if (isGV(gv)) {
8683                 CvGV_set(cv,gv);
8684                 assert(!CvCVGV_RC(cv));
8685                 assert(CvGV(cv) == gv);
8686             }
8687             else {
8688                 dVAR;
8689                 U32 hash;
8690                 PERL_HASH(hash, name, namlen);
8691                 CvNAME_HEK_set(cv,
8692                                share_hek(name,
8693                                          name_is_utf8
8694                                             ? -(SSize_t)namlen
8695                                             :  (SSize_t)namlen,
8696                                          hash));
8697             }
8698
8699             SvPOK_off(cv);
8700             CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
8701                                              | CvNAMED(cv);
8702             CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
8703             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
8704             CvPADLIST_set(cv,CvPADLIST(PL_compcv));
8705             CvOUTSIDE(PL_compcv) = temp_cv;
8706             CvPADLIST_set(PL_compcv, temp_av);
8707             CvSTART(cv) = CvSTART(PL_compcv);
8708             CvSTART(PL_compcv) = cvstart;
8709             CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8710             CvFLAGS(PL_compcv) |= other_flags;
8711
8712             if (CvFILE(cv) && CvDYNFILE(cv)) {
8713                 Safefree(CvFILE(cv));
8714     }
8715             CvFILE_set_from_cop(cv, PL_curcop);
8716             CvSTASH_set(cv, PL_curstash);
8717
8718             /* inner references to PL_compcv must be fixed up ... */
8719             pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
8720             if (PERLDB_INTER)/* Advice debugger on the new sub. */
8721               ++PL_sub_generation;
8722         }
8723         else {
8724             /* Might have had built-in attributes applied -- propagate them. */
8725             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
8726         }
8727         /* ... before we throw it away */
8728         SvREFCNT_dec(PL_compcv);
8729         PL_compcv = cv;
8730     }
8731     else {
8732         cv = PL_compcv;
8733         if (name && isGV(gv)) {
8734             GvCV_set(gv, cv);
8735             GvCVGEN(gv) = 0;
8736             if (HvENAME_HEK(GvSTASH(gv)))
8737                 /* sub Foo::bar { (shift)+1 } */
8738                 gv_method_changed(gv);
8739         }
8740         else if (name) {
8741             if (!SvROK(gv)) {
8742                 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8743                 prepare_SV_for_RV((SV *)gv);
8744                 SvOK_off((SV *)gv);
8745                 SvROK_on(gv);
8746             }
8747             SvRV_set(gv, (SV *)cv);
8748         }
8749     }
8750     if (!CvHASGV(cv)) {
8751         if (isGV(gv)) CvGV_set(cv, gv);
8752         else {
8753             dVAR;
8754             U32 hash;
8755             PERL_HASH(hash, name, namlen);
8756             CvNAME_HEK_set(cv, share_hek(name,
8757                                          name_is_utf8
8758                                             ? -(SSize_t)namlen
8759                                             :  (SSize_t)namlen,
8760                                          hash));
8761         }
8762         CvFILE_set_from_cop(cv, PL_curcop);
8763         CvSTASH_set(cv, PL_curstash);
8764     }
8765
8766     if (ps) {
8767         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8768         if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
8769     }
8770
8771     if (!block)
8772         goto attrs;
8773
8774     /* If we assign an optree to a PVCV, then we've defined a subroutine that
8775        the debugger could be able to set a breakpoint in, so signal to
8776        pp_entereval that it should not throw away any saved lines at scope
8777        exit.  */
8778
8779     PL_breakable_sub_gen++;
8780     CvROOT(cv) = block;
8781     CvROOT(cv)->op_private |= OPpREFCOUNTED;
8782     OpREFCNT_set(CvROOT(cv), 1);
8783     /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8784        itself has a refcount. */
8785     CvSLABBED_off(cv);
8786     OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8787 #ifdef PERL_DEBUG_READONLY_OPS
8788     slab = (OPSLAB *)CvSTART(cv);
8789 #endif
8790     CvSTART(cv) = start;
8791     CALL_PEEP(start);
8792     finalize_optree(CvROOT(cv));
8793     S_prune_chain_head(&CvSTART(cv));
8794
8795     /* now that optimizer has done its work, adjust pad values */
8796
8797     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8798
8799   attrs:
8800     if (attrs) {
8801         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8802         HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
8803                         ? GvSTASH(CvGV(cv))
8804                         : PL_curstash;
8805         if (!name) SAVEFREESV(cv);
8806         apply_attrs(stash, MUTABLE_SV(cv), attrs);
8807         if (!name) SvREFCNT_inc_simple_void_NN(cv);
8808     }
8809
8810     if (block && has_name) {
8811         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8812             SV * const tmpstr = cv_name(cv,NULL,0);
8813             GV * const db_postponed = gv_fetchpvs("DB::postponed",
8814                                                   GV_ADDMULTI, SVt_PVHV);
8815             HV *hv;
8816             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8817                                           CopFILE(PL_curcop),
8818                                           (long)PL_subline,
8819                                           (long)CopLINE(PL_curcop));
8820             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8821                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8822             hv = GvHVn(db_postponed);
8823             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8824                 CV * const pcv = GvCV(db_postponed);
8825                 if (pcv) {
8826                     dSP;
8827                     PUSHMARK(SP);
8828                     XPUSHs(tmpstr);
8829                     PUTBACK;
8830                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
8831                 }
8832             }
8833         }
8834
8835         if (name) {
8836             if (PL_parser && PL_parser->error_count)
8837                 clear_special_blocks(name, gv, cv);
8838             else
8839                 evanescent =
8840                     process_special_blocks(floor, name, gv, cv);
8841         }
8842     }
8843
8844   done:
8845     if (PL_parser)
8846         PL_parser->copline = NOLINE;
8847     LEAVE_SCOPE(floor);
8848     if (!evanescent) {
8849 #ifdef PERL_DEBUG_READONLY_OPS
8850       if (slab)
8851         Slab_to_ro(slab);
8852 #endif
8853       if (cv && name && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
8854         pad_add_weakref(cv);
8855     }
8856     return cv;
8857 }
8858
8859 STATIC void
8860 S_clear_special_blocks(pTHX_ const char *const fullname,
8861                        GV *const gv, CV *const cv) {
8862     const char *colon;
8863     const char *name;
8864
8865     PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
8866
8867     colon = strrchr(fullname,':');
8868     name = colon ? colon + 1 : fullname;
8869
8870     if ((*name == 'B' && strEQ(name, "BEGIN"))
8871         || (*name == 'E' && strEQ(name, "END"))
8872         || (*name == 'U' && strEQ(name, "UNITCHECK"))
8873         || (*name == 'C' && strEQ(name, "CHECK"))
8874         || (*name == 'I' && strEQ(name, "INIT"))) {
8875         if (!isGV(gv)) {
8876             (void)CvGV(cv);
8877             assert(isGV(gv));
8878         }
8879         GvCV_set(gv, NULL);
8880         SvREFCNT_dec_NN(MUTABLE_SV(cv));
8881     }
8882 }
8883
8884 /* Returns true if the sub has been freed.  */
8885 STATIC bool
8886 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
8887                          GV *const gv,
8888                          CV *const cv)
8889 {
8890     const char *const colon = strrchr(fullname,':');
8891     const char *const name = colon ? colon + 1 : fullname;
8892
8893     PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
8894
8895     if (*name == 'B') {
8896         if (strEQ(name, "BEGIN")) {
8897             const I32 oldscope = PL_scopestack_ix;
8898             dSP;
8899             (void)CvGV(cv);
8900             if (floor) LEAVE_SCOPE(floor);
8901             ENTER;
8902             PUSHSTACKi(PERLSI_REQUIRE);
8903             SAVECOPFILE(&PL_compiling);
8904             SAVECOPLINE(&PL_compiling);
8905             SAVEVPTR(PL_curcop);
8906
8907             DEBUG_x( dump_sub(gv) );
8908             Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
8909             GvCV_set(gv,0);             /* cv has been hijacked */
8910             call_list(oldscope, PL_beginav);
8911
8912             POPSTACK;
8913             LEAVE;
8914             return !PL_savebegin;
8915         }
8916         else
8917             return FALSE;
8918     } else {
8919         if (*name == 'E') {
8920             if strEQ(name, "END") {
8921                 DEBUG_x( dump_sub(gv) );
8922                 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
8923             } else
8924                 return FALSE;
8925         } else if (*name == 'U') {
8926             if (strEQ(name, "UNITCHECK")) {
8927                 /* It's never too late to run a unitcheck block */
8928                 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
8929             }
8930             else
8931                 return FALSE;
8932         } else if (*name == 'C') {
8933             if (strEQ(name, "CHECK")) {
8934                 if (PL_main_start)
8935                     /* diag_listed_as: Too late to run %s block */
8936                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8937                                    "Too late to run CHECK block");
8938                 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
8939             }
8940             else
8941                 return FALSE;
8942         } else if (*name == 'I') {
8943             if (strEQ(name, "INIT")) {
8944                 if (PL_main_start)
8945                     /* diag_listed_as: Too late to run %s block */
8946                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8947                                    "Too late to run INIT block");
8948                 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
8949             }
8950             else
8951                 return FALSE;
8952         } else
8953             return FALSE;
8954         DEBUG_x( dump_sub(gv) );
8955         (void)CvGV(cv);
8956         GvCV_set(gv,0);         /* cv has been hijacked */
8957         return FALSE;
8958     }
8959 }
8960
8961 /*
8962 =for apidoc newCONSTSUB
8963
8964 See L</newCONSTSUB_flags>.
8965
8966 =cut
8967 */
8968
8969 CV *
8970 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
8971 {
8972     return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
8973 }
8974
8975 /*
8976 =for apidoc newCONSTSUB_flags
8977
8978 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
8979 eligible for inlining at compile-time.
8980
8981 Currently, the only useful value for C<flags> is SVf_UTF8.
8982
8983 The newly created subroutine takes ownership of a reference to the passed in
8984 SV.
8985
8986 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
8987 which won't be called if used as a destructor, but will suppress the overhead
8988 of a call to C<AUTOLOAD>.  (This form, however, isn't eligible for inlining at
8989 compile time.)
8990
8991 =cut
8992 */
8993
8994 CV *
8995 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
8996                              U32 flags, SV *sv)
8997 {
8998     CV* cv;
8999     const char *const file = CopFILE(PL_curcop);
9000
9001     ENTER;
9002
9003     if (IN_PERL_RUNTIME) {
9004         /* at runtime, it's not safe to manipulate PL_curcop: it may be
9005          * an op shared between threads. Use a non-shared COP for our
9006          * dirty work */
9007          SAVEVPTR(PL_curcop);
9008          SAVECOMPILEWARNINGS();
9009          PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
9010          PL_curcop = &PL_compiling;
9011     }
9012     SAVECOPLINE(PL_curcop);
9013     CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
9014
9015     SAVEHINTS();
9016     PL_hints &= ~HINT_BLOCK_SCOPE;
9017
9018     if (stash) {
9019         SAVEGENERICSV(PL_curstash);
9020         PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
9021     }
9022
9023     /* Protect sv against leakage caused by fatal warnings. */
9024     if (sv) SAVEFREESV(sv);
9025
9026     /* file becomes the CvFILE. For an XS, it's usually static storage,
9027        and so doesn't get free()d.  (It's expected to be from the C pre-
9028        processor __FILE__ directive). But we need a dynamically allocated one,
9029        and we need it to get freed.  */
9030     cv = newXS_len_flags(name, len,
9031                          sv && SvTYPE(sv) == SVt_PVAV
9032                              ? const_av_xsub
9033                              : const_sv_xsub,
9034                          file ? file : "", "",
9035                          &sv, XS_DYNAMIC_FILENAME | flags);
9036     CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
9037     CvCONST_on(cv);
9038
9039     LEAVE;
9040
9041     return cv;
9042 }
9043
9044 /*
9045 =for apidoc U||newXS
9046
9047 Used by C<xsubpp> to hook up XSUBs as Perl subs.  I<filename> needs to be
9048 static storage, as it is used directly as CvFILE(), without a copy being made.
9049
9050 =cut
9051 */
9052
9053 CV *
9054 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
9055 {
9056     PERL_ARGS_ASSERT_NEWXS;
9057     return newXS_len_flags(
9058         name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
9059     );
9060 }
9061
9062 CV *
9063 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
9064                  const char *const filename, const char *const proto,
9065                  U32 flags)
9066 {
9067     PERL_ARGS_ASSERT_NEWXS_FLAGS;
9068     return newXS_len_flags(
9069        name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
9070     );
9071 }
9072
9073 CV *
9074 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
9075 {
9076     PERL_ARGS_ASSERT_NEWXS_DEFFILE;
9077     return newXS_len_flags(
9078         name, name ? strlen(name) : 0, subaddr, NULL, NULL, NULL, 0
9079     );
9080 }
9081
9082 CV *
9083 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
9084                            XSUBADDR_t subaddr, const char *const filename,
9085                            const char *const proto, SV **const_svp,
9086                            U32 flags)
9087 {
9088     CV *cv;
9089     bool interleave = FALSE;
9090
9091     PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
9092     if (!subaddr)
9093         Perl_croak_nocontext("panic: no address for '%s' in '%s'",
9094             name, filename ? filename : PL_xsubfilename);
9095     {
9096         GV * const gv = gv_fetchpvn(
9097                             name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
9098                             name ? len : PL_curstash ? sizeof("__ANON__") - 1:
9099                                 sizeof("__ANON__::__ANON__") - 1,
9100                             GV_ADDMULTI | flags, SVt_PVCV);
9101
9102         if ((cv = (name ? GvCV(gv) : NULL))) {
9103             if (GvCVGEN(gv)) {
9104                 /* just a cached method */
9105                 SvREFCNT_dec(cv);
9106                 cv = NULL;
9107             }
9108             else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
9109                 /* already defined (or promised) */
9110                 /* Redundant check that allows us to avoid creating an SV
9111                    most of the time: */
9112                 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
9113                     report_redefined_cv(newSVpvn_flags(
9114                                          name,len,(flags&SVf_UTF8)|SVs_TEMP
9115                                         ),
9116                                         cv, const_svp);
9117                 }
9118                 interleave = TRUE;
9119                 ENTER;
9120                 SAVEFREESV(cv);
9121                 cv = NULL;
9122             }
9123         }
9124
9125         if (cv)                         /* must reuse cv if autoloaded */
9126             cv_undef(cv);
9127         else {
9128             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9129             if (name) {
9130                 GvCV_set(gv,cv);
9131                 GvCVGEN(gv) = 0;
9132                 if (HvENAME_HEK(GvSTASH(gv)))
9133                     gv_method_changed(gv); /* newXS */
9134             }
9135         }
9136
9137         CvGV_set(cv, gv);
9138         if(filename) {
9139             (void)gv_fetchfile(filename);
9140             assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
9141             if (flags & XS_DYNAMIC_FILENAME) {
9142                 CvDYNFILE_on(cv);
9143                 CvFILE(cv) = savepv(filename);
9144             } else {
9145             /* NOTE: not copied, as it is expected to be an external constant string */
9146                 CvFILE(cv) = (char *)filename;
9147             }
9148         } else {
9149             assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
9150             CvFILE(cv) = (char*)PL_xsubfilename;
9151         }
9152         CvISXSUB_on(cv);
9153         CvXSUB(cv) = subaddr;
9154 #ifndef PERL_IMPLICIT_CONTEXT
9155         CvHSCXT(cv) = &PL_stack_sp;
9156 #else
9157         PoisonPADLIST(cv);
9158 #endif
9159
9160         if (name)
9161             process_special_blocks(0, name, gv, cv);
9162         else
9163             CvANON_on(cv);
9164     } /* <- not a conditional branch */
9165
9166
9167     sv_setpv(MUTABLE_SV(cv), proto);
9168     if (interleave) LEAVE;
9169     return cv;
9170 }
9171
9172 CV *
9173 Perl_newSTUB(pTHX_ GV *gv, bool fake)
9174 {
9175     CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9176     GV *cvgv;
9177     PERL_ARGS_ASSERT_NEWSTUB;
9178     assert(!GvCVu(gv));
9179     GvCV_set(gv, cv);
9180     GvCVGEN(gv) = 0;
9181     if (!fake && HvENAME_HEK(GvSTASH(gv)))
9182         gv_method_changed(gv);
9183     if (SvFAKE(gv)) {
9184         cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
9185         SvFAKE_off(cvgv);
9186     }
9187     else cvgv = gv;
9188     CvGV_set(cv, cvgv);
9189     CvFILE_set_from_cop(cv, PL_curcop);
9190     CvSTASH_set(cv, PL_curstash);
9191     GvMULTI_on(gv);
9192     return cv;
9193 }
9194
9195 void
9196 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
9197 {
9198     CV *cv;
9199
9200     GV *gv;
9201
9202     if (PL_parser && PL_parser->error_count) {
9203         op_free(block);
9204         goto finish;
9205     }
9206
9207     gv = o
9208         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
9209         : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
9210
9211     GvMULTI_on(gv);
9212     if ((cv = GvFORM(gv))) {
9213         if (ckWARN(WARN_REDEFINE)) {
9214             const line_t oldline = CopLINE(PL_curcop);
9215             if (PL_parser && PL_parser->copline != NOLINE)
9216                 CopLINE_set(PL_curcop, PL_parser->copline);
9217             if (o) {
9218                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9219                             "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
9220             } else {
9221                 /* diag_listed_as: Format %s redefined */
9222                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9223                             "Format STDOUT redefined");
9224             }
9225             CopLINE_set(PL_curcop, oldline);
9226         }
9227         SvREFCNT_dec(cv);
9228     }
9229     cv = PL_compcv;
9230     GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
9231     CvGV_set(cv, gv);
9232     CvFILE_set_from_cop(cv, PL_curcop);
9233
9234
9235     pad_tidy(padtidy_FORMAT);
9236     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
9237     CvROOT(cv)->op_private |= OPpREFCOUNTED;
9238     OpREFCNT_set(CvROOT(cv), 1);
9239     CvSTART(cv) = LINKLIST(CvROOT(cv));
9240     CvROOT(cv)->op_next = 0;
9241     CALL_PEEP(CvSTART(cv));
9242     finalize_optree(CvROOT(cv));
9243     S_prune_chain_head(&CvSTART(cv));
9244     cv_forget_slab(cv);
9245
9246   finish:
9247     op_free(o);
9248     if (PL_parser)
9249         PL_parser->copline = NOLINE;
9250     LEAVE_SCOPE(floor);
9251     PL_compiling.cop_seq = 0;
9252 }
9253
9254 OP *
9255 Perl_newANONLIST(pTHX_ OP *o)
9256 {
9257     return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
9258 }
9259
9260 OP *
9261 Perl_newANONHASH(pTHX_ OP *o)
9262 {
9263     return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
9264 }
9265
9266 OP *
9267 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
9268 {
9269     return newANONATTRSUB(floor, proto, NULL, block);
9270 }
9271
9272 OP *
9273 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
9274 {
9275     return newUNOP(OP_REFGEN, 0,
9276         newSVOP(OP_ANONCODE, 0,
9277                 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
9278 }
9279
9280 OP *
9281 Perl_oopsAV(pTHX_ OP *o)
9282 {
9283     dVAR;
9284
9285     PERL_ARGS_ASSERT_OOPSAV;
9286
9287     switch (o->op_type) {
9288     case OP_PADSV:
9289     case OP_PADHV:
9290         CHANGE_TYPE(o, OP_PADAV);
9291         return ref(o, OP_RV2AV);
9292
9293     case OP_RV2SV:
9294     case OP_RV2HV:
9295         CHANGE_TYPE(o, OP_RV2AV);
9296         ref(o, OP_RV2AV);
9297         break;
9298
9299     default:
9300         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
9301         break;
9302     }
9303     return o;
9304 }
9305
9306 OP *
9307 Perl_oopsHV(pTHX_ OP *o)
9308 {
9309     dVAR;
9310
9311     PERL_ARGS_ASSERT_OOPSHV;
9312
9313     switch (o->op_type) {
9314     case OP_PADSV:
9315     case OP_PADAV:
9316         CHANGE_TYPE(o, OP_PADHV);
9317         return ref(o, OP_RV2HV);
9318
9319     case OP_RV2SV:
9320     case OP_RV2AV:
9321         CHANGE_TYPE(o, OP_RV2HV);
9322         ref(o, OP_RV2HV);
9323         break;
9324
9325     default:
9326         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
9327         break;
9328     }
9329     return o;
9330 }
9331
9332 OP *
9333 Perl_newAVREF(pTHX_ OP *o)
9334 {
9335     dVAR;
9336
9337     PERL_ARGS_ASSERT_NEWAVREF;
9338
9339     if (o->op_type == OP_PADANY) {
9340         CHANGE_TYPE(o, OP_PADAV);
9341         return o;
9342     }
9343     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
9344         Perl_croak(aTHX_ "Can't use an array as a reference");
9345     }
9346     return newUNOP(OP_RV2AV, 0, scalar(o));
9347 }
9348
9349 OP *
9350 Perl_newGVREF(pTHX_ I32 type, OP *o)
9351 {
9352     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
9353         return newUNOP(OP_NULL, 0, o);
9354     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
9355 }
9356
9357 OP *
9358 Perl_newHVREF(pTHX_ OP *o)
9359 {
9360     dVAR;
9361
9362     PERL_ARGS_ASSERT_NEWHVREF;
9363
9364     if (o->op_type == OP_PADANY) {
9365         CHANGE_TYPE(o, OP_PADHV);
9366         return o;
9367     }
9368     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
9369         Perl_croak(aTHX_ "Can't use a hash as a reference");
9370     }
9371     return newUNOP(OP_RV2HV, 0, scalar(o));
9372 }
9373
9374 OP *
9375 Perl_newCVREF(pTHX_ I32 flags, OP *o)
9376 {
9377     if (o->op_type == OP_PADANY) {
9378         dVAR;
9379         CHANGE_TYPE(o, OP_PADCV);
9380     }
9381     return newUNOP(OP_RV2CV, flags, scalar(o));
9382 }
9383
9384 OP *
9385 Perl_newSVREF(pTHX_ OP *o)
9386 {
9387     dVAR;
9388
9389     PERL_ARGS_ASSERT_NEWSVREF;
9390
9391     if (o->op_type == OP_PADANY) {
9392         CHANGE_TYPE(o, OP_PADSV);
9393         scalar(o);
9394         return o;
9395     }
9396     return newUNOP(OP_RV2SV, 0, scalar(o));
9397 }
9398
9399 /* Check routines. See the comments at the top of this file for details
9400  * on when these are called */
9401
9402 OP *
9403 Perl_ck_anoncode(pTHX_ OP *o)
9404 {
9405     PERL_ARGS_ASSERT_CK_ANONCODE;
9406
9407     cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
9408     cSVOPo->op_sv = NULL;
9409     return o;
9410 }
9411
9412 static void
9413 S_io_hints(pTHX_ OP *o)
9414 {
9415 #if O_BINARY != 0 || O_TEXT != 0
9416     HV * const table =
9417         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
9418     if (table) {
9419         SV **svp = hv_fetchs(table, "open_IN", FALSE);
9420         if (svp && *svp) {
9421             STRLEN len = 0;
9422             const char *d = SvPV_const(*svp, len);
9423             const I32 mode = mode_from_discipline(d, len);
9424             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9425 #  if O_BINARY != 0
9426             if (mode & O_BINARY)
9427                 o->op_private |= OPpOPEN_IN_RAW;
9428 #  endif
9429 #  if O_TEXT != 0
9430             if (mode & O_TEXT)
9431                 o->op_private |= OPpOPEN_IN_CRLF;
9432 #  endif
9433         }
9434
9435         svp = hv_fetchs(table, "open_OUT", FALSE);
9436         if (svp && *svp) {
9437             STRLEN len = 0;
9438             const char *d = SvPV_const(*svp, len);
9439             const I32 mode = mode_from_discipline(d, len);
9440             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9441 #  if O_BINARY != 0
9442             if (mode & O_BINARY)
9443                 o->op_private |= OPpOPEN_OUT_RAW;
9444 #  endif
9445 #  if O_TEXT != 0
9446             if (mode & O_TEXT)
9447                 o->op_private |= OPpOPEN_OUT_CRLF;
9448 #  endif
9449         }
9450     }
9451 #else
9452     PERL_UNUSED_CONTEXT;
9453     PERL_UNUSED_ARG(o);
9454 #endif
9455 }
9456
9457 OP *
9458 Perl_ck_backtick(pTHX_ OP *o)
9459 {
9460     GV *gv;
9461     OP *newop = NULL;
9462     OP *sibl;
9463     PERL_ARGS_ASSERT_CK_BACKTICK;
9464     /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
9465     if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
9466      && (gv = gv_override("readpipe",8)))
9467     {
9468         /* detach rest of siblings from o and its first child */
9469         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
9470         newop = S_new_entersubop(aTHX_ gv, sibl);
9471     }
9472     else if (!(o->op_flags & OPf_KIDS))
9473         newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
9474     if (newop) {
9475         op_free(o);
9476         return newop;
9477     }
9478     S_io_hints(aTHX_ o);
9479     return o;
9480 }
9481
9482 OP *
9483 Perl_ck_bitop(pTHX_ OP *o)
9484 {
9485     PERL_ARGS_ASSERT_CK_BITOP;
9486
9487     o->op_private = (U8)(PL_hints & HINT_INTEGER);
9488     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
9489             && (o->op_type == OP_BIT_OR
9490              || o->op_type == OP_BIT_AND
9491              || o->op_type == OP_BIT_XOR))
9492     {
9493         const OP * const left = cBINOPo->op_first;
9494         const OP * const right = OpSIBLING(left);
9495         if ((OP_IS_NUMCOMPARE(left->op_type) &&
9496                 (left->op_flags & OPf_PARENS) == 0) ||
9497             (OP_IS_NUMCOMPARE(right->op_type) &&
9498                 (right->op_flags & OPf_PARENS) == 0))
9499             Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
9500                            "Possible precedence problem on bitwise %c operator",
9501                            o->op_type == OP_BIT_OR ? '|'
9502                            : o->op_type == OP_BIT_AND ? '&' : '^'
9503                            );
9504     }
9505     return o;
9506 }
9507
9508 PERL_STATIC_INLINE bool
9509 is_dollar_bracket(pTHX_ const OP * const o)
9510 {
9511     const OP *kid;
9512     PERL_UNUSED_CONTEXT;
9513     return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
9514         && (kid = cUNOPx(o)->op_first)
9515         && kid->op_type == OP_GV
9516         && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
9517 }
9518
9519 OP *
9520 Perl_ck_cmp(pTHX_ OP *o)
9521 {
9522     PERL_ARGS_ASSERT_CK_CMP;
9523     if (ckWARN(WARN_SYNTAX)) {
9524         const OP *kid = cUNOPo->op_first;
9525         if (kid &&
9526             (
9527                 (   is_dollar_bracket(aTHX_ kid)
9528                  && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
9529                 )
9530              || (   kid->op_type == OP_CONST
9531                  && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
9532                 )
9533            )
9534         )
9535             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9536                         "$[ used in %s (did you mean $] ?)", OP_DESC(o));
9537     }
9538     return o;
9539 }
9540
9541 OP *
9542 Perl_ck_concat(pTHX_ OP *o)
9543 {
9544     const OP * const kid = cUNOPo->op_first;
9545
9546     PERL_ARGS_ASSERT_CK_CONCAT;
9547     PERL_UNUSED_CONTEXT;
9548
9549     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
9550             !(kUNOP->op_first->op_flags & OPf_MOD))
9551         o->op_flags |= OPf_STACKED;
9552     return o;
9553 }
9554
9555 OP *
9556 Perl_ck_spair(pTHX_ OP *o)
9557 {
9558     dVAR;
9559
9560     PERL_ARGS_ASSERT_CK_SPAIR;
9561
9562     if (o->op_flags & OPf_KIDS) {
9563         OP* newop;
9564         OP* kid;
9565         OP* kidkid;
9566         const OPCODE type = o->op_type;
9567         o = modkids(ck_fun(o), type);
9568         kid    = cUNOPo->op_first;
9569         kidkid = kUNOP->op_first;
9570         newop = OpSIBLING(kidkid);
9571         if (newop) {
9572             const OPCODE type = newop->op_type;
9573             if (OpHAS_SIBLING(newop))
9574                 return o;
9575             if (o->op_type == OP_REFGEN
9576              && (  type == OP_RV2CV
9577                 || (  !(newop->op_flags & OPf_PARENS)
9578                    && (  type == OP_RV2AV || type == OP_PADAV
9579                       || type == OP_RV2HV || type == OP_PADHV))))
9580                 NOOP; /* OK (allow srefgen for \@a and \%h) */
9581             else if (OP_GIMME(newop,0) != G_SCALAR)
9582                 return o;
9583         }
9584         /* excise first sibling */
9585         op_sibling_splice(kid, NULL, 1, NULL);
9586         op_free(kidkid);
9587     }
9588     /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
9589      * and OP_CHOMP into OP_SCHOMP */
9590     o->op_ppaddr = PL_ppaddr[++o->op_type];
9591     return ck_fun(o);
9592 }
9593
9594 OP *
9595 Perl_ck_delete(pTHX_ OP *o)
9596 {
9597     PERL_ARGS_ASSERT_CK_DELETE;
9598
9599     o = ck_fun(o);
9600     o->op_private = 0;
9601     if (o->op_flags & OPf_KIDS) {
9602         OP * const kid = cUNOPo->op_first;
9603         switch (kid->op_type) {
9604         case OP_ASLICE:
9605             o->op_flags |= OPf_SPECIAL;
9606             /* FALLTHROUGH */
9607         case OP_HSLICE:
9608             o->op_private |= OPpSLICE;
9609             break;
9610         case OP_AELEM:
9611             o->op_flags |= OPf_SPECIAL;
9612             /* FALLTHROUGH */
9613         case OP_HELEM:
9614             break;
9615         case OP_KVASLICE:
9616             Perl_croak(aTHX_ "delete argument is index/value array slice,"
9617                              " use array slice");
9618         case OP_KVHSLICE:
9619             Perl_croak(aTHX_ "delete argument is key/value hash slice, use"
9620                              " hash slice");
9621         default:
9622             Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
9623                              "element or slice");
9624         }
9625         if (kid->op_private & OPpLVAL_INTRO)
9626             o->op_private |= OPpLVAL_INTRO;
9627         op_null(kid);
9628     }
9629     return o;
9630 }
9631
9632 OP *
9633 Perl_ck_eof(pTHX_ OP *o)
9634 {
9635     PERL_ARGS_ASSERT_CK_EOF;
9636
9637     if (o->op_flags & OPf_KIDS) {
9638         OP *kid;
9639         if (cLISTOPo->op_first->op_type == OP_STUB) {
9640             OP * const newop
9641                 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
9642             op_free(o);
9643             o = newop;
9644         }
9645         o = ck_fun(o);
9646         kid = cLISTOPo->op_first;
9647         if (kid->op_type == OP_RV2GV)
9648             kid->op_private |= OPpALLOW_FAKE;
9649     }
9650     return o;
9651 }
9652
9653 OP *
9654 Perl_ck_eval(pTHX_ OP *o)
9655 {
9656     dVAR;
9657
9658     PERL_ARGS_ASSERT_CK_EVAL;
9659
9660     PL_hints |= HINT_BLOCK_SCOPE;
9661     if (o->op_flags & OPf_KIDS) {
9662         SVOP * const kid = (SVOP*)cUNOPo->op_first;
9663         assert(kid);
9664
9665         if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
9666             LOGOP *enter;
9667
9668             /* cut whole sibling chain free from o */
9669             op_sibling_splice(o, NULL, -1, NULL);
9670             op_free(o);
9671
9672             enter = S_alloc_LOGOP(aTHX_ OP_ENTERTRY, NULL, NULL);
9673
9674             /* establish postfix order */
9675             enter->op_next = (OP*)enter;
9676
9677             o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
9678             CHANGE_TYPE(o, OP_LEAVETRY);
9679             enter->op_other = o;
9680             return o;
9681         }
9682         else {
9683             scalar((OP*)kid);
9684             S_set_haseval(aTHX);
9685         }
9686     }
9687     else {
9688         const U8 priv = o->op_private;
9689         op_free(o);
9690         /* the newUNOP will recursively call ck_eval(), which will handle
9691          * all the stuff at the end of this function, like adding
9692          * OP_HINTSEVAL
9693          */
9694         return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
9695     }
9696     o->op_targ = (PADOFFSET)PL_hints;
9697     if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
9698     if ((PL_hints & HINT_LOCALIZE_HH) != 0
9699      && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
9700         /* Store a copy of %^H that pp_entereval can pick up. */
9701         OP *hhop = newSVOP(OP_HINTSEVAL, 0,
9702                            MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
9703         /* append hhop to only child  */
9704         op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
9705
9706         o->op_private |= OPpEVAL_HAS_HH;
9707     }
9708     if (!(o->op_private & OPpEVAL_BYTES)
9709          && FEATURE_UNIEVAL_IS_ENABLED)
9710             o->op_private |= OPpEVAL_UNICODE;
9711     return o;
9712 }
9713
9714 OP *
9715 Perl_ck_exec(pTHX_ OP *o)
9716 {
9717     PERL_ARGS_ASSERT_CK_EXEC;
9718
9719     if (o->op_flags & OPf_STACKED) {
9720         OP *kid;
9721         o = ck_fun(o);
9722         kid = OpSIBLING(cUNOPo->op_first);
9723         if (kid->op_type == OP_RV2GV)
9724             op_null(kid);
9725     }
9726     else
9727         o = listkids(o);
9728     return o;
9729 }
9730
9731 OP *
9732 Perl_ck_exists(pTHX_ OP *o)
9733 {
9734     PERL_ARGS_ASSERT_CK_EXISTS;
9735
9736     o = ck_fun(o);
9737     if (o->op_flags & OPf_KIDS) {
9738         OP * const kid = cUNOPo->op_first;
9739         if (kid->op_type == OP_ENTERSUB) {
9740             (void) ref(kid, o->op_type);
9741             if (kid->op_type != OP_RV2CV
9742                         && !(PL_parser && PL_parser->error_count))
9743                 Perl_croak(aTHX_
9744                           "exists argument is not a subroutine name");
9745             o->op_private |= OPpEXISTS_SUB;
9746         }
9747         else if (kid->op_type == OP_AELEM)
9748             o->op_flags |= OPf_SPECIAL;
9749         else if (kid->op_type != OP_HELEM)
9750             Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
9751                              "element or a subroutine");
9752         op_null(kid);
9753     }
9754     return o;
9755 }
9756
9757 OP *
9758 Perl_ck_rvconst(pTHX_ OP *o)
9759 {
9760     dVAR;
9761     SVOP * const kid = (SVOP*)cUNOPo->op_first;
9762
9763     PERL_ARGS_ASSERT_CK_RVCONST;
9764
9765     o->op_private |= (PL_hints & HINT_STRICT_REFS);
9766
9767     if (kid->op_type == OP_CONST) {
9768         int iscv;
9769         GV *gv;
9770         SV * const kidsv = kid->op_sv;
9771
9772         /* Is it a constant from cv_const_sv()? */
9773         if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
9774             return o;
9775         }
9776         if (SvTYPE(kidsv) == SVt_PVAV) return o;
9777         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
9778             const char *badthing;
9779             switch (o->op_type) {
9780             case OP_RV2SV:
9781                 badthing = "a SCALAR";
9782                 break;
9783             case OP_RV2AV:
9784                 badthing = "an ARRAY";
9785                 break;
9786             case OP_RV2HV:
9787                 badthing = "a HASH";
9788                 break;
9789             default:
9790                 badthing = NULL;
9791                 break;
9792             }
9793             if (badthing)
9794                 Perl_croak(aTHX_
9795                            "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
9796                            SVfARG(kidsv), badthing);
9797         }
9798         /*
9799          * This is a little tricky.  We only want to add the symbol if we
9800          * didn't add it in the lexer.  Otherwise we get duplicate strict
9801          * warnings.  But if we didn't add it in the lexer, we must at
9802          * least pretend like we wanted to add it even if it existed before,
9803          * or we get possible typo warnings.  OPpCONST_ENTERED says
9804          * whether the lexer already added THIS instance of this symbol.
9805          */
9806         iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
9807         gv = gv_fetchsv(kidsv,
9808                 o->op_type == OP_RV2CV
9809                         && o->op_private & OPpMAY_RETURN_CONSTANT
9810                     ? GV_NOEXPAND
9811                     : iscv | !(kid->op_private & OPpCONST_ENTERED),
9812                 iscv
9813                     ? SVt_PVCV
9814                     : o->op_type == OP_RV2SV
9815                         ? SVt_PV
9816                         : o->op_type == OP_RV2AV
9817                             ? SVt_PVAV
9818                             : o->op_type == OP_RV2HV
9819                                 ? SVt_PVHV
9820                                 : SVt_PVGV);
9821         if (gv) {
9822             if (!isGV(gv)) {
9823                 assert(iscv);
9824                 assert(SvROK(gv));
9825                 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
9826                   && SvTYPE(SvRV(gv)) != SVt_PVCV)
9827                     gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
9828             }
9829             CHANGE_TYPE(kid, OP_GV);
9830             SvREFCNT_dec(kid->op_sv);
9831 #ifdef USE_ITHREADS
9832             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
9833             STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
9834             kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
9835             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
9836             PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
9837 #else
9838             kid->op_sv = SvREFCNT_inc_simple_NN(gv);
9839 #endif
9840             kid->op_private = 0;
9841             /* FAKE globs in the symbol table cause weird bugs (#77810) */
9842             SvFAKE_off(gv);
9843         }
9844     }
9845     return o;
9846 }
9847
9848 OP *
9849 Perl_ck_ftst(pTHX_ OP *o)
9850 {
9851     dVAR;
9852     const I32 type = o->op_type;
9853
9854     PERL_ARGS_ASSERT_CK_FTST;
9855
9856     if (o->op_flags & OPf_REF) {
9857         NOOP;
9858     }
9859     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
9860         SVOP * const kid = (SVOP*)cUNOPo->op_first;
9861         const OPCODE kidtype = kid->op_type;
9862
9863         if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
9864          && !kid->op_folded) {
9865             OP * const newop = newGVOP(type, OPf_REF,
9866                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
9867             op_free(o);
9868             return newop;
9869         }
9870         if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
9871             o->op_private |= OPpFT_ACCESS;
9872         if (PL_check[kidtype] == Perl_ck_ftst
9873                 && kidtype != OP_STAT && kidtype != OP_LSTAT) {
9874             o->op_private |= OPpFT_STACKED;
9875             kid->op_private |= OPpFT_STACKING;
9876             if (kidtype == OP_FTTTY && (
9877                    !(kid->op_private & OPpFT_STACKED)
9878                 || kid->op_private & OPpFT_AFTER_t
9879                ))
9880                 o->op_private |= OPpFT_AFTER_t;
9881         }
9882     }
9883     else {
9884         op_free(o);
9885         if (type == OP_FTTTY)
9886             o = newGVOP(type, OPf_REF, PL_stdingv);
9887         else
9888             o = newUNOP(type, 0, newDEFSVOP());
9889     }
9890     return o;
9891 }
9892
9893 OP *
9894 Perl_ck_fun(pTHX_ OP *o)
9895 {
9896     const int type = o->op_type;
9897     I32 oa = PL_opargs[type] >> OASHIFT;
9898
9899     PERL_ARGS_ASSERT_CK_FUN;
9900
9901     if (o->op_flags & OPf_STACKED) {
9902         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
9903             oa &= ~OA_OPTIONAL;
9904         else
9905             return no_fh_allowed(o);
9906     }
9907
9908     if (o->op_flags & OPf_KIDS) {
9909         OP *prev_kid = NULL;
9910         OP *kid = cLISTOPo->op_first;
9911         I32 numargs = 0;
9912         bool seen_optional = FALSE;
9913
9914         if (kid->op_type == OP_PUSHMARK ||
9915             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
9916         {
9917             prev_kid = kid;
9918             kid = OpSIBLING(kid);
9919         }
9920         if (kid && kid->op_type == OP_COREARGS) {
9921             bool optional = FALSE;
9922             while (oa) {
9923                 numargs++;
9924                 if (oa & OA_OPTIONAL) optional = TRUE;
9925                 oa = oa >> 4;
9926             }
9927             if (optional) o->op_private |= numargs;
9928             return o;
9929         }
9930
9931         while (oa) {
9932             if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
9933                 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
9934                     kid = newDEFSVOP();
9935                     /* append kid to chain */
9936                     op_sibling_splice(o, prev_kid, 0, kid);
9937                 }
9938                 seen_optional = TRUE;
9939             }
9940             if (!kid) break;
9941
9942             numargs++;
9943             switch (oa & 7) {
9944             case OA_SCALAR:
9945                 /* list seen where single (scalar) arg expected? */
9946                 if (numargs == 1 && !(oa >> 4)
9947                     && kid->op_type == OP_LIST && type != OP_SCALAR)
9948                 {
9949                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
9950                 }
9951                 if (type != OP_DELETE) scalar(kid);
9952                 break;
9953             case OA_LIST:
9954                 if (oa < 16) {
9955                     kid = 0;
9956                     continue;
9957                 }
9958                 else
9959                     list(kid);
9960                 break;
9961             case OA_AVREF:
9962                 if ((type == OP_PUSH || type == OP_UNSHIFT)
9963                     && !OpHAS_SIBLING(kid))
9964                     Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
9965                                    "Useless use of %s with no values",
9966                                    PL_op_desc[type]);
9967
9968                 if (kid->op_type == OP_CONST
9969                       && (  !SvROK(cSVOPx_sv(kid))
9970                          || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV  )
9971                         )
9972                     bad_type_pv(numargs, "array", PL_op_desc[type], 0, kid);
9973                 /* Defer checks to run-time if we have a scalar arg */
9974                 if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
9975                     op_lvalue(kid, type);
9976                 else {
9977                     scalar(kid);
9978                     /* diag_listed_as: push on reference is experimental */
9979                     Perl_ck_warner_d(aTHX_
9980                                      packWARN(WARN_EXPERIMENTAL__AUTODEREF),
9981                                     "%s on reference is experimental",
9982                                      PL_op_desc[type]);
9983                 }
9984                 break;
9985             case OA_HVREF:
9986                 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
9987                     bad_type_pv(numargs, "hash", PL_op_desc[type], 0, kid);
9988                 op_lvalue(kid, type);
9989                 break;
9990             case OA_CVREF:
9991                 {
9992                     /* replace kid with newop in chain */
9993                     OP * const newop =
9994                         S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
9995                     newop->op_next = newop;
9996                     kid = newop;
9997                 }
9998                 break;
9999             case OA_FILEREF:
10000                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
10001                     if (kid->op_type == OP_CONST &&
10002                         (kid->op_private & OPpCONST_BARE))
10003                     {
10004                         OP * const newop = newGVOP(OP_GV, 0,
10005                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
10006                         /* replace kid with newop in chain */
10007                         op_sibling_splice(o, prev_kid, 1, newop);
10008                         op_free(kid);
10009                         kid = newop;
10010                     }
10011                     else if (kid->op_type == OP_READLINE) {
10012                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
10013                         bad_type_pv(numargs, "HANDLE", OP_DESC(o), 0, kid);
10014                     }
10015                     else {
10016                         I32 flags = OPf_SPECIAL;
10017                         I32 priv = 0;
10018                         PADOFFSET targ = 0;
10019
10020                         /* is this op a FH constructor? */
10021                         if (is_handle_constructor(o,numargs)) {
10022                             const char *name = NULL;
10023                             STRLEN len = 0;
10024                             U32 name_utf8 = 0;
10025                             bool want_dollar = TRUE;
10026
10027                             flags = 0;
10028                             /* Set a flag to tell rv2gv to vivify
10029                              * need to "prove" flag does not mean something
10030                              * else already - NI-S 1999/05/07
10031                              */
10032                             priv = OPpDEREF;
10033                             if (kid->op_type == OP_PADSV) {
10034                                 PADNAME * const pn
10035                                     = PAD_COMPNAME_SV(kid->op_targ);
10036                                 name = PadnamePV (pn);
10037                                 len  = PadnameLEN(pn);
10038                                 name_utf8 = PadnameUTF8(pn);
10039                             }
10040                             else if (kid->op_type == OP_RV2SV
10041                                      && kUNOP->op_first->op_type == OP_GV)
10042                             {
10043                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
10044                                 name = GvNAME(gv);
10045                                 len = GvNAMELEN(gv);
10046                                 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
10047                             }
10048                             else if (kid->op_type == OP_AELEM
10049                                      || kid->op_type == OP_HELEM)
10050                             {
10051                                  OP *firstop;
10052                                  OP *op = ((BINOP*)kid)->op_first;
10053                                  name = NULL;
10054                                  if (op) {
10055                                       SV *tmpstr = NULL;
10056                                       const char * const a =
10057                                            kid->op_type == OP_AELEM ?
10058                                            "[]" : "{}";
10059                                       if (((op->op_type == OP_RV2AV) ||
10060                                            (op->op_type == OP_RV2HV)) &&
10061                                           (firstop = ((UNOP*)op)->op_first) &&
10062                                           (firstop->op_type == OP_GV)) {
10063                                            /* packagevar $a[] or $h{} */
10064                                            GV * const gv = cGVOPx_gv(firstop);
10065                                            if (gv)
10066                                                 tmpstr =
10067                                                      Perl_newSVpvf(aTHX_
10068                                                                    "%s%c...%c",
10069                                                                    GvNAME(gv),
10070                                                                    a[0], a[1]);
10071                                       }
10072                                       else if (op->op_type == OP_PADAV
10073                                                || op->op_type == OP_PADHV) {
10074                                            /* lexicalvar $a[] or $h{} */
10075                                            const char * const padname =
10076                                                 PAD_COMPNAME_PV(op->op_targ);
10077                                            if (padname)
10078                                                 tmpstr =
10079                                                      Perl_newSVpvf(aTHX_
10080                                                                    "%s%c...%c",
10081                                                                    padname + 1,
10082                                                                    a[0], a[1]);
10083                                       }
10084                                       if (tmpstr) {
10085                                            name = SvPV_const(tmpstr, len);
10086                                            name_utf8 = SvUTF8(tmpstr);
10087                                            sv_2mortal(tmpstr);
10088                                       }
10089                                  }
10090                                  if (!name) {
10091                                       name = "__ANONIO__";
10092                                       len = 10;
10093                                       want_dollar = FALSE;
10094                                  }
10095                                  op_lvalue(kid, type);
10096                             }
10097                             if (name) {
10098                                 SV *namesv;
10099                                 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
10100                                 namesv = PAD_SVl(targ);
10101                                 if (want_dollar && *name != '$')
10102                                     sv_setpvs(namesv, "$");
10103                                 else
10104                                     sv_setpvs(namesv, "");
10105                                 sv_catpvn(namesv, name, len);
10106                                 if ( name_utf8 ) SvUTF8_on(namesv);
10107                             }
10108                         }
10109                         scalar(kid);
10110                         kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
10111                                     OP_RV2GV, flags);
10112                         kid->op_targ = targ;
10113                         kid->op_private |= priv;
10114                     }
10115                 }
10116                 scalar(kid);
10117                 break;
10118             case OA_SCALARREF:
10119                 if ((type == OP_UNDEF || type == OP_POS)
10120                     && numargs == 1 && !(oa >> 4)
10121                     && kid->op_type == OP_LIST)
10122                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
10123                 op_lvalue(scalar(kid), type);
10124                 break;
10125             }
10126             oa >>= 4;
10127             prev_kid = kid;
10128             kid = OpSIBLING(kid);
10129         }
10130         /* FIXME - should the numargs or-ing move after the too many
10131          * arguments check? */
10132         o->op_private |= numargs;
10133         if (kid)
10134             return too_many_arguments_pv(o,OP_DESC(o), 0);
10135         listkids(o);
10136     }
10137     else if (PL_opargs[type] & OA_DEFGV) {
10138         /* Ordering of these two is important to keep f_map.t passing.  */
10139         op_free(o);
10140         return newUNOP(type, 0, newDEFSVOP());
10141     }
10142
10143     if (oa) {
10144         while (oa & OA_OPTIONAL)
10145             oa >>= 4;
10146         if (oa && oa != OA_LIST)
10147             return too_few_arguments_pv(o,OP_DESC(o), 0);
10148     }
10149     return o;
10150 }
10151
10152 OP *
10153 Perl_ck_glob(pTHX_ OP *o)
10154 {
10155     GV *gv;
10156
10157     PERL_ARGS_ASSERT_CK_GLOB;
10158
10159     o = ck_fun(o);
10160     if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
10161         op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
10162
10163     if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
10164     {
10165         /* convert
10166          *     glob
10167          *       \ null - const(wildcard)
10168          * into
10169          *     null
10170          *       \ enter
10171          *            \ list
10172          *                 \ mark - glob - rv2cv
10173          *                             |        \ gv(CORE::GLOBAL::glob)
10174          *                             |
10175          *                              \ null - const(wildcard)
10176          */
10177         o->op_flags |= OPf_SPECIAL;
10178         o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
10179         o = S_new_entersubop(aTHX_ gv, o);
10180         o = newUNOP(OP_NULL, 0, o);
10181         o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
10182         return o;
10183     }
10184     else o->op_flags &= ~OPf_SPECIAL;
10185 #if !defined(PERL_EXTERNAL_GLOB)
10186     if (!PL_globhook) {
10187         ENTER;
10188         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
10189                                newSVpvs("File::Glob"), NULL, NULL, NULL);
10190         LEAVE;
10191     }
10192 #endif /* !PERL_EXTERNAL_GLOB */
10193     gv = (GV *)newSV(0);
10194     gv_init(gv, 0, "", 0, 0);
10195     gv_IOadd(gv);
10196     op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
10197     SvREFCNT_dec_NN(gv); /* newGVOP increased it */
10198     scalarkids(o);
10199     return o;
10200 }
10201
10202 OP *
10203 Perl_ck_grep(pTHX_ OP *o)
10204 {
10205     LOGOP *gwop;
10206     OP *kid;
10207     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
10208     PADOFFSET offset;
10209
10210     PERL_ARGS_ASSERT_CK_GREP;
10211
10212     /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
10213
10214     if (o->op_flags & OPf_STACKED) {
10215         kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
10216         if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
10217             return no_fh_allowed(o);
10218         o->op_flags &= ~OPf_STACKED;
10219     }
10220     kid = OpSIBLING(cLISTOPo->op_first);
10221     if (type == OP_MAPWHILE)
10222         list(kid);
10223     else
10224         scalar(kid);
10225     o = ck_fun(o);
10226     if (PL_parser && PL_parser->error_count)
10227         return o;
10228     kid = OpSIBLING(cLISTOPo->op_first);
10229     if (kid->op_type != OP_NULL)
10230         Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
10231     kid = kUNOP->op_first;
10232
10233     gwop = S_alloc_LOGOP(aTHX_ type, o, LINKLIST(kid));
10234     kid->op_next = (OP*)gwop;
10235     offset = pad_findmy_pvs("$_", 0);
10236     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
10237         o->op_private = gwop->op_private = 0;
10238         gwop->op_targ = pad_alloc(type, SVs_PADTMP);
10239     }
10240     else {
10241         o->op_private = gwop->op_private = OPpGREP_LEX;
10242         gwop->op_targ = o->op_targ = offset;
10243     }
10244
10245     kid = OpSIBLING(cLISTOPo->op_first);
10246     for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
10247         op_lvalue(kid, OP_GREPSTART);
10248
10249     return (OP*)gwop;
10250 }
10251
10252 OP *
10253 Perl_ck_index(pTHX_ OP *o)
10254 {
10255     PERL_ARGS_ASSERT_CK_INDEX;
10256
10257     if (o->op_flags & OPf_KIDS) {
10258         OP *kid = OpSIBLING(cLISTOPo->op_first);        /* get past pushmark */
10259         if (kid)
10260             kid = OpSIBLING(kid);                       /* get past "big" */
10261         if (kid && kid->op_type == OP_CONST) {
10262             const bool save_taint = TAINT_get;
10263             SV *sv = kSVOP->op_sv;
10264             if ((!SvPOK(sv) || SvNIOKp(sv)) && SvOK(sv) && !SvROK(sv)) {
10265                 sv = newSV(0);
10266                 sv_copypv(sv, kSVOP->op_sv);
10267                 SvREFCNT_dec_NN(kSVOP->op_sv);
10268                 kSVOP->op_sv = sv;
10269             }
10270             if (SvOK(sv)) fbm_compile(sv, 0);
10271             TAINT_set(save_taint);
10272 #ifdef NO_TAINT_SUPPORT
10273             PERL_UNUSED_VAR(save_taint);
10274 #endif
10275         }
10276     }
10277     return ck_fun(o);
10278 }
10279
10280 OP *
10281 Perl_ck_lfun(pTHX_ OP *o)
10282 {
10283     const OPCODE type = o->op_type;
10284
10285     PERL_ARGS_ASSERT_CK_LFUN;
10286
10287     return modkids(ck_fun(o), type);
10288 }
10289
10290 OP *
10291 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
10292 {
10293     PERL_ARGS_ASSERT_CK_DEFINED;
10294
10295     if ((o->op_flags & OPf_KIDS)) {
10296         switch (cUNOPo->op_first->op_type) {
10297         case OP_RV2AV:
10298         case OP_PADAV:
10299             Perl_croak(aTHX_ "Can't use 'defined(@array)'"
10300                              " (Maybe you should just omit the defined()?)");
10301         break;
10302         case OP_RV2HV:
10303         case OP_PADHV:
10304             Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
10305                              " (Maybe you should just omit the defined()?)");
10306             break;
10307         default:
10308             /* no warning */
10309             break;
10310         }
10311     }
10312     return ck_rfun(o);
10313 }
10314
10315 OP *
10316 Perl_ck_readline(pTHX_ OP *o)
10317 {
10318     PERL_ARGS_ASSERT_CK_READLINE;
10319
10320     if (o->op_flags & OPf_KIDS) {
10321          OP *kid = cLISTOPo->op_first;
10322          if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
10323     }
10324     else {
10325         OP * const newop
10326             = newUNOP(OP_READLINE, o->op_flags | OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
10327         op_free(o);
10328         return newop;
10329     }
10330     return o;
10331 }
10332
10333 OP *
10334 Perl_ck_rfun(pTHX_ OP *o)
10335 {
10336     const OPCODE type = o->op_type;
10337
10338     PERL_ARGS_ASSERT_CK_RFUN;
10339
10340     return refkids(ck_fun(o), type);
10341 }
10342
10343 OP *
10344 Perl_ck_listiob(pTHX_ OP *o)
10345 {
10346     OP *kid;
10347
10348     PERL_ARGS_ASSERT_CK_LISTIOB;
10349
10350     kid = cLISTOPo->op_first;
10351     if (!kid) {
10352         o = force_list(o, 1);
10353         kid = cLISTOPo->op_first;
10354     }
10355     if (kid->op_type == OP_PUSHMARK)
10356         kid = OpSIBLING(kid);
10357     if (kid && o->op_flags & OPf_STACKED)
10358         kid = OpSIBLING(kid);
10359     else if (kid && !OpHAS_SIBLING(kid)) {              /* print HANDLE; */
10360         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
10361          && !kid->op_folded) {
10362             o->op_flags |= OPf_STACKED; /* make it a filehandle */
10363             scalar(kid);
10364             /* replace old const op with new OP_RV2GV parent */
10365             kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
10366                                         OP_RV2GV, OPf_REF);
10367             kid = OpSIBLING(kid);
10368         }
10369     }
10370
10371     if (!kid)
10372         op_append_elem(o->op_type, o, newDEFSVOP());
10373
10374     if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
10375     return listkids(o);
10376 }
10377
10378 OP *
10379 Perl_ck_smartmatch(pTHX_ OP *o)
10380 {
10381     dVAR;
10382     PERL_ARGS_ASSERT_CK_SMARTMATCH;
10383     if (0 == (o->op_flags & OPf_SPECIAL)) {
10384         OP *first  = cBINOPo->op_first;
10385         OP *second = OpSIBLING(first);
10386
10387         /* Implicitly take a reference to an array or hash */
10388
10389         /* remove the original two siblings, then add back the
10390          * (possibly different) first and second sibs.
10391          */
10392         op_sibling_splice(o, NULL, 1, NULL);
10393         op_sibling_splice(o, NULL, 1, NULL);
10394         first  = ref_array_or_hash(first);
10395         second = ref_array_or_hash(second);
10396         op_sibling_splice(o, NULL, 0, second);
10397         op_sibling_splice(o, NULL, 0, first);
10398
10399         /* Implicitly take a reference to a regular expression */
10400         if (first->op_type == OP_MATCH) {
10401             CHANGE_TYPE(first, OP_QR);
10402         }
10403         if (second->op_type == OP_MATCH) {
10404             CHANGE_TYPE(second, OP_QR);
10405         }
10406     }
10407
10408     return o;
10409 }
10410
10411
10412 static OP *
10413 S_maybe_targlex(pTHX_ OP *o)
10414 {
10415     OP * const kid = cLISTOPo->op_first;
10416     /* has a disposable target? */
10417     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
10418         && !(kid->op_flags & OPf_STACKED)
10419         /* Cannot steal the second time! */
10420         && !(kid->op_private & OPpTARGET_MY)
10421         )
10422     {
10423         OP * const kkid = OpSIBLING(kid);
10424
10425         /* Can just relocate the target. */
10426         if (kkid && kkid->op_type == OP_PADSV
10427             && (!(kkid->op_private & OPpLVAL_INTRO)
10428                || kkid->op_private & OPpPAD_STATE))
10429         {
10430             kid->op_targ = kkid->op_targ;
10431             kkid->op_targ = 0;
10432             /* Now we do not need PADSV and SASSIGN.
10433              * Detach kid and free the rest. */
10434             op_sibling_splice(o, NULL, 1, NULL);
10435             op_free(o);
10436             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
10437             return kid;
10438         }
10439     }
10440     return o;
10441 }
10442
10443 OP *
10444 Perl_ck_sassign(pTHX_ OP *o)
10445 {
10446     dVAR;
10447     OP * const kid = cLISTOPo->op_first;
10448
10449     PERL_ARGS_ASSERT_CK_SASSIGN;
10450
10451     if (OpHAS_SIBLING(kid)) {
10452         OP *kkid = OpSIBLING(kid);
10453         /* For state variable assignment with attributes, kkid is a list op
10454            whose op_last is a padsv. */
10455         if ((kkid->op_type == OP_PADSV ||
10456              (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
10457               (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
10458              )
10459             )
10460                 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
10461                     == (OPpLVAL_INTRO|OPpPAD_STATE)) {
10462             const PADOFFSET target = kkid->op_targ;
10463             OP *const other = newOP(OP_PADSV,
10464                                     kkid->op_flags
10465                                     | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
10466             OP *const first = newOP(OP_NULL, 0);
10467             OP *const nullop =
10468                 newCONDOP(0, first, S_maybe_targlex(aTHX_ o), other);
10469             OP *const condop = first->op_next;
10470
10471             CHANGE_TYPE(condop, OP_ONCE);
10472             other->op_targ = target;
10473             nullop->op_flags |= OPf_WANT_SCALAR;
10474
10475             /* Store the initializedness of state vars in a separate
10476                pad entry.  */
10477             condop->op_targ =
10478               pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
10479             /* hijacking PADSTALE for uninitialized state variables */
10480             SvPADSTALE_on(PAD_SVl(condop->op_targ));
10481
10482             return nullop;
10483         }
10484     }
10485     return S_maybe_targlex(aTHX_ o);
10486 }
10487
10488 OP *
10489 Perl_ck_match(pTHX_ OP *o)
10490 {
10491     PERL_ARGS_ASSERT_CK_MATCH;
10492
10493     if (o->op_type != OP_QR && PL_compcv) {
10494         const PADOFFSET offset = pad_findmy_pvs("$_", 0);
10495         if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
10496             o->op_targ = offset;
10497             o->op_private |= OPpTARGET_MY;
10498         }
10499     }
10500     if (o->op_type == OP_MATCH || o->op_type == OP_QR)
10501         o->op_private |= OPpRUNTIME;
10502     return o;
10503 }
10504
10505 OP *
10506 Perl_ck_method(pTHX_ OP *o)
10507 {
10508     SV *sv, *methsv, *rclass;
10509     const char* method;
10510     char* compatptr;
10511     int utf8;
10512     STRLEN len, nsplit = 0, i;
10513     OP* new_op;
10514     OP * const kid = cUNOPo->op_first;
10515
10516     PERL_ARGS_ASSERT_CK_METHOD;
10517     if (kid->op_type != OP_CONST) return o;
10518
10519     sv = kSVOP->op_sv;
10520
10521     /* replace ' with :: */
10522     while ((compatptr = strchr(SvPVX(sv), '\''))) {
10523         *compatptr = ':';
10524         sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
10525     }
10526
10527     method = SvPVX_const(sv);
10528     len = SvCUR(sv);
10529     utf8 = SvUTF8(sv) ? -1 : 1;
10530
10531     for (i = len - 1; i > 0; --i) if (method[i] == ':') {
10532         nsplit = i+1;
10533         break;
10534     }
10535
10536     methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
10537
10538     if (!nsplit) { /* $proto->method() */
10539         op_free(o);
10540         return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
10541     }
10542
10543     if (nsplit == 7 && memEQ(method, "SUPER::", nsplit)) { /* $proto->SUPER::method() */
10544         op_free(o);
10545         return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
10546     }
10547
10548     /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
10549     if (nsplit >= 9 && strnEQ(method+nsplit-9, "::SUPER::", 9)) {
10550         rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
10551         new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
10552     } else {
10553         rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
10554         new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
10555     }
10556 #ifdef USE_ITHREADS
10557     op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
10558 #else
10559     cMETHOPx(new_op)->op_rclass_sv = rclass;
10560 #endif
10561     op_free(o);
10562     return new_op;
10563 }
10564
10565 OP *
10566 Perl_ck_null(pTHX_ OP *o)
10567 {
10568     PERL_ARGS_ASSERT_CK_NULL;
10569     PERL_UNUSED_CONTEXT;
10570     return o;
10571 }
10572
10573 OP *
10574 Perl_ck_open(pTHX_ OP *o)
10575 {
10576     PERL_ARGS_ASSERT_CK_OPEN;
10577
10578     S_io_hints(aTHX_ o);
10579     {
10580          /* In case of three-arg dup open remove strictness
10581           * from the last arg if it is a bareword. */
10582          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
10583          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
10584          OP *oa;
10585          const char *mode;
10586
10587          if ((last->op_type == OP_CONST) &&             /* The bareword. */
10588              (last->op_private & OPpCONST_BARE) &&
10589              (last->op_private & OPpCONST_STRICT) &&
10590              (oa = OpSIBLING(first)) &&         /* The fh. */
10591              (oa = OpSIBLING(oa)) &&                    /* The mode. */
10592              (oa->op_type == OP_CONST) &&
10593              SvPOK(((SVOP*)oa)->op_sv) &&
10594              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
10595              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
10596              (last == OpSIBLING(oa)))                   /* The bareword. */
10597               last->op_private &= ~OPpCONST_STRICT;
10598     }
10599     return ck_fun(o);
10600 }
10601
10602 OP *
10603 Perl_ck_prototype(pTHX_ OP *o)
10604 {
10605     PERL_ARGS_ASSERT_CK_PROTOTYPE;
10606     if (!(o->op_flags & OPf_KIDS)) {
10607         op_free(o);
10608         return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
10609     }
10610     return o;
10611 }
10612
10613 OP *
10614 Perl_ck_refassign(pTHX_ OP *o)
10615 {
10616     OP * const right = cLISTOPo->op_first;
10617     OP * const left = OpSIBLING(right);
10618     OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
10619     bool stacked = 0;
10620
10621     PERL_ARGS_ASSERT_CK_REFASSIGN;
10622     assert (left);
10623     assert (left->op_type == OP_SREFGEN);
10624
10625     o->op_private = varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE);
10626
10627     switch (varop->op_type) {
10628     case OP_PADAV:
10629         o->op_private |= OPpLVREF_AV;
10630         goto settarg;
10631     case OP_PADHV:
10632         o->op_private |= OPpLVREF_HV;
10633     case OP_PADSV:
10634       settarg:
10635         o->op_targ = varop->op_targ;
10636         varop->op_targ = 0;
10637         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
10638         break;
10639     case OP_RV2AV:
10640         o->op_private |= OPpLVREF_AV;
10641         goto checkgv;
10642     case OP_RV2HV:
10643         o->op_private |= OPpLVREF_HV;
10644     case OP_RV2SV:
10645       checkgv:
10646         if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
10647       detach_and_stack:
10648         /* Point varop to its GV kid, detached.  */
10649         varop = op_sibling_splice(varop, NULL, -1, NULL);
10650         stacked = TRUE;
10651         break;
10652     case OP_RV2CV: {
10653         OP * const kidparent =
10654             cUNOPx(cUNOPx(varop)->op_first)->op_first->op_sibling;
10655         OP * const kid = cUNOPx(kidparent)->op_first;
10656         o->op_private |= OPpLVREF_CV;
10657         if (kid->op_type == OP_GV) {
10658             varop = kidparent;
10659             goto detach_and_stack;
10660         }
10661         if (kid->op_type != OP_PADCV)   goto bad;
10662         o->op_targ = kid->op_targ;
10663         kid->op_targ = 0;
10664         break;
10665     }
10666     case OP_AELEM:
10667     case OP_HELEM:
10668         o->op_private |= OPpLVREF_ELEM;
10669         op_null(varop);
10670         stacked = TRUE;
10671         /* Detach varop.  */
10672         op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
10673         break;
10674     default:
10675       bad:
10676         /* diag_listed_as: Can't modify reference to %s in %s assignment */
10677         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
10678                                 "assignment",
10679                                  OP_DESC(varop)));
10680         return o;
10681     }
10682     if (!FEATURE_REFALIASING_IS_ENABLED)
10683         Perl_croak(aTHX_
10684                   "Experimental aliasing via reference not enabled");
10685     Perl_ck_warner_d(aTHX_
10686                      packWARN(WARN_EXPERIMENTAL__REFALIASING),
10687                     "Aliasing via reference is experimental");
10688     if (stacked) {
10689         o->op_flags |= OPf_STACKED;
10690         op_sibling_splice(o, right, 1, varop);
10691     }
10692     else {
10693         o->op_flags &=~ OPf_STACKED;
10694         op_sibling_splice(o, right, 1, NULL);
10695     }
10696     op_free(left);
10697     return o;
10698 }
10699
10700 OP *
10701 Perl_ck_repeat(pTHX_ OP *o)
10702 {
10703     PERL_ARGS_ASSERT_CK_REPEAT;
10704
10705     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
10706         OP* kids;
10707         o->op_private |= OPpREPEAT_DOLIST;
10708         kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
10709         kids = force_list(kids, 1); /* promote it to a list */
10710         op_sibling_splice(o, NULL, 0, kids); /* and add back */
10711     }
10712     else
10713         scalar(o);
10714     return o;
10715 }
10716
10717 OP *
10718 Perl_ck_require(pTHX_ OP *o)
10719 {
10720     GV* gv;
10721
10722     PERL_ARGS_ASSERT_CK_REQUIRE;
10723
10724     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
10725         SVOP * const kid = (SVOP*)cUNOPo->op_first;
10726         HEK *hek;
10727         U32 hash;
10728         char *s;
10729         STRLEN len;
10730         if (kid->op_type == OP_CONST) {
10731           SV * const sv = kid->op_sv;
10732           U32 const was_readonly = SvREADONLY(sv);
10733           if (kid->op_private & OPpCONST_BARE) {
10734             dVAR;
10735             const char *end;
10736
10737             if (was_readonly) {
10738                     SvREADONLY_off(sv);
10739             }
10740             if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
10741
10742             s = SvPVX(sv);
10743             len = SvCUR(sv);
10744             end = s + len;
10745             for (; s < end; s++) {
10746                 if (*s == ':' && s[1] == ':') {
10747                     *s = '/';
10748                     Move(s+2, s+1, end - s - 1, char);
10749                     --end;
10750                 }
10751             }
10752             SvEND_set(sv, end);
10753             sv_catpvs(sv, ".pm");
10754             PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
10755             hek = share_hek(SvPVX(sv),
10756                             (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
10757                             hash);
10758             sv_sethek(sv, hek);
10759             unshare_hek(hek);
10760             SvFLAGS(sv) |= was_readonly;
10761           }
10762           else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)) {
10763             s = SvPV(sv, len);
10764             if (SvREFCNT(sv) > 1) {
10765                 kid->op_sv = newSVpvn_share(
10766                     s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
10767                 SvREFCNT_dec_NN(sv);
10768             }
10769             else {
10770                 dVAR;
10771                 if (was_readonly) SvREADONLY_off(sv);
10772                 PERL_HASH(hash, s, len);
10773                 hek = share_hek(s,
10774                                 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
10775                                 hash);
10776                 sv_sethek(sv, hek);
10777                 unshare_hek(hek);
10778                 SvFLAGS(sv) |= was_readonly;
10779             }
10780           }
10781         }
10782     }
10783
10784     if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
10785         /* handle override, if any */
10786      && (gv = gv_override("require", 7))) {
10787         OP *kid, *newop;
10788         if (o->op_flags & OPf_KIDS) {
10789             kid = cUNOPo->op_first;
10790             op_sibling_splice(o, NULL, -1, NULL);
10791         }
10792         else {
10793             kid = newDEFSVOP();
10794         }
10795         op_free(o);
10796         newop = S_new_entersubop(aTHX_ gv, kid);
10797         return newop;
10798     }
10799
10800     return ck_fun(o);
10801 }
10802
10803 OP *
10804 Perl_ck_return(pTHX_ OP *o)
10805 {
10806     OP *kid;
10807
10808     PERL_ARGS_ASSERT_CK_RETURN;
10809
10810     kid = OpSIBLING(cLISTOPo->op_first);
10811     if (CvLVALUE(PL_compcv)) {
10812         for (; kid; kid = OpSIBLING(kid))
10813             op_lvalue(kid, OP_LEAVESUBLV);
10814     }
10815
10816     return o;
10817 }
10818
10819 OP *
10820 Perl_ck_select(pTHX_ OP *o)
10821 {
10822     dVAR;
10823     OP* kid;
10824
10825     PERL_ARGS_ASSERT_CK_SELECT;
10826
10827     if (o->op_flags & OPf_KIDS) {
10828         kid = OpSIBLING(cLISTOPo->op_first);     /* get past pushmark */
10829         if (kid && OpHAS_SIBLING(kid)) {
10830             CHANGE_TYPE(o, OP_SSELECT);
10831             o = ck_fun(o);
10832             return fold_constants(op_integerize(op_std_init(o)));
10833         }
10834     }
10835     o = ck_fun(o);
10836     kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
10837     if (kid && kid->op_type == OP_RV2GV)
10838         kid->op_private &= ~HINT_STRICT_REFS;
10839     return o;
10840 }
10841
10842 OP *
10843 Perl_ck_shift(pTHX_ OP *o)
10844 {
10845     const I32 type = o->op_type;
10846
10847     PERL_ARGS_ASSERT_CK_SHIFT;
10848
10849     if (!(o->op_flags & OPf_KIDS)) {
10850         OP *argop;
10851
10852         if (!CvUNIQUE(PL_compcv)) {
10853             o->op_flags |= OPf_SPECIAL;
10854             return o;
10855         }
10856
10857         argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
10858         op_free(o);
10859         return newUNOP(type, 0, scalar(argop));
10860     }
10861     return scalar(ck_fun(o));
10862 }
10863
10864 OP *
10865 Perl_ck_sort(pTHX_ OP *o)
10866 {
10867     OP *firstkid;
10868     OP *kid;
10869     HV * const hinthv =
10870         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
10871     U8 stacked;
10872
10873     PERL_ARGS_ASSERT_CK_SORT;
10874
10875     if (hinthv) {
10876             SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
10877             if (svp) {
10878                 const I32 sorthints = (I32)SvIV(*svp);
10879                 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
10880                     o->op_private |= OPpSORT_QSORT;
10881                 if ((sorthints & HINT_SORT_STABLE) != 0)
10882                     o->op_private |= OPpSORT_STABLE;
10883             }
10884     }
10885
10886     if (o->op_flags & OPf_STACKED)
10887         simplify_sort(o);
10888     firstkid = OpSIBLING(cLISTOPo->op_first);           /* get past pushmark */
10889
10890     if ((stacked = o->op_flags & OPf_STACKED)) {        /* may have been cleared */
10891         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
10892
10893         /* if the first arg is a code block, process it and mark sort as
10894          * OPf_SPECIAL */
10895         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
10896             LINKLIST(kid);
10897             if (kid->op_type == OP_LEAVE)
10898                     op_null(kid);                       /* wipe out leave */
10899             /* Prevent execution from escaping out of the sort block. */
10900             kid->op_next = 0;
10901
10902             /* provide scalar context for comparison function/block */
10903             kid = scalar(firstkid);
10904             kid->op_next = kid;
10905             o->op_flags |= OPf_SPECIAL;
10906         }
10907         else if (kid->op_type == OP_CONST
10908               && kid->op_private & OPpCONST_BARE) {
10909             char tmpbuf[256];
10910             STRLEN len;
10911             PADOFFSET off;
10912             const char * const name = SvPV(kSVOP_sv, len);
10913             *tmpbuf = '&';
10914             assert (len < 256);
10915             Copy(name, tmpbuf+1, len, char);
10916             off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv));
10917             if (off != NOT_IN_PAD) {
10918                 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
10919                     SV * const fq =
10920                         newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
10921                     sv_catpvs(fq, "::");
10922                     sv_catsv(fq, kSVOP_sv);
10923                     SvREFCNT_dec_NN(kSVOP_sv);
10924                     kSVOP->op_sv = fq;
10925                 }
10926                 else {
10927                     OP * const padop = newOP(OP_PADCV, 0);
10928                     padop->op_targ = off;
10929                     cUNOPx(firstkid)->op_first = padop;
10930 #ifdef PERL_OP_PARENT
10931                     padop->op_sibling = firstkid;
10932 #endif
10933                     op_free(kid);
10934                 }
10935             }
10936         }
10937
10938         firstkid = OpSIBLING(firstkid);
10939     }
10940
10941     for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
10942         /* provide list context for arguments */
10943         list(kid);
10944         if (stacked)
10945             op_lvalue(kid, OP_GREPSTART);
10946     }
10947
10948     return o;
10949 }
10950
10951 /* for sort { X } ..., where X is one of
10952  *   $a <=> $b, $b <= $a, $a cmp $b, $b cmp $a
10953  * elide the second child of the sort (the one containing X),
10954  * and set these flags as appropriate
10955         OPpSORT_NUMERIC;
10956         OPpSORT_INTEGER;
10957         OPpSORT_DESCEND;
10958  * Also, check and warn on lexical $a, $b.
10959  */
10960
10961 STATIC void
10962 S_simplify_sort(pTHX_ OP *o)
10963 {
10964     OP *kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
10965     OP *k;
10966     int descending;
10967     GV *gv;
10968     const char *gvname;
10969     bool have_scopeop;
10970
10971     PERL_ARGS_ASSERT_SIMPLIFY_SORT;
10972
10973     kid = kUNOP->op_first;                              /* get past null */
10974     if (!(have_scopeop = kid->op_type == OP_SCOPE)
10975      && kid->op_type != OP_LEAVE)
10976         return;
10977     kid = kLISTOP->op_last;                             /* get past scope */
10978     switch(kid->op_type) {
10979         case OP_NCMP:
10980         case OP_I_NCMP:
10981         case OP_SCMP:
10982             if (!have_scopeop) goto padkids;
10983             break;
10984         default:
10985             return;
10986     }
10987     k = kid;                                            /* remember this node*/
10988     if (kBINOP->op_first->op_type != OP_RV2SV
10989      || kBINOP->op_last ->op_type != OP_RV2SV)
10990     {
10991         /*
10992            Warn about my($a) or my($b) in a sort block, *if* $a or $b is
10993            then used in a comparison.  This catches most, but not
10994            all cases.  For instance, it catches
10995                sort { my($a); $a <=> $b }
10996            but not
10997                sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
10998            (although why you'd do that is anyone's guess).
10999         */
11000
11001        padkids:
11002         if (!ckWARN(WARN_SYNTAX)) return;
11003         kid = kBINOP->op_first;
11004         do {
11005             if (kid->op_type == OP_PADSV) {
11006                 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
11007                 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
11008                  && (  PadnamePV(name)[1] == 'a'
11009                     || PadnamePV(name)[1] == 'b'  ))
11010                     /* diag_listed_as: "my %s" used in sort comparison */
11011                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11012                                      "\"%s %s\" used in sort comparison",
11013                                       PadnameIsSTATE(name)
11014                                         ? "state"
11015                                         : "my",
11016                                       PadnamePV(name));
11017             }
11018         } while ((kid = OpSIBLING(kid)));
11019         return;
11020     }
11021     kid = kBINOP->op_first;                             /* get past cmp */
11022     if (kUNOP->op_first->op_type != OP_GV)
11023         return;
11024     kid = kUNOP->op_first;                              /* get past rv2sv */
11025     gv = kGVOP_gv;
11026     if (GvSTASH(gv) != PL_curstash)
11027         return;
11028     gvname = GvNAME(gv);
11029     if (*gvname == 'a' && gvname[1] == '\0')
11030         descending = 0;
11031     else if (*gvname == 'b' && gvname[1] == '\0')
11032         descending = 1;
11033     else
11034         return;
11035
11036     kid = k;                                            /* back to cmp */
11037     /* already checked above that it is rv2sv */
11038     kid = kBINOP->op_last;                              /* down to 2nd arg */
11039     if (kUNOP->op_first->op_type != OP_GV)
11040         return;
11041     kid = kUNOP->op_first;                              /* get past rv2sv */
11042     gv = kGVOP_gv;
11043     if (GvSTASH(gv) != PL_curstash)
11044         return;
11045     gvname = GvNAME(gv);
11046     if ( descending
11047          ? !(*gvname == 'a' && gvname[1] == '\0')
11048          : !(*gvname == 'b' && gvname[1] == '\0'))
11049         return;
11050     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
11051     if (descending)
11052         o->op_private |= OPpSORT_DESCEND;
11053     if (k->op_type == OP_NCMP)
11054         o->op_private |= OPpSORT_NUMERIC;
11055     if (k->op_type == OP_I_NCMP)
11056         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
11057     kid = OpSIBLING(cLISTOPo->op_first);
11058     /* cut out and delete old block (second sibling) */
11059     op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
11060     op_free(kid);
11061 }
11062
11063 OP *
11064 Perl_ck_split(pTHX_ OP *o)
11065 {
11066     dVAR;
11067     OP *kid;
11068
11069     PERL_ARGS_ASSERT_CK_SPLIT;
11070
11071     if (o->op_flags & OPf_STACKED)
11072         return no_fh_allowed(o);
11073
11074     kid = cLISTOPo->op_first;
11075     if (kid->op_type != OP_NULL)
11076         Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
11077     /* delete leading NULL node, then add a CONST if no other nodes */
11078     op_sibling_splice(o, NULL, 1,
11079         OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
11080     op_free(kid);
11081     kid = cLISTOPo->op_first;
11082
11083     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
11084         /* remove kid, and replace with new optree */
11085         op_sibling_splice(o, NULL, 1, NULL);
11086         /* OPf_SPECIAL is used to trigger split " " behavior */
11087         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, NULL, 0, 0);
11088         op_sibling_splice(o, NULL, 0, kid);
11089     }
11090     CHANGE_TYPE(kid, OP_PUSHRE);
11091     scalar(kid);
11092     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
11093       Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
11094                      "Use of /g modifier is meaningless in split");
11095     }
11096
11097     if (!OpHAS_SIBLING(kid))
11098         op_append_elem(OP_SPLIT, o, newDEFSVOP());
11099
11100     kid = OpSIBLING(kid);
11101     assert(kid);
11102     scalar(kid);
11103
11104     if (!OpHAS_SIBLING(kid))
11105     {
11106         op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
11107         o->op_private |= OPpSPLIT_IMPLIM;
11108     }
11109     assert(OpHAS_SIBLING(kid));
11110
11111     kid = OpSIBLING(kid);
11112     scalar(kid);
11113
11114     if (OpHAS_SIBLING(kid))
11115         return too_many_arguments_pv(o,OP_DESC(o), 0);
11116
11117     return o;
11118 }
11119
11120 OP *
11121 Perl_ck_stringify(pTHX_ OP *o)
11122 {
11123     OP * const kid = OpSIBLING(cUNOPo->op_first);
11124     PERL_ARGS_ASSERT_CK_STRINGIFY;
11125     if (kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
11126      || kid->op_type == OP_LC   || kid->op_type == OP_LCFIRST
11127      || kid->op_type == OP_UC   || kid->op_type == OP_UCFIRST)
11128     {
11129         assert(!OpHAS_SIBLING(kid));
11130         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
11131         op_free(o);
11132         return kid;
11133     }
11134     return ck_fun(o);
11135 }
11136
11137 OP *
11138 Perl_ck_join(pTHX_ OP *o)
11139 {
11140     OP * const kid = OpSIBLING(cLISTOPo->op_first);
11141
11142     PERL_ARGS_ASSERT_CK_JOIN;
11143
11144     if (kid && kid->op_type == OP_MATCH) {
11145         if (ckWARN(WARN_SYNTAX)) {
11146             const REGEXP *re = PM_GETRE(kPMOP);
11147             const SV *msg = re
11148                     ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
11149                                             SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
11150                     : newSVpvs_flags( "STRING", SVs_TEMP );
11151             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11152                         "/%"SVf"/ should probably be written as \"%"SVf"\"",
11153                         SVfARG(msg), SVfARG(msg));
11154         }
11155     }
11156     if (kid
11157      && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
11158         || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
11159         || (  kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
11160            && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
11161     {
11162         const OP * const bairn = OpSIBLING(kid); /* the list */
11163         if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
11164          && OP_GIMME(bairn,0) == G_SCALAR)
11165         {
11166             OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
11167                                      op_sibling_splice(o, kid, 1, NULL));
11168             op_free(o);
11169             return ret;
11170         }
11171     }
11172
11173     return ck_fun(o);
11174 }
11175
11176 /*
11177 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
11178
11179 Examines an op, which is expected to identify a subroutine at runtime,
11180 and attempts to determine at compile time which subroutine it identifies.
11181 This is normally used during Perl compilation to determine whether
11182 a prototype can be applied to a function call.  I<cvop> is the op
11183 being considered, normally an C<rv2cv> op.  A pointer to the identified
11184 subroutine is returned, if it could be determined statically, and a null
11185 pointer is returned if it was not possible to determine statically.
11186
11187 Currently, the subroutine can be identified statically if the RV that the
11188 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
11189 A C<gv> op is suitable if the GV's CV slot is populated.  A C<const> op is
11190 suitable if the constant value must be an RV pointing to a CV.  Details of
11191 this process may change in future versions of Perl.  If the C<rv2cv> op
11192 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
11193 the subroutine statically: this flag is used to suppress compile-time
11194 magic on a subroutine call, forcing it to use default runtime behaviour.
11195
11196 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
11197 of a GV reference is modified.  If a GV was examined and its CV slot was
11198 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
11199 If the op is not optimised away, and the CV slot is later populated with
11200 a subroutine having a prototype, that flag eventually triggers the warning
11201 "called too early to check prototype".
11202
11203 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
11204 of returning a pointer to the subroutine it returns a pointer to the
11205 GV giving the most appropriate name for the subroutine in this context.
11206 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
11207 (C<CvANON>) subroutine that is referenced through a GV it will be the
11208 referencing GV.  The resulting C<GV*> is cast to C<CV*> to be returned.
11209 A null pointer is returned as usual if there is no statically-determinable
11210 subroutine.
11211
11212 =cut
11213 */
11214
11215 /* shared by toke.c:yylex */
11216 CV *
11217 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
11218 {
11219     PADNAME *name = PAD_COMPNAME(off);
11220     CV *compcv = PL_compcv;
11221     while (PadnameOUTER(name)) {
11222         assert(PARENT_PAD_INDEX(name));
11223         compcv = CvOUTSIDE(PL_compcv);
11224         name = PadlistNAMESARRAY(CvPADLIST(compcv))
11225                 [off = PARENT_PAD_INDEX(name)];
11226     }
11227     assert(!PadnameIsOUR(name));
11228     if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
11229         return PadnamePROTOCV(name);
11230     }
11231     return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
11232 }
11233
11234 CV *
11235 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
11236 {
11237     OP *rvop;
11238     CV *cv;
11239     GV *gv;
11240     PERL_ARGS_ASSERT_RV2CV_OP_CV;
11241     if (flags & ~RV2CVOPCV_FLAG_MASK)
11242         Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
11243     if (cvop->op_type != OP_RV2CV)
11244         return NULL;
11245     if (cvop->op_private & OPpENTERSUB_AMPER)
11246         return NULL;
11247     if (!(cvop->op_flags & OPf_KIDS))
11248         return NULL;
11249     rvop = cUNOPx(cvop)->op_first;
11250     switch (rvop->op_type) {
11251         case OP_GV: {
11252             gv = cGVOPx_gv(rvop);
11253             if (!isGV(gv)) {
11254                 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
11255                     cv = MUTABLE_CV(SvRV(gv));
11256                     gv = NULL;
11257                     break;
11258                 }
11259                 if (flags & RV2CVOPCV_RETURN_STUB)
11260                     return (CV *)gv;
11261                 else return NULL;
11262             }
11263             cv = GvCVu(gv);
11264             if (!cv) {
11265                 if (flags & RV2CVOPCV_MARK_EARLY)
11266                     rvop->op_private |= OPpEARLY_CV;
11267                 return NULL;
11268             }
11269         } break;
11270         case OP_CONST: {
11271             SV *rv = cSVOPx_sv(rvop);
11272             if (!SvROK(rv))
11273                 return NULL;
11274             cv = (CV*)SvRV(rv);
11275             gv = NULL;
11276         } break;
11277         case OP_PADCV: {
11278             cv = find_lexical_cv(rvop->op_targ);
11279             gv = NULL;
11280         } break;
11281         default: {
11282             return NULL;
11283         } NOT_REACHED; /* NOTREACHED */
11284     }
11285     if (SvTYPE((SV*)cv) != SVt_PVCV)
11286         return NULL;
11287     if (flags & (RV2CVOPCV_RETURN_NAME_GV|RV2CVOPCV_MAYBE_NAME_GV)) {
11288         if ((!CvANON(cv) || !gv) && !CvLEXICAL(cv)
11289          && ((flags & RV2CVOPCV_RETURN_NAME_GV) || !CvNAMED(cv)))
11290             gv = CvGV(cv);
11291         return (CV*)gv;
11292     } else {
11293         return cv;
11294     }
11295 }
11296
11297 /*
11298 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
11299
11300 Performs the default fixup of the arguments part of an C<entersub>
11301 op tree.  This consists of applying list context to each of the
11302 argument ops.  This is the standard treatment used on a call marked
11303 with C<&>, or a method call, or a call through a subroutine reference,
11304 or any other call where the callee can't be identified at compile time,
11305 or a call where the callee has no prototype.
11306
11307 =cut
11308 */
11309
11310 OP *
11311 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
11312 {
11313     OP *aop;
11314     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
11315     aop = cUNOPx(entersubop)->op_first;
11316     if (!OpHAS_SIBLING(aop))
11317         aop = cUNOPx(aop)->op_first;
11318     for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
11319         list(aop);
11320         op_lvalue(aop, OP_ENTERSUB);
11321     }
11322     return entersubop;
11323 }
11324
11325 /*
11326 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
11327
11328 Performs the fixup of the arguments part of an C<entersub> op tree
11329 based on a subroutine prototype.  This makes various modifications to
11330 the argument ops, from applying context up to inserting C<refgen> ops,
11331 and checking the number and syntactic types of arguments, as directed by
11332 the prototype.  This is the standard treatment used on a subroutine call,
11333 not marked with C<&>, where the callee can be identified at compile time
11334 and has a prototype.
11335
11336 I<protosv> supplies the subroutine prototype to be applied to the call.
11337 It may be a normal defined scalar, of which the string value will be used.
11338 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11339 that has been cast to C<SV*>) which has a prototype.  The prototype
11340 supplied, in whichever form, does not need to match the actual callee
11341 referenced by the op tree.
11342
11343 If the argument ops disagree with the prototype, for example by having
11344 an unacceptable number of arguments, a valid op tree is returned anyway.
11345 The error is reflected in the parser state, normally resulting in a single
11346 exception at the top level of parsing which covers all the compilation
11347 errors that occurred.  In the error message, the callee is referred to
11348 by the name defined by the I<namegv> parameter.
11349
11350 =cut
11351 */
11352
11353 OP *
11354 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11355 {
11356     STRLEN proto_len;
11357     const char *proto, *proto_end;
11358     OP *aop, *prev, *cvop, *parent;
11359     int optional = 0;
11360     I32 arg = 0;
11361     I32 contextclass = 0;
11362     const char *e = NULL;
11363     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
11364     if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
11365         Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
11366                    "flags=%lx", (unsigned long) SvFLAGS(protosv));
11367     if (SvTYPE(protosv) == SVt_PVCV)
11368          proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
11369     else proto = SvPV(protosv, proto_len);
11370     proto = S_strip_spaces(aTHX_ proto, &proto_len);
11371     proto_end = proto + proto_len;
11372     parent = entersubop;
11373     aop = cUNOPx(entersubop)->op_first;
11374     if (!OpHAS_SIBLING(aop)) {
11375         parent = aop;
11376         aop = cUNOPx(aop)->op_first;
11377     }
11378     prev = aop;
11379     aop = OpSIBLING(aop);
11380     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11381     while (aop != cvop) {
11382         OP* o3 = aop;
11383
11384         if (proto >= proto_end)
11385         {
11386             SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11387             yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf,
11388                                         SVfARG(namesv)), SvUTF8(namesv));
11389             return entersubop;
11390         }
11391
11392         switch (*proto) {
11393             case ';':
11394                 optional = 1;
11395                 proto++;
11396                 continue;
11397             case '_':
11398                 /* _ must be at the end */
11399                 if (proto[1] && !strchr(";@%", proto[1]))
11400                     goto oops;
11401                 /* FALLTHROUGH */
11402             case '$':
11403                 proto++;
11404                 arg++;
11405                 scalar(aop);
11406                 break;
11407             case '%':
11408             case '@':
11409                 list(aop);
11410                 arg++;
11411                 break;
11412             case '&':
11413                 proto++;
11414                 arg++;
11415                 if (o3->op_type != OP_SREFGEN
11416                  || (  cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
11417                         != OP_ANONCODE
11418                     && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
11419                         != OP_RV2CV))
11420                     bad_type_gv(arg,
11421                             arg == 1 ? "block or sub {}" : "sub {}",
11422                             namegv, 0, o3);
11423                 break;
11424             case '*':
11425                 /* '*' allows any scalar type, including bareword */
11426                 proto++;
11427                 arg++;
11428                 if (o3->op_type == OP_RV2GV)
11429                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
11430                 else if (o3->op_type == OP_CONST)
11431                     o3->op_private &= ~OPpCONST_STRICT;
11432                 scalar(aop);
11433                 break;
11434             case '+':
11435                 proto++;
11436                 arg++;
11437                 if (o3->op_type == OP_RV2AV ||
11438                     o3->op_type == OP_PADAV ||
11439                     o3->op_type == OP_RV2HV ||
11440                     o3->op_type == OP_PADHV
11441                 ) {
11442                     goto wrapref;
11443                 }
11444                 scalar(aop);
11445                 break;
11446             case '[': case ']':
11447                 goto oops;
11448
11449             case '\\':
11450                 proto++;
11451                 arg++;
11452             again:
11453                 switch (*proto++) {
11454                     case '[':
11455                         if (contextclass++ == 0) {
11456                             e = strchr(proto, ']');
11457                             if (!e || e == proto)
11458                                 goto oops;
11459                         }
11460                         else
11461                             goto oops;
11462                         goto again;
11463
11464                     case ']':
11465                         if (contextclass) {
11466                             const char *p = proto;
11467                             const char *const end = proto;
11468                             contextclass = 0;
11469                             while (*--p != '[')
11470                                 /* \[$] accepts any scalar lvalue */
11471                                 if (*p == '$'
11472                                  && Perl_op_lvalue_flags(aTHX_
11473                                      scalar(o3),
11474                                      OP_READ, /* not entersub */
11475                                      OP_LVALUE_NO_CROAK
11476                                     )) goto wrapref;
11477                             bad_type_gv(arg, Perl_form(aTHX_ "one of %.*s",
11478                                         (int)(end - p), p),
11479                                     namegv, 0, o3);
11480                         } else
11481                             goto oops;
11482                         break;
11483                     case '*':
11484                         if (o3->op_type == OP_RV2GV)
11485                             goto wrapref;
11486                         if (!contextclass)
11487                             bad_type_gv(arg, "symbol", namegv, 0, o3);
11488                         break;
11489                     case '&':
11490                         if (o3->op_type == OP_ENTERSUB
11491                          && !(o3->op_flags & OPf_STACKED))
11492                             goto wrapref;
11493                         if (!contextclass)
11494                             bad_type_gv(arg, "subroutine", namegv, 0,
11495                                     o3);
11496                         break;
11497                     case '$':
11498                         if (o3->op_type == OP_RV2SV ||
11499                                 o3->op_type == OP_PADSV ||
11500                                 o3->op_type == OP_HELEM ||
11501                                 o3->op_type == OP_AELEM)
11502                             goto wrapref;
11503                         if (!contextclass) {
11504                             /* \$ accepts any scalar lvalue */
11505                             if (Perl_op_lvalue_flags(aTHX_
11506                                     scalar(o3),
11507                                     OP_READ,  /* not entersub */
11508                                     OP_LVALUE_NO_CROAK
11509                                )) goto wrapref;
11510                             bad_type_gv(arg, "scalar", namegv, 0, o3);
11511                         }
11512                         break;
11513                     case '@':
11514                         if (o3->op_type == OP_RV2AV ||
11515                                 o3->op_type == OP_PADAV)
11516                         {
11517                             o3->op_flags &=~ OPf_PARENS;
11518                             goto wrapref;
11519                         }
11520                         if (!contextclass)
11521                             bad_type_gv(arg, "array", namegv, 0, o3);
11522                         break;
11523                     case '%':
11524                         if (o3->op_type == OP_RV2HV ||
11525                                 o3->op_type == OP_PADHV)
11526                         {
11527                             o3->op_flags &=~ OPf_PARENS;
11528                             goto wrapref;
11529                         }
11530                         if (!contextclass)
11531                             bad_type_gv(arg, "hash", namegv, 0, o3);
11532                         break;
11533                     wrapref:
11534                             aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
11535                                                 OP_REFGEN, 0);
11536                         if (contextclass && e) {
11537                             proto = e + 1;
11538                             contextclass = 0;
11539                         }
11540                         break;
11541                     default: goto oops;
11542                 }
11543                 if (contextclass)
11544                     goto again;
11545                 break;
11546             case ' ':
11547                 proto++;
11548                 continue;
11549             default:
11550             oops: {
11551                 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
11552                                   SVfARG(cv_name((CV *)namegv, NULL, 0)),
11553                                   SVfARG(protosv));
11554             }
11555         }
11556
11557         op_lvalue(aop, OP_ENTERSUB);
11558         prev = aop;
11559         aop = OpSIBLING(aop);
11560     }
11561     if (aop == cvop && *proto == '_') {
11562         /* generate an access to $_ */
11563         op_sibling_splice(parent, prev, 0, newDEFSVOP());
11564     }
11565     if (!optional && proto_end > proto &&
11566         (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
11567     {
11568         SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11569         yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf,
11570                                     SVfARG(namesv)), SvUTF8(namesv));
11571     }
11572     return entersubop;
11573 }
11574
11575 /*
11576 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
11577
11578 Performs the fixup of the arguments part of an C<entersub> op tree either
11579 based on a subroutine prototype or using default list-context processing.
11580 This is the standard treatment used on a subroutine call, not marked
11581 with C<&>, where the callee can be identified at compile time.
11582
11583 I<protosv> supplies the subroutine prototype to be applied to the call,
11584 or indicates that there is no prototype.  It may be a normal scalar,
11585 in which case if it is defined then the string value will be used
11586 as a prototype, and if it is undefined then there is no prototype.
11587 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11588 that has been cast to C<SV*>), of which the prototype will be used if it
11589 has one.  The prototype (or lack thereof) supplied, in whichever form,
11590 does not need to match the actual callee referenced by the op tree.
11591
11592 If the argument ops disagree with the prototype, for example by having
11593 an unacceptable number of arguments, a valid op tree is returned anyway.
11594 The error is reflected in the parser state, normally resulting in a single
11595 exception at the top level of parsing which covers all the compilation
11596 errors that occurred.  In the error message, the callee is referred to
11597 by the name defined by the I<namegv> parameter.
11598
11599 =cut
11600 */
11601
11602 OP *
11603 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
11604         GV *namegv, SV *protosv)
11605 {
11606     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
11607     if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
11608         return ck_entersub_args_proto(entersubop, namegv, protosv);
11609     else
11610         return ck_entersub_args_list(entersubop);
11611 }
11612
11613 OP *
11614 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11615 {
11616     int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
11617     OP *aop = cUNOPx(entersubop)->op_first;
11618
11619     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
11620
11621     if (!opnum) {
11622         OP *cvop;
11623         if (!OpHAS_SIBLING(aop))
11624             aop = cUNOPx(aop)->op_first;
11625         aop = OpSIBLING(aop);
11626         for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11627         if (aop != cvop)
11628             (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
11629
11630         op_free(entersubop);
11631         switch(GvNAME(namegv)[2]) {
11632         case 'F': return newSVOP(OP_CONST, 0,
11633                                         newSVpv(CopFILE(PL_curcop),0));
11634         case 'L': return newSVOP(
11635                            OP_CONST, 0,
11636                            Perl_newSVpvf(aTHX_
11637                              "%"IVdf, (IV)CopLINE(PL_curcop)
11638                            )
11639                          );
11640         case 'P': return newSVOP(OP_CONST, 0,
11641                                    (PL_curstash
11642                                      ? newSVhek(HvNAME_HEK(PL_curstash))
11643                                      : &PL_sv_undef
11644                                    )
11645                                 );
11646         }
11647         NOT_REACHED;
11648     }
11649     else {
11650         OP *prev, *cvop, *first, *parent;
11651         U32 flags = 0;
11652
11653         parent = entersubop;
11654         if (!OpHAS_SIBLING(aop)) {
11655             parent = aop;
11656             aop = cUNOPx(aop)->op_first;
11657         }
11658
11659         first = prev = aop;
11660         aop = OpSIBLING(aop);
11661         /* find last sibling */
11662         for (cvop = aop;
11663              OpHAS_SIBLING(cvop);
11664              prev = cvop, cvop = OpSIBLING(cvop))
11665             ;
11666         if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
11667             /* Usually, OPf_SPECIAL on an op with no args means that it had
11668              * parens, but these have their own meaning for that flag: */
11669             && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
11670             && opnum != OP_DELETE && opnum != OP_EXISTS)
11671                 flags |= OPf_SPECIAL;
11672         /* excise cvop from end of sibling chain */
11673         op_sibling_splice(parent, prev, 1, NULL);
11674         op_free(cvop);
11675         if (aop == cvop) aop = NULL;
11676
11677         /* detach remaining siblings from the first sibling, then
11678          * dispose of original optree */
11679
11680         if (aop)
11681             op_sibling_splice(parent, first, -1, NULL);
11682         op_free(entersubop);
11683
11684         if (opnum == OP_ENTEREVAL
11685          && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
11686             flags |= OPpEVAL_BYTES <<8;
11687
11688         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
11689         case OA_UNOP:
11690         case OA_BASEOP_OR_UNOP:
11691         case OA_FILESTATOP:
11692             return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
11693         case OA_BASEOP:
11694             if (aop) {
11695                     (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
11696                 op_free(aop);
11697             }
11698             return opnum == OP_RUNCV
11699                 ? newPVOP(OP_RUNCV,0,NULL)
11700                 : newOP(opnum,0);
11701         default:
11702             return op_convert_list(opnum,0,aop);
11703         }
11704     }
11705     NOT_REACHED;
11706     return entersubop;
11707 }
11708
11709 /*
11710 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
11711
11712 Retrieves the function that will be used to fix up a call to I<cv>.
11713 Specifically, the function is applied to an C<entersub> op tree for a
11714 subroutine call, not marked with C<&>, where the callee can be identified
11715 at compile time as I<cv>.
11716
11717 The C-level function pointer is returned in I<*ckfun_p>, and an SV
11718 argument for it is returned in I<*ckobj_p>.  The function is intended
11719 to be called in this manner:
11720
11721     entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
11722
11723 In this call, I<entersubop> is a pointer to the C<entersub> op,
11724 which may be replaced by the check function, and I<namegv> is a GV
11725 supplying the name that should be used by the check function to refer
11726 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11727 It is permitted to apply the check function in non-standard situations,
11728 such as to a call to a different subroutine or to a method call.
11729
11730 By default, the function is
11731 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
11732 and the SV parameter is I<cv> itself.  This implements standard
11733 prototype processing.  It can be changed, for a particular subroutine,
11734 by L</cv_set_call_checker>.
11735
11736 =cut
11737 */
11738
11739 static void
11740 S_cv_get_call_checker(CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p,
11741                       U8 *flagsp)
11742 {
11743     MAGIC *callmg;
11744     callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
11745     if (callmg) {
11746         *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
11747         *ckobj_p = callmg->mg_obj;
11748         if (flagsp) *flagsp = callmg->mg_flags;
11749     } else {
11750         *ckfun_p = Perl_ck_entersub_args_proto_or_list;
11751         *ckobj_p = (SV*)cv;
11752         if (flagsp) *flagsp = 0;
11753     }
11754 }
11755
11756 void
11757 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
11758 {
11759     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
11760     PERL_UNUSED_CONTEXT;
11761     S_cv_get_call_checker(cv, ckfun_p, ckobj_p, NULL);
11762 }
11763
11764 /*
11765 =for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 flags
11766
11767 Sets the function that will be used to fix up a call to I<cv>.
11768 Specifically, the function is applied to an C<entersub> op tree for a
11769 subroutine call, not marked with C<&>, where the callee can be identified
11770 at compile time as I<cv>.
11771
11772 The C-level function pointer is supplied in I<ckfun>, and an SV argument
11773 for it is supplied in I<ckobj>.  The function should be defined like this:
11774
11775     STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
11776
11777 It is intended to be called in this manner:
11778
11779     entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
11780
11781 In this call, I<entersubop> is a pointer to the C<entersub> op,
11782 which may be replaced by the check function, and I<namegv> supplies
11783 the name that should be used by the check function to refer
11784 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11785 It is permitted to apply the check function in non-standard situations,
11786 such as to a call to a different subroutine or to a method call.
11787
11788 I<namegv> may not actually be a GV.  For efficiency, perl may pass a
11789 CV or other SV instead.  Whatever is passed can be used as the first
11790 argument to L</cv_name>.  You can force perl to pass a GV by including
11791 C<CALL_CHECKER_REQUIRE_GV> in the I<flags>.
11792
11793 The current setting for a particular CV can be retrieved by
11794 L</cv_get_call_checker>.
11795
11796 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
11797
11798 The original form of L</cv_set_call_checker_flags>, which passes it the
11799 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.
11800
11801 =cut
11802 */
11803
11804 void
11805 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
11806 {
11807     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
11808     cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
11809 }
11810
11811 void
11812 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
11813                                      SV *ckobj, U32 flags)
11814 {
11815     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
11816     if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
11817         if (SvMAGICAL((SV*)cv))
11818             mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
11819     } else {
11820         MAGIC *callmg;
11821         sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
11822         callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
11823         assert(callmg);
11824         if (callmg->mg_flags & MGf_REFCOUNTED) {
11825             SvREFCNT_dec(callmg->mg_obj);
11826             callmg->mg_flags &= ~MGf_REFCOUNTED;
11827         }
11828         callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
11829         callmg->mg_obj = ckobj;
11830         if (ckobj != (SV*)cv) {
11831             SvREFCNT_inc_simple_void_NN(ckobj);
11832             callmg->mg_flags |= MGf_REFCOUNTED;
11833         }
11834         callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
11835                          | (U8)(flags & MGf_REQUIRE_GV) | MGf_COPY;
11836     }
11837 }
11838
11839 static void
11840 S_entersub_alloc_targ(pTHX_ OP * const o)
11841 {
11842     o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
11843     o->op_private |= OPpENTERSUB_HASTARG;
11844 }
11845
11846 OP *
11847 Perl_ck_subr(pTHX_ OP *o)
11848 {
11849     OP *aop, *cvop;
11850     CV *cv;
11851     GV *namegv;
11852     SV **const_class = NULL;
11853
11854     PERL_ARGS_ASSERT_CK_SUBR;
11855
11856     aop = cUNOPx(o)->op_first;
11857     if (!OpHAS_SIBLING(aop))
11858         aop = cUNOPx(aop)->op_first;
11859     aop = OpSIBLING(aop);
11860     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11861     cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
11862     namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
11863
11864     o->op_private &= ~1;
11865     o->op_private |= (PL_hints & HINT_STRICT_REFS);
11866     if (PERLDB_SUB && PL_curstash != PL_debstash)
11867         o->op_private |= OPpENTERSUB_DB;
11868     switch (cvop->op_type) {
11869         case OP_RV2CV:
11870             o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
11871             op_null(cvop);
11872             break;
11873         case OP_METHOD:
11874         case OP_METHOD_NAMED:
11875         case OP_METHOD_SUPER:
11876         case OP_METHOD_REDIR:
11877         case OP_METHOD_REDIR_SUPER:
11878             if (aop->op_type == OP_CONST) {
11879                 aop->op_private &= ~OPpCONST_STRICT;
11880                 const_class = &cSVOPx(aop)->op_sv;
11881             }
11882             else if (aop->op_type == OP_LIST) {
11883                 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
11884                 if (sib && sib->op_type == OP_CONST) {
11885                     sib->op_private &= ~OPpCONST_STRICT;
11886                     const_class = &cSVOPx(sib)->op_sv;
11887                 }
11888             }
11889             /* make class name a shared cow string to speedup method calls */
11890             /* constant string might be replaced with object, f.e. bigint */
11891             if (const_class && !SvROK(*const_class)) {
11892                 STRLEN len;
11893                 const char* str = SvPV(*const_class, len);
11894                 if (len) {
11895                     SV* const shared = newSVpvn_share(
11896                         str, SvUTF8(*const_class)
11897                                     ? -(SSize_t)len : (SSize_t)len,
11898                         0
11899                     );
11900                     SvREFCNT_dec(*const_class);
11901                     *const_class = shared;
11902                 }
11903             }
11904             break;
11905     }
11906
11907     if (!cv) {
11908         S_entersub_alloc_targ(aTHX_ o);
11909         return ck_entersub_args_list(o);
11910     } else {
11911         Perl_call_checker ckfun;
11912         SV *ckobj;
11913         U8 flags;
11914         S_cv_get_call_checker(cv, &ckfun, &ckobj, &flags);
11915         if (CvISXSUB(cv) || !CvROOT(cv))
11916             S_entersub_alloc_targ(aTHX_ o);
11917         if (!namegv) {
11918             /* The original call checker API guarantees that a GV will be
11919                be provided with the right name.  So, if the old API was
11920                used (or the REQUIRE_GV flag was passed), we have to reify
11921                the CV’s GV, unless this is an anonymous sub.  This is not
11922                ideal for lexical subs, as its stringification will include
11923                the package.  But it is the best we can do.  */
11924             if (flags & MGf_REQUIRE_GV) {
11925                 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
11926                     namegv = CvGV(cv);
11927             }
11928             else namegv = MUTABLE_GV(cv);
11929             /* After a syntax error in a lexical sub, the cv that
11930                rv2cv_op_cv returns may be a nameless stub. */
11931             if (!namegv) return ck_entersub_args_list(o);
11932
11933         }
11934         return ckfun(aTHX_ o, namegv, ckobj);
11935     }
11936 }
11937
11938 OP *
11939 Perl_ck_svconst(pTHX_ OP *o)
11940 {
11941     SV * const sv = cSVOPo->op_sv;
11942     PERL_ARGS_ASSERT_CK_SVCONST;
11943     PERL_UNUSED_CONTEXT;
11944 #ifdef PERL_OLD_COPY_ON_WRITE
11945     if (SvIsCOW(sv)) sv_force_normal(sv);
11946 #elif defined(PERL_NEW_COPY_ON_WRITE)
11947     /* Since the read-only flag may be used to protect a string buffer, we
11948        cannot do copy-on-write with existing read-only scalars that are not
11949        already copy-on-write scalars.  To allow $_ = "hello" to do COW with
11950        that constant, mark the constant as COWable here, if it is not
11951        already read-only. */
11952     if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
11953         SvIsCOW_on(sv);
11954         CowREFCNT(sv) = 0;
11955 # ifdef PERL_DEBUG_READONLY_COW
11956         sv_buf_to_ro(sv);
11957 # endif
11958     }
11959 #endif
11960     SvREADONLY_on(sv);
11961     return o;
11962 }
11963
11964 OP *
11965 Perl_ck_trunc(pTHX_ OP *o)
11966 {
11967     PERL_ARGS_ASSERT_CK_TRUNC;
11968
11969     if (o->op_flags & OPf_KIDS) {
11970         SVOP *kid = (SVOP*)cUNOPo->op_first;
11971
11972         if (kid->op_type == OP_NULL)
11973             kid = (SVOP*)OpSIBLING(kid);
11974         if (kid && kid->op_type == OP_CONST &&
11975             (kid->op_private & OPpCONST_BARE) &&
11976             !kid->op_folded)
11977         {
11978             o->op_flags |= OPf_SPECIAL;
11979             kid->op_private &= ~OPpCONST_STRICT;
11980         }
11981     }
11982     return ck_fun(o);
11983 }
11984
11985 OP *
11986 Perl_ck_substr(pTHX_ OP *o)
11987 {
11988     PERL_ARGS_ASSERT_CK_SUBSTR;
11989
11990     o = ck_fun(o);
11991     if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
11992         OP *kid = cLISTOPo->op_first;
11993
11994         if (kid->op_type == OP_NULL)
11995             kid = OpSIBLING(kid);
11996         if (kid)
11997             kid->op_flags |= OPf_MOD;
11998
11999     }
12000     return o;
12001 }
12002
12003 OP *
12004 Perl_ck_tell(pTHX_ OP *o)
12005 {
12006     PERL_ARGS_ASSERT_CK_TELL;
12007     o = ck_fun(o);
12008     if (o->op_flags & OPf_KIDS) {
12009      OP *kid = cLISTOPo->op_first;
12010      if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
12011      if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
12012     }
12013     return o;
12014 }
12015
12016 OP *
12017 Perl_ck_each(pTHX_ OP *o)
12018 {
12019     dVAR;
12020     OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
12021     const unsigned orig_type  = o->op_type;
12022     const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
12023                               : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
12024     const unsigned ref_type   = orig_type == OP_EACH ? OP_REACH
12025                               : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
12026
12027     PERL_ARGS_ASSERT_CK_EACH;
12028
12029     if (kid) {
12030         switch (kid->op_type) {
12031             case OP_PADHV:
12032             case OP_RV2HV:
12033                 break;
12034             case OP_PADAV:
12035             case OP_RV2AV:
12036                 CHANGE_TYPE(o, array_type);
12037                 break;
12038             case OP_CONST:
12039                 if (kid->op_private == OPpCONST_BARE
12040                  || !SvROK(cSVOPx_sv(kid))
12041                  || (  SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
12042                     && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV  )
12043                    )
12044                     /* we let ck_fun handle it */
12045                     break;
12046             default:
12047                 CHANGE_TYPE(o, ref_type);
12048                 scalar(kid);
12049         }
12050     }
12051     /* if treating as a reference, defer additional checks to runtime */
12052     if (o->op_type == ref_type) {
12053         /* diag_listed_as: keys on reference is experimental */
12054         Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__AUTODEREF),
12055                               "%s is experimental", PL_op_desc[ref_type]);
12056         return o;
12057     }
12058     return ck_fun(o);
12059 }
12060
12061 OP *
12062 Perl_ck_length(pTHX_ OP *o)
12063 {
12064     PERL_ARGS_ASSERT_CK_LENGTH;
12065
12066     o = ck_fun(o);
12067
12068     if (ckWARN(WARN_SYNTAX)) {
12069         const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
12070
12071         if (kid) {
12072             SV *name = NULL;
12073             const bool hash = kid->op_type == OP_PADHV
12074                            || kid->op_type == OP_RV2HV;
12075             switch (kid->op_type) {
12076                 case OP_PADHV:
12077                 case OP_PADAV:
12078                 case OP_RV2HV:
12079                 case OP_RV2AV:
12080                     name = S_op_varname(aTHX_ kid);
12081                     break;
12082                 default:
12083                     return o;
12084             }
12085             if (name)
12086                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12087                     "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
12088                     ")\"?)",
12089                     SVfARG(name), hash ? "keys " : "", SVfARG(name)
12090                 );
12091             else if (hash)
12092      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
12093                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12094                     "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
12095             else
12096      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
12097                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12098                     "length() used on @array (did you mean \"scalar(@array)\"?)");
12099         }
12100     }
12101
12102     return o;
12103 }
12104
12105 /* Check for in place reverse and sort assignments like "@a = reverse @a"
12106    and modify the optree to make them work inplace */
12107
12108 STATIC void
12109 S_inplace_aassign(pTHX_ OP *o) {
12110
12111     OP *modop, *modop_pushmark;
12112     OP *oright;
12113     OP *oleft, *oleft_pushmark;
12114
12115     PERL_ARGS_ASSERT_INPLACE_AASSIGN;
12116
12117     assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
12118
12119     assert(cUNOPo->op_first->op_type == OP_NULL);
12120     modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
12121     assert(modop_pushmark->op_type == OP_PUSHMARK);
12122     modop = OpSIBLING(modop_pushmark);
12123
12124     if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
12125         return;
12126
12127     /* no other operation except sort/reverse */
12128     if (OpHAS_SIBLING(modop))
12129         return;
12130
12131     assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
12132     if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
12133
12134     if (modop->op_flags & OPf_STACKED) {
12135         /* skip sort subroutine/block */
12136         assert(oright->op_type == OP_NULL);
12137         oright = OpSIBLING(oright);
12138     }
12139
12140     assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
12141     oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
12142     assert(oleft_pushmark->op_type == OP_PUSHMARK);
12143     oleft = OpSIBLING(oleft_pushmark);
12144
12145     /* Check the lhs is an array */
12146     if (!oleft ||
12147         (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
12148         || OpHAS_SIBLING(oleft)
12149         || (oleft->op_private & OPpLVAL_INTRO)
12150     )
12151         return;
12152
12153     /* Only one thing on the rhs */
12154     if (OpHAS_SIBLING(oright))
12155         return;
12156
12157     /* check the array is the same on both sides */
12158     if (oleft->op_type == OP_RV2AV) {
12159         if (oright->op_type != OP_RV2AV
12160             || !cUNOPx(oright)->op_first
12161             || cUNOPx(oright)->op_first->op_type != OP_GV
12162             || cUNOPx(oleft )->op_first->op_type != OP_GV
12163             || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
12164                cGVOPx_gv(cUNOPx(oright)->op_first)
12165         )
12166             return;
12167     }
12168     else if (oright->op_type != OP_PADAV
12169         || oright->op_targ != oleft->op_targ
12170     )
12171         return;
12172
12173     /* This actually is an inplace assignment */
12174
12175     modop->op_private |= OPpSORT_INPLACE;
12176
12177     /* transfer MODishness etc from LHS arg to RHS arg */
12178     oright->op_flags = oleft->op_flags;
12179
12180     /* remove the aassign op and the lhs */
12181     op_null(o);
12182     op_null(oleft_pushmark);
12183     if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
12184         op_null(cUNOPx(oleft)->op_first);
12185     op_null(oleft);
12186 }
12187
12188
12189
12190 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
12191  * that potentially represent a series of one or more aggregate derefs
12192  * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
12193  * the whole chain to a single OP_MULTIDEREF op (maybe with a few
12194  * additional ops left in too).
12195  *
12196  * The caller will have already verified that the first few ops in the
12197  * chain following 'start' indicate a multideref candidate, and will have
12198  * set 'orig_o' to the point further on in the chain where the first index
12199  * expression (if any) begins.  'orig_action' specifies what type of
12200  * beginning has already been determined by the ops between start..orig_o
12201  * (e.g.  $lex_ary[], $pkg_ary->{}, expr->[], etc).
12202  *
12203  * 'hints' contains any hints flags that need adding (currently just
12204  * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
12205  */
12206
12207 void
12208 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
12209 {
12210     dVAR;
12211     int pass;
12212     UNOP_AUX_item *arg_buf = NULL;
12213     bool reset_start_targ  = FALSE; /* start->op_targ needs zeroing */
12214     int index_skip         = -1;    /* don't output index arg on this action */
12215
12216     /* similar to regex compiling, do two passes; the first pass
12217      * determines whether the op chain is convertible and calculates the
12218      * buffer size; the second pass populates the buffer and makes any
12219      * changes necessary to ops (such as moving consts to the pad on
12220      * threaded builds)
12221      */
12222     for (pass = 0; pass < 2; pass++) {
12223         OP *o                = orig_o;
12224         UV action            = orig_action;
12225         OP *first_elem_op    = NULL;  /* first seen aelem/helem */
12226         OP *top_op           = NULL;  /* highest [ah]elem/exists/del/rv2[ah]v */
12227         int action_count     = 0;     /* number of actions seen so far */
12228         int action_ix        = 0;     /* action_count % (actions per IV) */
12229         bool next_is_hash    = FALSE; /* is the next lookup to be a hash? */
12230         bool is_last         = FALSE; /* no more derefs to follow */
12231         bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
12232         UNOP_AUX_item *arg     = arg_buf;
12233         UNOP_AUX_item *action_ptr = arg_buf;
12234
12235         if (pass)
12236             action_ptr->uv = 0;
12237         arg++;
12238
12239         switch (action) {
12240         case MDEREF_HV_gvsv_vivify_rv2hv_helem:
12241         case MDEREF_HV_gvhv_helem:
12242             next_is_hash = TRUE;
12243             /* FALLTHROUGH */
12244         case MDEREF_AV_gvsv_vivify_rv2av_aelem:
12245         case MDEREF_AV_gvav_aelem:
12246             if (pass) {
12247 #ifdef USE_ITHREADS
12248                 arg->pad_offset = cPADOPx(start)->op_padix;
12249                 /* stop it being swiped when nulled */
12250                 cPADOPx(start)->op_padix = 0;
12251 #else
12252                 arg->sv = cSVOPx(start)->op_sv;
12253                 cSVOPx(start)->op_sv = NULL;
12254 #endif
12255             }
12256             arg++;
12257             break;
12258
12259         case MDEREF_HV_padhv_helem:
12260         case MDEREF_HV_padsv_vivify_rv2hv_helem:
12261             next_is_hash = TRUE;
12262             /* FALLTHROUGH */
12263         case MDEREF_AV_padav_aelem:
12264         case MDEREF_AV_padsv_vivify_rv2av_aelem:
12265             if (pass) {
12266                 arg->pad_offset = start->op_targ;
12267                 /* we skip setting op_targ = 0 for now, since the intact
12268                  * OP_PADXV is needed by S_check_hash_fields_and_hekify */
12269                 reset_start_targ = TRUE;
12270             }
12271             arg++;
12272             break;
12273
12274         case MDEREF_HV_pop_rv2hv_helem:
12275             next_is_hash = TRUE;
12276             /* FALLTHROUGH */
12277         case MDEREF_AV_pop_rv2av_aelem:
12278             break;
12279
12280         default:
12281             NOT_REACHED;
12282             return;
12283         }
12284
12285         while (!is_last) {
12286             /* look for another (rv2av/hv; get index;
12287              * aelem/helem/exists/delele) sequence */
12288
12289             IV iv;
12290             OP *kid;
12291             bool is_deref;
12292             bool ok;
12293             UV index_type = MDEREF_INDEX_none;
12294
12295             if (action_count) {
12296                 /* if this is not the first lookup, consume the rv2av/hv  */
12297
12298                 /* for N levels of aggregate lookup, we normally expect
12299                  * that the first N-1 [ah]elem ops will be flagged as
12300                  * /DEREF (so they autovivifiy if necessary), and the last
12301                  * lookup op not to be.
12302                  * For other things (like @{$h{k1}{k2}}) extra scope or
12303                  * leave ops can appear, so abandon the effort in that
12304                  * case */
12305                 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
12306                     return;
12307
12308                 /* rv2av or rv2hv sKR/1 */
12309
12310                 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12311                                             |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12312                 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
12313                     return;
12314
12315                 /* at this point, we wouldn't expect any of these
12316                  * possible private flags:
12317                  * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
12318                  * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
12319                  */
12320                 ASSUME(!(o->op_private &
12321                     ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
12322
12323                 hints = (o->op_private & OPpHINT_STRICT_REFS);
12324
12325                 /* make sure the type of the previous /DEREF matches the
12326                  * type of the next lookup */
12327                 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
12328                 top_op = o;
12329
12330                 action = next_is_hash
12331                             ? MDEREF_HV_vivify_rv2hv_helem
12332                             : MDEREF_AV_vivify_rv2av_aelem;
12333                 o = o->op_next;
12334             }
12335
12336             /* if this is the second pass, and we're at the depth where
12337              * previously we encountered a non-simple index expression,
12338              * stop processing the index at this point */
12339             if (action_count != index_skip) {
12340
12341                 /* look for one or more simple ops that return an array
12342                  * index or hash key */
12343
12344                 switch (o->op_type) {
12345                 case OP_PADSV:
12346                     /* it may be a lexical var index */
12347                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
12348                                             |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12349                     ASSUME(!(o->op_private &
12350                             ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
12351
12352                     if (   OP_GIMME(o,0) == G_SCALAR
12353                         && !(o->op_flags & (OPf_REF|OPf_MOD))
12354                         && o->op_private == 0)
12355                     {
12356                         if (pass)
12357                             arg->pad_offset = o->op_targ;
12358                         arg++;
12359                         index_type = MDEREF_INDEX_padsv;
12360                         o = o->op_next;
12361                     }
12362                     break;
12363
12364                 case OP_CONST:
12365                     if (next_is_hash) {
12366                         /* it's a constant hash index */
12367                         if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
12368                             /* "use constant foo => FOO; $h{+foo}" for
12369                              * some weird FOO, can leave you with constants
12370                              * that aren't simple strings. It's not worth
12371                              * the extra hassle for those edge cases */
12372                             break;
12373
12374                         if (pass) {
12375                             UNOP *rop = NULL;
12376                             OP * helem_op = o->op_next;
12377
12378                             ASSUME(   helem_op->op_type == OP_HELEM
12379                                    || helem_op->op_type == OP_NULL);
12380                             if (helem_op->op_type == OP_HELEM) {
12381                                 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
12382                                 if (   helem_op->op_private & OPpLVAL_INTRO
12383                                     || rop->op_type != OP_RV2HV
12384                                 )
12385                                     rop = NULL;
12386                             }
12387                             S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo);
12388
12389 #ifdef USE_ITHREADS
12390                             /* Relocate sv to the pad for thread safety */
12391                             op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
12392                             arg->pad_offset = o->op_targ;
12393                             o->op_targ = 0;
12394 #else
12395                             arg->sv = cSVOPx_sv(o);
12396 #endif
12397                         }
12398                     }
12399                     else {
12400                         /* it's a constant array index */
12401                         SV *ix_sv = cSVOPo->op_sv;
12402                         if (pass && UNLIKELY(SvROK(ix_sv) && !SvGAMAGIC(ix_sv)
12403                                                 && ckWARN(WARN_MISC)))
12404                         Perl_warner(aTHX_ packWARN(WARN_MISC),
12405                                 "Use of reference \"%"SVf"\" as array index",
12406                                 SVfARG(ix_sv));
12407                         iv = SvIV(ix_sv);
12408
12409                         if (   action_count == 0
12410                             && iv >= -128
12411                             && iv <= 127
12412                             && (   action == MDEREF_AV_padav_aelem
12413                                 || action == MDEREF_AV_gvav_aelem)
12414                         )
12415                             maybe_aelemfast = TRUE;
12416
12417                         if (pass) {
12418                             arg->iv = iv;
12419                             SvREFCNT_dec_NN(cSVOPo->op_sv);
12420                         }
12421                     }
12422                     if (pass)
12423                         /* we've taken ownership of the SV */
12424                         cSVOPo->op_sv = NULL;
12425                     arg++;
12426                     index_type = MDEREF_INDEX_const;
12427                     o = o->op_next;
12428                     break;
12429
12430                 case OP_GV:
12431                     /* it may be a package var index */
12432
12433                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_SPECIAL)));
12434                     ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
12435                     if (  (o->op_flags &~ OPf_SPECIAL) != OPf_WANT_SCALAR
12436                         || o->op_private != 0
12437                     )
12438                         break;
12439
12440                     kid = o->op_next;
12441                     if (kid->op_type != OP_RV2SV)
12442                         break;
12443
12444                     ASSUME(!(kid->op_flags &
12445                             ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
12446                              |OPf_SPECIAL|OPf_PARENS)));
12447                     ASSUME(!(kid->op_private &
12448                                     ~(OPpARG1_MASK
12449                                      |OPpHINT_STRICT_REFS|OPpOUR_INTRO
12450                                      |OPpDEREF|OPpLVAL_INTRO)));
12451                     if(   (kid->op_flags &~ OPf_PARENS)
12452                             != (OPf_WANT_SCALAR|OPf_KIDS)
12453                        || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
12454                     )
12455                         break;
12456
12457                     if (pass) {
12458 #ifdef USE_ITHREADS
12459                         arg->pad_offset = cPADOPx(o)->op_padix;
12460                         /* stop it being swiped when nulled */
12461                         cPADOPx(o)->op_padix = 0;
12462 #else
12463                         arg->sv = cSVOPx(o)->op_sv;
12464                         cSVOPo->op_sv = NULL;
12465 #endif
12466                     }
12467                     arg++;
12468                     index_type = MDEREF_INDEX_gvsv;
12469                     o = kid->op_next;
12470                     break;
12471
12472                 } /* switch */
12473             } /* action_count != index_skip */
12474
12475             action |= index_type;
12476
12477
12478             /* at this point we have either:
12479              *   * detected what looks like a simple index expression,
12480              *     and expect the next op to be an [ah]elem, or
12481              *     an nulled  [ah]elem followed by a delete or exists;
12482              *  * found a more complex expression, so something other
12483              *    than the above follows.
12484              */
12485
12486             /* possibly an optimised away [ah]elem (where op_next is
12487              * exists or delete) */
12488             if (o->op_type == OP_NULL)
12489                 o = o->op_next;
12490
12491             /* at this point we're looking for an OP_AELEM, OP_HELEM,
12492              * OP_EXISTS or OP_DELETE */
12493
12494             /* if something like arybase (a.k.a $[ ) is in scope,
12495              * abandon optimisation attempt */
12496             if (  (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
12497                && PL_check[o->op_type] != Perl_ck_null)
12498                 return;
12499
12500             if (   o->op_type != OP_AELEM
12501                 || (o->op_private &
12502                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
12503                 )
12504                 maybe_aelemfast = FALSE;
12505
12506             /* look for aelem/helem/exists/delete. If it's not the last elem
12507              * lookup, it *must* have OPpDEREF_AV/HV, but not many other
12508              * flags; if it's the last, then it mustn't have
12509              * OPpDEREF_AV/HV, but may have lots of other flags, like
12510              * OPpLVAL_INTRO etc
12511              */
12512
12513             if (   index_type == MDEREF_INDEX_none
12514                 || (   o->op_type != OP_AELEM  && o->op_type != OP_HELEM
12515                     && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
12516             )
12517                 ok = FALSE;
12518             else {
12519                 /* we have aelem/helem/exists/delete with valid simple index */
12520
12521                 is_deref =    (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
12522                            && (   (o->op_private & OPpDEREF) == OPpDEREF_AV
12523                                || (o->op_private & OPpDEREF) == OPpDEREF_HV);
12524
12525                 if (is_deref) {
12526                     ASSUME(!(o->op_flags &
12527                                  ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
12528                     ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
12529
12530                     ok =    (o->op_flags &~ OPf_PARENS)
12531                                == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
12532                          && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
12533                 }
12534                 else if (o->op_type == OP_EXISTS) {
12535                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12536                                 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12537                     ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
12538                     ok =  !(o->op_private & ~OPpARG1_MASK);
12539                 }
12540                 else if (o->op_type == OP_DELETE) {
12541                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12542                                 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12543                     ASSUME(!(o->op_private &
12544                                     ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
12545                     /* don't handle slices or 'local delete'; the latter
12546                      * is fairly rare, and has a complex runtime */
12547                     ok =  !(o->op_private & ~OPpARG1_MASK);
12548                     if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
12549                         /* skip handling run-tome error */
12550                         ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
12551                 }
12552                 else {
12553                     ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
12554                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
12555                                             |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
12556                     ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
12557                                     |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
12558                     ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
12559                 }
12560             }
12561
12562             if (ok) {
12563                 if (!first_elem_op)
12564                     first_elem_op = o;
12565                 top_op = o;
12566                 if (is_deref) {
12567                     next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
12568                     o = o->op_next;
12569                 }
12570                 else {
12571                     is_last = TRUE;
12572                     action |= MDEREF_FLAG_last;
12573                 }
12574             }
12575             else {
12576                 /* at this point we have something that started
12577                  * promisingly enough (with rv2av or whatever), but failed
12578                  * to find a simple index followed by an
12579                  * aelem/helem/exists/delete. If this is the first action,
12580                  * give up; but if we've already seen at least one
12581                  * aelem/helem, then keep them and add a new action with
12582                  * MDEREF_INDEX_none, which causes it to do the vivify
12583                  * from the end of the previous lookup, and do the deref,
12584                  * but stop at that point. So $a[0][expr] will do one
12585                  * av_fetch, vivify and deref, then continue executing at
12586                  * expr */
12587                 if (!action_count)
12588                     return;
12589                 is_last = TRUE;
12590                 index_skip = action_count;
12591                 action |= MDEREF_FLAG_last;
12592             }
12593
12594             if (pass)
12595                 action_ptr->uv |= (action << (action_ix * MDEREF_SHIFT));
12596             action_ix++;
12597             action_count++;
12598             /* if there's no space for the next action, create a new slot
12599              * for it *before* we start adding args for that action */
12600             if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
12601                 action_ptr = arg;
12602                 if (pass)
12603                     arg->uv = 0;
12604                 arg++;
12605                 action_ix = 0;
12606             }
12607         } /* while !is_last */
12608
12609         /* success! */
12610
12611         if (pass) {
12612             OP *mderef;
12613             OP *p;
12614
12615             mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
12616             if (index_skip == -1) {
12617                 mderef->op_flags = o->op_flags
12618                         & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
12619                 if (o->op_type == OP_EXISTS)
12620                     mderef->op_private = OPpMULTIDEREF_EXISTS;
12621                 else if (o->op_type == OP_DELETE)
12622                     mderef->op_private = OPpMULTIDEREF_DELETE;
12623                 else
12624                     mderef->op_private = o->op_private
12625                         & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
12626             }
12627             /* accumulate strictness from every level (although I don't think
12628              * they can actually vary) */
12629             mderef->op_private |= hints;
12630
12631             /* integrate the new multideref op into the optree and the
12632              * op_next chain.
12633              *
12634              * In general an op like aelem or helem has two child
12635              * sub-trees: the aggregate expression (a_expr) and the
12636              * index expression (i_expr):
12637              *
12638              *     aelem
12639              *       |
12640              *     a_expr - i_expr
12641              *
12642              * The a_expr returns an AV or HV, while the i-expr returns an
12643              * index. In general a multideref replaces most or all of a
12644              * multi-level tree, e.g.
12645              *
12646              *     exists
12647              *       |
12648              *     ex-aelem
12649              *       |
12650              *     rv2av  - i_expr1
12651              *       |
12652              *     helem
12653              *       |
12654              *     rv2hv  - i_expr2
12655              *       |
12656              *     aelem
12657              *       |
12658              *     a_expr - i_expr3
12659              *
12660              * With multideref, all the i_exprs will be simple vars or
12661              * constants, except that i_expr1 may be arbitrary in the case
12662              * of MDEREF_INDEX_none.
12663              *
12664              * The bottom-most a_expr will be either:
12665              *   1) a simple var (so padXv or gv+rv2Xv);
12666              *   2) a simple scalar var dereferenced (e.g. $r->[0]):
12667              *      so a simple var with an extra rv2Xv;
12668              *   3) or an arbitrary expression.
12669              *
12670              * 'start', the first op in the execution chain, will point to
12671              *   1),2): the padXv or gv op;
12672              *   3):    the rv2Xv which forms the last op in the a_expr
12673              *          execution chain, and the top-most op in the a_expr
12674              *          subtree.
12675              *
12676              * For all cases, the 'start' node is no longer required,
12677              * but we can't free it since one or more external nodes
12678              * may point to it. E.g. consider
12679              *     $h{foo} = $a ? $b : $c
12680              * Here, both the op_next and op_other branches of the
12681              * cond_expr point to the gv[*h] of the hash expression, so
12682              * we can't free the 'start' op.
12683              *
12684              * For expr->[...], we need to save the subtree containing the
12685              * expression; for the other cases, we just need to save the
12686              * start node.
12687              * So in all cases, we null the start op and keep it around by
12688              * making it the child of the multideref op; for the expr->
12689              * case, the expr will be a subtree of the start node.
12690              *
12691              * So in the simple 1,2 case the  optree above changes to
12692              *
12693              *     ex-exists
12694              *       |
12695              *     multideref
12696              *       |
12697              *     ex-gv (or ex-padxv)
12698              *
12699              *  with the op_next chain being
12700              *
12701              *  -> ex-gv -> multideref -> op-following-ex-exists ->
12702              *
12703              *  In the 3 case, we have
12704              *
12705              *     ex-exists
12706              *       |
12707              *     multideref
12708              *       |
12709              *     ex-rv2xv
12710              *       |
12711              *    rest-of-a_expr
12712              *      subtree
12713              *
12714              *  and
12715              *
12716              *  -> rest-of-a_expr subtree ->
12717              *    ex-rv2xv -> multideref -> op-following-ex-exists ->
12718              *
12719              *
12720              * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
12721              * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
12722              * multideref attached as the child, e.g.
12723              *
12724              *     exists
12725              *       |
12726              *     ex-aelem
12727              *       |
12728              *     ex-rv2av  - i_expr1
12729              *       |
12730              *     multideref
12731              *       |
12732              *     ex-whatever
12733              *
12734              */
12735
12736             /* if we free this op, don't free the pad entry */
12737             if (reset_start_targ)
12738                 start->op_targ = 0;
12739
12740
12741             /* Cut the bit we need to save out of the tree and attach to
12742              * the multideref op, then free the rest of the tree */
12743
12744             /* find parent of node to be detached (for use by splice) */
12745             p = first_elem_op;
12746             if (   orig_action == MDEREF_AV_pop_rv2av_aelem
12747                 || orig_action == MDEREF_HV_pop_rv2hv_helem)
12748             {
12749                 /* there is an arbitrary expression preceding us, e.g.
12750                  * expr->[..]? so we need to save the 'expr' subtree */
12751                 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
12752                     p = cUNOPx(p)->op_first;
12753                 ASSUME(   start->op_type == OP_RV2AV
12754                        || start->op_type == OP_RV2HV);
12755             }
12756             else {
12757                 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
12758                  * above for exists/delete. */
12759                 while (   (p->op_flags & OPf_KIDS)
12760                        && cUNOPx(p)->op_first != start
12761                 )
12762                     p = cUNOPx(p)->op_first;
12763             }
12764             ASSUME(cUNOPx(p)->op_first == start);
12765
12766             /* detach from main tree, and re-attach under the multideref */
12767             op_sibling_splice(mderef, NULL, 0,
12768                     op_sibling_splice(p, NULL, 1, NULL));
12769             op_null(start);
12770
12771             start->op_next = mderef;
12772
12773             mderef->op_next = index_skip == -1 ? o->op_next : o;
12774
12775             /* excise and free the original tree, and replace with
12776              * the multideref op */
12777             op_free(op_sibling_splice(top_op, NULL, -1, mderef));
12778             op_null(top_op);
12779         }
12780         else {
12781             Size_t size = arg - arg_buf;
12782
12783             if (maybe_aelemfast && action_count == 1)
12784                 return;
12785
12786             arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
12787                                 sizeof(UNOP_AUX_item) * (size + 1));
12788             /* for dumping etc: store the length in a hidden first slot;
12789              * we set the op_aux pointer to the second slot */
12790             arg_buf->uv = size;
12791             arg_buf++;
12792         }
12793     } /* for (pass = ...) */
12794 }
12795
12796
12797
12798 /* mechanism for deferring recursion in rpeep() */
12799
12800 #define MAX_DEFERRED 4
12801
12802 #define DEFER(o) \
12803   STMT_START { \
12804     if (defer_ix == (MAX_DEFERRED-1)) { \
12805         OP **defer = defer_queue[defer_base]; \
12806         CALL_RPEEP(*defer); \
12807         S_prune_chain_head(defer); \
12808         defer_base = (defer_base + 1) % MAX_DEFERRED; \
12809         defer_ix--; \
12810     } \
12811     defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
12812   } STMT_END
12813
12814 #define IS_AND_OP(o)   (o->op_type == OP_AND)
12815 #define IS_OR_OP(o)    (o->op_type == OP_OR)
12816
12817
12818 /* A peephole optimizer.  We visit the ops in the order they're to execute.
12819  * See the comments at the top of this file for more details about when
12820  * peep() is called */
12821
12822 void
12823 Perl_rpeep(pTHX_ OP *o)
12824 {
12825     dVAR;
12826     OP* oldop = NULL;
12827     OP* oldoldop = NULL;
12828     OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
12829     int defer_base = 0;
12830     int defer_ix = -1;
12831     OP *fop;
12832     OP *sop;
12833
12834     if (!o || o->op_opt)
12835         return;
12836     ENTER;
12837     SAVEOP();
12838     SAVEVPTR(PL_curcop);
12839     for (;; o = o->op_next) {
12840         if (o && o->op_opt)
12841             o = NULL;
12842         if (!o) {
12843             while (defer_ix >= 0) {
12844                 OP **defer =
12845                         defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
12846                 CALL_RPEEP(*defer);
12847                 S_prune_chain_head(defer);
12848             }
12849             break;
12850         }
12851
12852       redo:
12853         /* By default, this op has now been optimised. A couple of cases below
12854            clear this again.  */
12855         o->op_opt = 1;
12856         PL_op = o;
12857
12858         /* look for a series of 1 or more aggregate derefs, e.g.
12859          *   $a[1]{foo}[$i]{$k}
12860          * and replace with a single OP_MULTIDEREF op.
12861          * Each index must be either a const, or a simple variable,
12862          *
12863          * First, look for likely combinations of starting ops,
12864          * corresponding to (global and lexical variants of)
12865          *     $a[...]   $h{...}
12866          *     $r->[...] $r->{...}
12867          *     (preceding expression)->[...]
12868          *     (preceding expression)->{...}
12869          * and if so, call maybe_multideref() to do a full inspection
12870          * of the op chain and if appropriate, replace with an
12871          * OP_MULTIDEREF
12872          */
12873         {
12874             UV action;
12875             OP *o2 = o;
12876             U8 hints = 0;
12877
12878             switch (o2->op_type) {
12879             case OP_GV:
12880                 /* $pkg[..]   :   gv[*pkg]
12881                  * $pkg->[...]:   gv[*pkg]; rv2sv sKM/DREFAV */
12882
12883                 /* Fail if there are new op flag combinations that we're
12884                  * not aware of, rather than:
12885                  *  * silently failing to optimise, or
12886                  *  * silently optimising the flag away.
12887                  * If this ASSUME starts failing, examine what new flag
12888                  * has been added to the op, and decide whether the
12889                  * optimisation should still occur with that flag, then
12890                  * update the code accordingly. This applies to all the
12891                  * other ASSUMEs in the block of code too.
12892                  */
12893                 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_SPECIAL)));
12894                 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
12895
12896                 o2 = o2->op_next;
12897
12898                 if (o2->op_type == OP_RV2AV) {
12899                     action = MDEREF_AV_gvav_aelem;
12900                     goto do_deref;
12901                 }
12902
12903                 if (o2->op_type == OP_RV2HV) {
12904                     action = MDEREF_HV_gvhv_helem;
12905                     goto do_deref;
12906                 }
12907
12908                 if (o2->op_type != OP_RV2SV)
12909                     break;
12910
12911                 /* at this point we've seen gv,rv2sv, so the only valid
12912                  * construct left is $pkg->[] or $pkg->{} */
12913
12914                 ASSUME(!(o2->op_flags & OPf_STACKED));
12915                 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
12916                             != (OPf_WANT_SCALAR|OPf_MOD))
12917                     break;
12918
12919                 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
12920                                     |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
12921                 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
12922                     break;
12923                 if (   (o2->op_private & OPpDEREF) != OPpDEREF_AV
12924                     && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
12925                     break;
12926
12927                 o2 = o2->op_next;
12928                 if (o2->op_type == OP_RV2AV) {
12929                     action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
12930                     goto do_deref;
12931                 }
12932                 if (o2->op_type == OP_RV2HV) {
12933                     action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
12934                     goto do_deref;
12935                 }
12936                 break;
12937
12938             case OP_PADSV:
12939                 /* $lex->[...]: padsv[$lex] sM/DREFAV */
12940
12941                 ASSUME(!(o2->op_flags &
12942                     ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
12943                 if ((o2->op_flags &
12944                         (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
12945                      != (OPf_WANT_SCALAR|OPf_MOD))
12946                     break;
12947
12948                 ASSUME(!(o2->op_private &
12949                                 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
12950                 /* skip if state or intro, or not a deref */
12951                 if (      o2->op_private != OPpDEREF_AV
12952                        && o2->op_private != OPpDEREF_HV)
12953                     break;
12954
12955                 o2 = o2->op_next;
12956                 if (o2->op_type == OP_RV2AV) {
12957                     action = MDEREF_AV_padsv_vivify_rv2av_aelem;
12958                     goto do_deref;
12959                 }
12960                 if (o2->op_type == OP_RV2HV) {
12961                     action = MDEREF_HV_padsv_vivify_rv2hv_helem;
12962                     goto do_deref;
12963                 }
12964                 break;
12965
12966             case OP_PADAV:
12967             case OP_PADHV:
12968                 /*    $lex[..]:  padav[@lex:1,2] sR *
12969                  * or $lex{..}:  padhv[%lex:1,2] sR */
12970                 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
12971                                             OPf_REF|OPf_SPECIAL)));
12972                 if ((o2->op_flags &
12973                         (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
12974                      != (OPf_WANT_SCALAR|OPf_REF))
12975                     break;
12976                 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
12977                     break;
12978                 /* OPf_PARENS isn't currently used in this case;
12979                  * if that changes, let us know! */
12980                 ASSUME(!(o2->op_flags & OPf_PARENS));
12981
12982                 /* at this point, we wouldn't expect any of the remaining
12983                  * possible private flags:
12984                  * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
12985                  * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
12986                  *
12987                  * OPpSLICEWARNING shouldn't affect runtime
12988                  */
12989                 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
12990
12991                 action = o2->op_type == OP_PADAV
12992                             ? MDEREF_AV_padav_aelem
12993                             : MDEREF_HV_padhv_helem;
12994                 o2 = o2->op_next;
12995                 S_maybe_multideref(aTHX_ o, o2, action, 0);
12996                 break;
12997
12998
12999             case OP_RV2AV:
13000             case OP_RV2HV:
13001                 action = o2->op_type == OP_RV2AV
13002                             ? MDEREF_AV_pop_rv2av_aelem
13003                             : MDEREF_HV_pop_rv2hv_helem;
13004                 /* FALLTHROUGH */
13005             do_deref:
13006                 /* (expr)->[...]:  rv2av sKR/1;
13007                  * (expr)->{...}:  rv2hv sKR/1; */
13008
13009                 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
13010
13011                 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
13012                                 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
13013                 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
13014                     break;
13015
13016                 /* at this point, we wouldn't expect any of these
13017                  * possible private flags:
13018                  * OPpMAYBE_LVSUB, OPpLVAL_INTRO
13019                  * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
13020                  */
13021                 ASSUME(!(o2->op_private &
13022                     ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
13023                      |OPpOUR_INTRO)));
13024                 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
13025
13026                 o2 = o2->op_next;
13027
13028                 S_maybe_multideref(aTHX_ o, o2, action, hints);
13029                 break;
13030
13031             default:
13032                 break;
13033             }
13034         }
13035
13036
13037         switch (o->op_type) {
13038         case OP_DBSTATE:
13039             PL_curcop = ((COP*)o);              /* for warnings */
13040             break;
13041         case OP_NEXTSTATE:
13042             PL_curcop = ((COP*)o);              /* for warnings */
13043
13044             /* Optimise a "return ..." at the end of a sub to just be "...".
13045              * This saves 2 ops. Before:
13046              * 1  <;> nextstate(main 1 -e:1) v ->2
13047              * 4  <@> return K ->5
13048              * 2    <0> pushmark s ->3
13049              * -    <1> ex-rv2sv sK/1 ->4
13050              * 3      <#> gvsv[*cat] s ->4
13051              *
13052              * After:
13053              * -  <@> return K ->-
13054              * -    <0> pushmark s ->2
13055              * -    <1> ex-rv2sv sK/1 ->-
13056              * 2      <$> gvsv(*cat) s ->3
13057              */
13058             {
13059                 OP *next = o->op_next;
13060                 OP *sibling = OpSIBLING(o);
13061                 if (   OP_TYPE_IS(next, OP_PUSHMARK)
13062                     && OP_TYPE_IS(sibling, OP_RETURN)
13063                     && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
13064                     && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
13065                        ||OP_TYPE_IS(sibling->op_next->op_next,
13066                                     OP_LEAVESUBLV))
13067                     && cUNOPx(sibling)->op_first == next
13068                     && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
13069                     && next->op_next
13070                 ) {
13071                     /* Look through the PUSHMARK's siblings for one that
13072                      * points to the RETURN */
13073                     OP *top = OpSIBLING(next);
13074                     while (top && top->op_next) {
13075                         if (top->op_next == sibling) {
13076                             top->op_next = sibling->op_next;
13077                             o->op_next = next->op_next;
13078                             break;
13079                         }
13080                         top = OpSIBLING(top);
13081                     }
13082                 }
13083             }
13084
13085             /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
13086              *
13087              * This latter form is then suitable for conversion into padrange
13088              * later on. Convert:
13089              *
13090              *   nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
13091              *
13092              * into:
13093              *
13094              *   nextstate1 ->     listop     -> nextstate3
13095              *                 /            \
13096              *         pushmark -> padop1 -> padop2
13097              */
13098             if (o->op_next && (
13099                     o->op_next->op_type == OP_PADSV
13100                  || o->op_next->op_type == OP_PADAV
13101                  || o->op_next->op_type == OP_PADHV
13102                 )
13103                 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
13104                 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
13105                 && o->op_next->op_next->op_next && (
13106                     o->op_next->op_next->op_next->op_type == OP_PADSV
13107                  || o->op_next->op_next->op_next->op_type == OP_PADAV
13108                  || o->op_next->op_next->op_next->op_type == OP_PADHV
13109                 )
13110                 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
13111                 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
13112                 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
13113                 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
13114             ) {
13115                 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
13116
13117                 pad1 =    o->op_next;
13118                 ns2  = pad1->op_next;
13119                 pad2 =  ns2->op_next;
13120                 ns3  = pad2->op_next;
13121
13122                 /* we assume here that the op_next chain is the same as
13123                  * the op_sibling chain */
13124                 assert(OpSIBLING(o)    == pad1);
13125                 assert(OpSIBLING(pad1) == ns2);
13126                 assert(OpSIBLING(ns2)  == pad2);
13127                 assert(OpSIBLING(pad2) == ns3);
13128
13129                 /* create new listop, with children consisting of:
13130                  * a new pushmark, pad1, pad2. */
13131                 OpSIBLING_set(pad2, NULL);
13132                 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
13133                 newop->op_flags |= OPf_PARENS;
13134                 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
13135                 newpm = cUNOPx(newop)->op_first; /* pushmark */
13136
13137                 /* Kill nextstate2 between padop1/padop2 */
13138                 op_free(ns2);
13139
13140                 o    ->op_next = newpm;
13141                 newpm->op_next = pad1;
13142                 pad1 ->op_next = pad2;
13143                 pad2 ->op_next = newop; /* listop */
13144                 newop->op_next = ns3;
13145
13146                 OpSIBLING_set(o, newop);
13147                 OpSIBLING_set(newop, ns3);
13148                 newop->op_lastsib = 0;
13149
13150                 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
13151
13152                 /* Ensure pushmark has this flag if padops do */
13153                 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
13154                     o->op_next->op_flags |= OPf_MOD;
13155                 }
13156
13157                 break;
13158             }
13159
13160             /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
13161                to carry two labels. For now, take the easier option, and skip
13162                this optimisation if the first NEXTSTATE has a label.  */
13163             if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
13164                 OP *nextop = o->op_next;
13165                 while (nextop && nextop->op_type == OP_NULL)
13166                     nextop = nextop->op_next;
13167
13168                 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
13169                     op_null(o);
13170                     if (oldop)
13171                         oldop->op_next = nextop;
13172                     /* Skip (old)oldop assignment since the current oldop's
13173                        op_next already points to the next op.  */
13174                     continue;
13175                 }
13176             }
13177             break;
13178
13179         case OP_CONCAT:
13180             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
13181                 if (o->op_next->op_private & OPpTARGET_MY) {
13182                     if (o->op_flags & OPf_STACKED) /* chained concats */
13183                         break; /* ignore_optimization */
13184                     else {
13185                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
13186                         o->op_targ = o->op_next->op_targ;
13187                         o->op_next->op_targ = 0;
13188                         o->op_private |= OPpTARGET_MY;
13189                     }
13190                 }
13191                 op_null(o->op_next);
13192             }
13193             break;
13194         case OP_STUB:
13195             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
13196                 break; /* Scalar stub must produce undef.  List stub is noop */
13197             }
13198             goto nothin;
13199         case OP_NULL:
13200             if (o->op_targ == OP_NEXTSTATE
13201                 || o->op_targ == OP_DBSTATE)
13202             {
13203                 PL_curcop = ((COP*)o);
13204             }
13205             /* XXX: We avoid setting op_seq here to prevent later calls
13206                to rpeep() from mistakenly concluding that optimisation
13207                has already occurred. This doesn't fix the real problem,
13208                though (See 20010220.007). AMS 20010719 */
13209             /* op_seq functionality is now replaced by op_opt */
13210             o->op_opt = 0;
13211             /* FALLTHROUGH */
13212         case OP_SCALAR:
13213         case OP_LINESEQ:
13214         case OP_SCOPE:
13215         nothin:
13216             if (oldop) {
13217                 oldop->op_next = o->op_next;
13218                 o->op_opt = 0;
13219                 continue;
13220             }
13221             break;
13222
13223         case OP_PUSHMARK:
13224
13225             /* Given
13226                  5 repeat/DOLIST
13227                  3   ex-list
13228                  1     pushmark
13229                  2     scalar or const
13230                  4   const[0]
13231                convert repeat into a stub with no kids.
13232              */
13233             if (o->op_next->op_type == OP_CONST
13234              || (  o->op_next->op_type == OP_PADSV
13235                 && !(o->op_next->op_private & OPpLVAL_INTRO))
13236              || (  o->op_next->op_type == OP_GV
13237                 && o->op_next->op_next->op_type == OP_RV2SV
13238                 && !(o->op_next->op_next->op_private
13239                         & (OPpLVAL_INTRO|OPpOUR_INTRO))))
13240             {
13241                 const OP *kid = o->op_next->op_next;
13242                 if (o->op_next->op_type == OP_GV)
13243                    kid = kid->op_next;
13244                 /* kid is now the ex-list.  */
13245                 if (kid->op_type == OP_NULL
13246                  && (kid = kid->op_next)->op_type == OP_CONST
13247                     /* kid is now the repeat count.  */
13248                  && kid->op_next->op_type == OP_REPEAT
13249                  && kid->op_next->op_private & OPpREPEAT_DOLIST
13250                  && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
13251                  && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0)
13252                 {
13253                     o = kid->op_next; /* repeat */
13254                     assert(oldop);
13255                     oldop->op_next = o;
13256                     op_free(cBINOPo->op_first);
13257                     op_free(cBINOPo->op_last );
13258                     o->op_flags &=~ OPf_KIDS;
13259                     /* stub is a baseop; repeat is a binop */
13260                     STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
13261                     CHANGE_TYPE(o, OP_STUB);
13262                     o->op_private = 0;
13263                     break;
13264                 }
13265             }
13266
13267             /* Convert a series of PAD ops for my vars plus support into a
13268              * single padrange op. Basically
13269              *
13270              *    pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
13271              *
13272              * becomes, depending on circumstances, one of
13273              *
13274              *    padrange  ----------------------------------> (list) -> rest
13275              *    padrange  --------------------------------------------> rest
13276              *
13277              * where all the pad indexes are sequential and of the same type
13278              * (INTRO or not).
13279              * We convert the pushmark into a padrange op, then skip
13280              * any other pad ops, and possibly some trailing ops.
13281              * Note that we don't null() the skipped ops, to make it
13282              * easier for Deparse to undo this optimisation (and none of
13283              * the skipped ops are holding any resourses). It also makes
13284              * it easier for find_uninit_var(), as it can just ignore
13285              * padrange, and examine the original pad ops.
13286              */
13287         {
13288             OP *p;
13289             OP *followop = NULL; /* the op that will follow the padrange op */
13290             U8 count = 0;
13291             U8 intro = 0;
13292             PADOFFSET base = 0; /* init only to stop compiler whining */
13293             bool gvoid = 0;     /* init only to stop compiler whining */
13294             bool defav = 0;  /* seen (...) = @_ */
13295             bool reuse = 0;  /* reuse an existing padrange op */
13296
13297             /* look for a pushmark -> gv[_] -> rv2av */
13298
13299             {
13300                 OP *rv2av, *q;
13301                 p = o->op_next;
13302                 if (   p->op_type == OP_GV
13303                     && cGVOPx_gv(p) == PL_defgv
13304                     && (rv2av = p->op_next)
13305                     && rv2av->op_type == OP_RV2AV
13306                     && !(rv2av->op_flags & OPf_REF)
13307                     && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
13308                     && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
13309                 ) {
13310                     q = rv2av->op_next;
13311                     if (q->op_type == OP_NULL)
13312                         q = q->op_next;
13313                     if (q->op_type == OP_PUSHMARK) {
13314                         defav = 1;
13315                         p = q;
13316                     }
13317                 }
13318             }
13319             if (!defav) {
13320                 p = o;
13321             }
13322
13323             /* scan for PAD ops */
13324
13325             for (p = p->op_next; p; p = p->op_next) {
13326                 if (p->op_type == OP_NULL)
13327                     continue;
13328
13329                 if ((     p->op_type != OP_PADSV
13330                        && p->op_type != OP_PADAV
13331                        && p->op_type != OP_PADHV
13332                     )
13333                       /* any private flag other than INTRO? e.g. STATE */
13334                    || (p->op_private & ~OPpLVAL_INTRO)
13335                 )
13336                     break;
13337
13338                 /* let $a[N] potentially be optimised into AELEMFAST_LEX
13339                  * instead */
13340                 if (   p->op_type == OP_PADAV
13341                     && p->op_next
13342                     && p->op_next->op_type == OP_CONST
13343                     && p->op_next->op_next
13344                     && p->op_next->op_next->op_type == OP_AELEM
13345                 )
13346                     break;
13347
13348                 /* for 1st padop, note what type it is and the range
13349                  * start; for the others, check that it's the same type
13350                  * and that the targs are contiguous */
13351                 if (count == 0) {
13352                     intro = (p->op_private & OPpLVAL_INTRO);
13353                     base = p->op_targ;
13354                     gvoid = OP_GIMME(p,0) == G_VOID;
13355                 }
13356                 else {
13357                     if ((p->op_private & OPpLVAL_INTRO) != intro)
13358                         break;
13359                     /* Note that you'd normally  expect targs to be
13360                      * contiguous in my($a,$b,$c), but that's not the case
13361                      * when external modules start doing things, e.g.
13362                      i* Function::Parameters */
13363                     if (p->op_targ != base + count)
13364                         break;
13365                     assert(p->op_targ == base + count);
13366                     /* Either all the padops or none of the padops should
13367                        be in void context.  Since we only do the optimisa-
13368                        tion for av/hv when the aggregate itself is pushed
13369                        on to the stack (one item), there is no need to dis-
13370                        tinguish list from scalar context.  */
13371                     if (gvoid != (OP_GIMME(p,0) == G_VOID))
13372                         break;
13373                 }
13374
13375                 /* for AV, HV, only when we're not flattening */
13376                 if (   p->op_type != OP_PADSV
13377                     && !gvoid
13378                     && !(p->op_flags & OPf_REF)
13379                 )
13380                     break;
13381
13382                 if (count >= OPpPADRANGE_COUNTMASK)
13383                     break;
13384
13385                 /* there's a biggest base we can fit into a
13386                  * SAVEt_CLEARPADRANGE in pp_padrange */
13387                 if (intro && base >
13388                         (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)))
13389                     break;
13390
13391                 /* Success! We've got another valid pad op to optimise away */
13392                 count++;
13393                 followop = p->op_next;
13394             }
13395
13396             if (count < 1 || (count == 1 && !defav))
13397                 break;
13398
13399             /* pp_padrange in specifically compile-time void context
13400              * skips pushing a mark and lexicals; in all other contexts
13401              * (including unknown till runtime) it pushes a mark and the
13402              * lexicals. We must be very careful then, that the ops we
13403              * optimise away would have exactly the same effect as the
13404              * padrange.
13405              * In particular in void context, we can only optimise to
13406              * a padrange if see see the complete sequence
13407              *     pushmark, pad*v, ...., list
13408              * which has the net effect of of leaving the markstack as it
13409              * was.  Not pushing on to the stack (whereas padsv does touch
13410              * the stack) makes no difference in void context.
13411              */
13412             assert(followop);
13413             if (gvoid) {
13414                 if (followop->op_type == OP_LIST
13415                         && OP_GIMME(followop,0) == G_VOID
13416                    )
13417                 {
13418                     followop = followop->op_next; /* skip OP_LIST */
13419
13420                     /* consolidate two successive my(...);'s */
13421
13422                     if (   oldoldop
13423                         && oldoldop->op_type == OP_PADRANGE
13424                         && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
13425                         && (oldoldop->op_private & OPpLVAL_INTRO) == intro
13426                         && !(oldoldop->op_flags & OPf_SPECIAL)
13427                     ) {
13428                         U8 old_count;
13429                         assert(oldoldop->op_next == oldop);
13430                         assert(   oldop->op_type == OP_NEXTSTATE
13431                                || oldop->op_type == OP_DBSTATE);
13432                         assert(oldop->op_next == o);
13433
13434                         old_count
13435                             = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
13436
13437                        /* Do not assume pad offsets for $c and $d are con-
13438                           tiguous in
13439                             my ($a,$b,$c);
13440                             my ($d,$e,$f);
13441                         */
13442                         if (  oldoldop->op_targ + old_count == base
13443                            && old_count < OPpPADRANGE_COUNTMASK - count) {
13444                             base = oldoldop->op_targ;
13445                             count += old_count;
13446                             reuse = 1;
13447                         }
13448                     }
13449
13450                     /* if there's any immediately following singleton
13451                      * my var's; then swallow them and the associated
13452                      * nextstates; i.e.
13453                      *    my ($a,$b); my $c; my $d;
13454                      * is treated as
13455                      *    my ($a,$b,$c,$d);
13456                      */
13457
13458                     while (    ((p = followop->op_next))
13459                             && (  p->op_type == OP_PADSV
13460                                || p->op_type == OP_PADAV
13461                                || p->op_type == OP_PADHV)
13462                             && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
13463                             && (p->op_private & OPpLVAL_INTRO) == intro
13464                             && !(p->op_private & ~OPpLVAL_INTRO)
13465                             && p->op_next
13466                             && (   p->op_next->op_type == OP_NEXTSTATE
13467                                 || p->op_next->op_type == OP_DBSTATE)
13468                             && count < OPpPADRANGE_COUNTMASK
13469                             && base + count == p->op_targ
13470                     ) {
13471                         count++;
13472                         followop = p->op_next;
13473                     }
13474                 }
13475                 else
13476                     break;
13477             }
13478
13479             if (reuse) {
13480                 assert(oldoldop->op_type == OP_PADRANGE);
13481                 oldoldop->op_next = followop;
13482                 oldoldop->op_private = (intro | count);
13483                 o = oldoldop;
13484                 oldop = NULL;
13485                 oldoldop = NULL;
13486             }
13487             else {
13488                 /* Convert the pushmark into a padrange.
13489                  * To make Deparse easier, we guarantee that a padrange was
13490                  * *always* formerly a pushmark */
13491                 assert(o->op_type == OP_PUSHMARK);
13492                 o->op_next = followop;
13493                 CHANGE_TYPE(o, OP_PADRANGE);
13494                 o->op_targ = base;
13495                 /* bit 7: INTRO; bit 6..0: count */
13496                 o->op_private = (intro | count);
13497                 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
13498                               | gvoid * OPf_WANT_VOID
13499                               | (defav ? OPf_SPECIAL : 0));
13500             }
13501             break;
13502         }
13503
13504         case OP_PADAV:
13505         case OP_PADSV:
13506         case OP_PADHV:
13507         /* Skip over state($x) in void context.  */
13508         if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
13509          && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
13510         {
13511             oldop->op_next = o->op_next;
13512             goto redo_nextstate;
13513         }
13514         if (o->op_type != OP_PADAV)
13515             break;
13516         /* FALLTHROUGH */
13517         case OP_GV:
13518             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
13519                 OP* const pop = (o->op_type == OP_PADAV) ?
13520                             o->op_next : o->op_next->op_next;
13521                 IV i;
13522                 if (pop && pop->op_type == OP_CONST &&
13523                     ((PL_op = pop->op_next)) &&
13524                     pop->op_next->op_type == OP_AELEM &&
13525                     !(pop->op_next->op_private &
13526                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
13527                     (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
13528                 {
13529                     GV *gv;
13530                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
13531                         no_bareword_allowed(pop);
13532                     if (o->op_type == OP_GV)
13533                         op_null(o->op_next);
13534                     op_null(pop->op_next);
13535                     op_null(pop);
13536                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
13537                     o->op_next = pop->op_next->op_next;
13538                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
13539                     o->op_private = (U8)i;
13540                     if (o->op_type == OP_GV) {
13541                         gv = cGVOPo_gv;
13542                         GvAVn(gv);
13543                         o->op_type = OP_AELEMFAST;
13544                     }
13545                     else
13546                         o->op_type = OP_AELEMFAST_LEX;
13547                 }
13548                 if (o->op_type != OP_GV)
13549                     break;
13550             }
13551
13552             /* Remove $foo from the op_next chain in void context.  */
13553             if (oldop
13554              && (  o->op_next->op_type == OP_RV2SV
13555                 || o->op_next->op_type == OP_RV2AV
13556                 || o->op_next->op_type == OP_RV2HV  )
13557              && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
13558              && !(o->op_next->op_private & OPpLVAL_INTRO))
13559             {
13560                 oldop->op_next = o->op_next->op_next;
13561                 /* Reprocess the previous op if it is a nextstate, to
13562                    allow double-nextstate optimisation.  */
13563               redo_nextstate:
13564                 if (oldop->op_type == OP_NEXTSTATE) {
13565                     oldop->op_opt = 0;
13566                     o = oldop;
13567                     oldop = oldoldop;
13568                     oldoldop = NULL;
13569                     goto redo;
13570                 }
13571                 o = oldop;
13572             }
13573             else if (o->op_next->op_type == OP_RV2SV) {
13574                 if (!(o->op_next->op_private & OPpDEREF)) {
13575                     op_null(o->op_next);
13576                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
13577                                                                | OPpOUR_INTRO);
13578                     o->op_next = o->op_next->op_next;
13579                     CHANGE_TYPE(o, OP_GVSV);
13580                 }
13581             }
13582             else if (o->op_next->op_type == OP_READLINE
13583                     && o->op_next->op_next->op_type == OP_CONCAT
13584                     && (o->op_next->op_next->op_flags & OPf_STACKED))
13585             {
13586                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
13587                 CHANGE_TYPE(o, OP_RCATLINE);
13588                 o->op_flags |= OPf_STACKED;
13589                 op_null(o->op_next->op_next);
13590                 op_null(o->op_next);
13591             }
13592
13593             break;
13594
13595 #define HV_OR_SCALARHV(op)                                   \
13596     (  (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \
13597        ? (op)                                                  \
13598        : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \
13599        && (  cUNOPx(op)->op_first->op_type == OP_PADHV          \
13600           || cUNOPx(op)->op_first->op_type == OP_RV2HV)          \
13601          ? cUNOPx(op)->op_first                                   \
13602          : NULL)
13603
13604         case OP_NOT:
13605             if ((fop = HV_OR_SCALARHV(cUNOP->op_first)))
13606                 fop->op_private |= OPpTRUEBOOL;
13607             break;
13608
13609         case OP_AND:
13610         case OP_OR:
13611         case OP_DOR:
13612             fop = cLOGOP->op_first;
13613             sop = OpSIBLING(fop);
13614             while (cLOGOP->op_other->op_type == OP_NULL)
13615                 cLOGOP->op_other = cLOGOP->op_other->op_next;
13616             while (o->op_next && (   o->op_type == o->op_next->op_type
13617                                   || o->op_next->op_type == OP_NULL))
13618                 o->op_next = o->op_next->op_next;
13619
13620             /* if we're an OR and our next is a AND in void context, we'll
13621                follow it's op_other on short circuit, same for reverse.
13622                We can't do this with OP_DOR since if it's true, its return
13623                value is the underlying value which must be evaluated
13624                by the next op */
13625             if (o->op_next &&
13626                 (
13627                     (IS_AND_OP(o) && IS_OR_OP(o->op_next))
13628                  || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
13629                 )
13630                 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
13631             ) {
13632                 o->op_next = ((LOGOP*)o->op_next)->op_other;
13633             }
13634             DEFER(cLOGOP->op_other);
13635
13636             o->op_opt = 1;
13637             fop = HV_OR_SCALARHV(fop);
13638             if (sop) sop = HV_OR_SCALARHV(sop);
13639             if (fop || sop
13640             ){
13641                 OP * nop = o;
13642                 OP * lop = o;
13643                 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
13644                     while (nop && nop->op_next) {
13645                         switch (nop->op_next->op_type) {
13646                             case OP_NOT:
13647                             case OP_AND:
13648                             case OP_OR:
13649                             case OP_DOR:
13650                                 lop = nop = nop->op_next;
13651                                 break;
13652                             case OP_NULL:
13653                                 nop = nop->op_next;
13654                                 break;
13655                             default:
13656                                 nop = NULL;
13657                                 break;
13658                         }
13659                     }
13660                 }
13661                 if (fop) {
13662                     if (  (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
13663                       || o->op_type == OP_AND  )
13664                         fop->op_private |= OPpTRUEBOOL;
13665                     else if (!(lop->op_flags & OPf_WANT))
13666                         fop->op_private |= OPpMAYBE_TRUEBOOL;
13667                 }
13668                 if (  (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
13669                    && sop)
13670                     sop->op_private |= OPpTRUEBOOL;
13671             }
13672
13673
13674             break;
13675
13676         case OP_COND_EXPR:
13677             if ((fop = HV_OR_SCALARHV(cLOGOP->op_first)))
13678                 fop->op_private |= OPpTRUEBOOL;
13679 #undef HV_OR_SCALARHV
13680             /* GERONIMO! */ /* FALLTHROUGH */
13681
13682         case OP_MAPWHILE:
13683         case OP_GREPWHILE:
13684         case OP_ANDASSIGN:
13685         case OP_ORASSIGN:
13686         case OP_DORASSIGN:
13687         case OP_RANGE:
13688         case OP_ONCE:
13689             while (cLOGOP->op_other->op_type == OP_NULL)
13690                 cLOGOP->op_other = cLOGOP->op_other->op_next;
13691             DEFER(cLOGOP->op_other);
13692             break;
13693
13694         case OP_ENTERLOOP:
13695         case OP_ENTERITER:
13696             while (cLOOP->op_redoop->op_type == OP_NULL)
13697                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
13698             while (cLOOP->op_nextop->op_type == OP_NULL)
13699                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
13700             while (cLOOP->op_lastop->op_type == OP_NULL)
13701                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
13702             /* a while(1) loop doesn't have an op_next that escapes the
13703              * loop, so we have to explicitly follow the op_lastop to
13704              * process the rest of the code */
13705             DEFER(cLOOP->op_lastop);
13706             break;
13707
13708         case OP_ENTERTRY:
13709             assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
13710             DEFER(cLOGOPo->op_other);
13711             break;
13712
13713         case OP_SUBST:
13714             assert(!(cPMOP->op_pmflags & PMf_ONCE));
13715             while (cPMOP->op_pmstashstartu.op_pmreplstart &&
13716                    cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
13717                 cPMOP->op_pmstashstartu.op_pmreplstart
13718                     = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
13719             DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
13720             break;
13721
13722         case OP_SORT: {
13723             OP *oright;
13724
13725             if (o->op_flags & OPf_SPECIAL) {
13726                 /* first arg is a code block */
13727                 OP * const nullop = OpSIBLING(cLISTOP->op_first);
13728                 OP * kid          = cUNOPx(nullop)->op_first;
13729
13730                 assert(nullop->op_type == OP_NULL);
13731                 assert(kid->op_type == OP_SCOPE
13732                  || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
13733                 /* since OP_SORT doesn't have a handy op_other-style
13734                  * field that can point directly to the start of the code
13735                  * block, store it in the otherwise-unused op_next field
13736                  * of the top-level OP_NULL. This will be quicker at
13737                  * run-time, and it will also allow us to remove leading
13738                  * OP_NULLs by just messing with op_nexts without
13739                  * altering the basic op_first/op_sibling layout. */
13740                 kid = kLISTOP->op_first;
13741                 assert(
13742                       (kid->op_type == OP_NULL
13743                       && (  kid->op_targ == OP_NEXTSTATE
13744                          || kid->op_targ == OP_DBSTATE  ))
13745                     || kid->op_type == OP_STUB
13746                     || kid->op_type == OP_ENTER);
13747                 nullop->op_next = kLISTOP->op_next;
13748                 DEFER(nullop->op_next);
13749             }
13750
13751             /* check that RHS of sort is a single plain array */
13752             oright = cUNOPo->op_first;
13753             if (!oright || oright->op_type != OP_PUSHMARK)
13754                 break;
13755
13756             if (o->op_private & OPpSORT_INPLACE)
13757                 break;
13758
13759             /* reverse sort ... can be optimised.  */
13760             if (!OpHAS_SIBLING(cUNOPo)) {
13761                 /* Nothing follows us on the list. */
13762                 OP * const reverse = o->op_next;
13763
13764                 if (reverse->op_type == OP_REVERSE &&
13765                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
13766                     OP * const pushmark = cUNOPx(reverse)->op_first;
13767                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
13768                         && (OpSIBLING(cUNOPx(pushmark)) == o)) {
13769                         /* reverse -> pushmark -> sort */
13770                         o->op_private |= OPpSORT_REVERSE;
13771                         op_null(reverse);
13772                         pushmark->op_next = oright->op_next;
13773                         op_null(oright);
13774                     }
13775                 }
13776             }
13777
13778             break;
13779         }
13780
13781         case OP_REVERSE: {
13782             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
13783             OP *gvop = NULL;
13784             LISTOP *enter, *exlist;
13785
13786             if (o->op_private & OPpSORT_INPLACE)
13787                 break;
13788
13789             enter = (LISTOP *) o->op_next;
13790             if (!enter)
13791                 break;
13792             if (enter->op_type == OP_NULL) {
13793                 enter = (LISTOP *) enter->op_next;
13794                 if (!enter)
13795                     break;
13796             }
13797             /* for $a (...) will have OP_GV then OP_RV2GV here.
13798                for (...) just has an OP_GV.  */
13799             if (enter->op_type == OP_GV) {
13800                 gvop = (OP *) enter;
13801                 enter = (LISTOP *) enter->op_next;
13802                 if (!enter)
13803                     break;
13804                 if (enter->op_type == OP_RV2GV) {
13805                   enter = (LISTOP *) enter->op_next;
13806                   if (!enter)
13807                     break;
13808                 }
13809             }
13810
13811             if (enter->op_type != OP_ENTERITER)
13812                 break;
13813
13814             iter = enter->op_next;
13815             if (!iter || iter->op_type != OP_ITER)
13816                 break;
13817
13818             expushmark = enter->op_first;
13819             if (!expushmark || expushmark->op_type != OP_NULL
13820                 || expushmark->op_targ != OP_PUSHMARK)
13821                 break;
13822
13823             exlist = (LISTOP *) OpSIBLING(expushmark);
13824             if (!exlist || exlist->op_type != OP_NULL
13825                 || exlist->op_targ != OP_LIST)
13826                 break;
13827
13828             if (exlist->op_last != o) {
13829                 /* Mmm. Was expecting to point back to this op.  */
13830                 break;
13831             }
13832             theirmark = exlist->op_first;
13833             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
13834                 break;
13835
13836             if (OpSIBLING(theirmark) != o) {
13837                 /* There's something between the mark and the reverse, eg
13838                    for (1, reverse (...))
13839                    so no go.  */
13840                 break;
13841             }
13842
13843             ourmark = ((LISTOP *)o)->op_first;
13844             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
13845                 break;
13846
13847             ourlast = ((LISTOP *)o)->op_last;
13848             if (!ourlast || ourlast->op_next != o)
13849                 break;
13850
13851             rv2av = OpSIBLING(ourmark);
13852             if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
13853                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
13854                 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
13855                 /* We're just reversing a single array.  */
13856                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
13857                 enter->op_flags |= OPf_STACKED;
13858             }
13859
13860             /* We don't have control over who points to theirmark, so sacrifice
13861                ours.  */
13862             theirmark->op_next = ourmark->op_next;
13863             theirmark->op_flags = ourmark->op_flags;
13864             ourlast->op_next = gvop ? gvop : (OP *) enter;
13865             op_null(ourmark);
13866             op_null(o);
13867             enter->op_private |= OPpITER_REVERSED;
13868             iter->op_private |= OPpITER_REVERSED;
13869
13870             break;
13871         }
13872
13873         case OP_QR:
13874         case OP_MATCH:
13875             if (!(cPMOP->op_pmflags & PMf_ONCE)) {
13876                 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
13877             }
13878             break;
13879
13880         case OP_RUNCV:
13881             if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
13882              && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
13883             {
13884                 SV *sv;
13885                 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
13886                 else {
13887                     sv = newRV((SV *)PL_compcv);
13888                     sv_rvweaken(sv);
13889                     SvREADONLY_on(sv);
13890                 }
13891                 CHANGE_TYPE(o, OP_CONST);
13892                 o->op_flags |= OPf_SPECIAL;
13893                 cSVOPo->op_sv = sv;
13894             }
13895             break;
13896
13897         case OP_SASSIGN:
13898             if (OP_GIMME(o,0) == G_VOID
13899              || (  o->op_next->op_type == OP_LINESEQ
13900                 && (  o->op_next->op_next->op_type == OP_LEAVESUB
13901                    || (  o->op_next->op_next->op_type == OP_RETURN
13902                       && !CvLVALUE(PL_compcv)))))
13903             {
13904                 OP *right = cBINOP->op_first;
13905                 if (right) {
13906                     /*   sassign
13907                     *      RIGHT
13908                     *      substr
13909                     *         pushmark
13910                     *         arg1
13911                     *         arg2
13912                     *         ...
13913                     * becomes
13914                     *
13915                     *  ex-sassign
13916                     *     substr
13917                     *        pushmark
13918                     *        RIGHT
13919                     *        arg1
13920                     *        arg2
13921                     *        ...
13922                     */
13923                     OP *left = OpSIBLING(right);
13924                     if (left->op_type == OP_SUBSTR
13925                          && (left->op_private & 7) < 4) {
13926                         op_null(o);
13927                         /* cut out right */
13928                         op_sibling_splice(o, NULL, 1, NULL);
13929                         /* and insert it as second child of OP_SUBSTR */
13930                         op_sibling_splice(left, cBINOPx(left)->op_first, 0,
13931                                     right);
13932                         left->op_private |= OPpSUBSTR_REPL_FIRST;
13933                         left->op_flags =
13934                             (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
13935                     }
13936                 }
13937             }
13938             break;
13939
13940         case OP_AASSIGN:
13941             /* We do the common-vars check here, rather than in newASSIGNOP
13942                (as formerly), so that all lexical vars that get aliased are
13943                marked as such before we do the check.  */
13944             /* There can’t be common vars if the lhs is a stub.  */
13945             if (OpSIBLING(cLISTOPx(cBINOPo->op_last)->op_first)
13946                     == cLISTOPx(cBINOPo->op_last)->op_last
13947              && cLISTOPx(cBINOPo->op_last)->op_last->op_type == OP_STUB)
13948             {
13949                 o->op_private &=~ OPpASSIGN_COMMON;
13950                 break;
13951             }
13952             if (o->op_private & OPpASSIGN_COMMON) {
13953                  /* See the comment before S_aassign_common_vars concerning
13954                     PL_generation sorcery.  */
13955                 PL_generation++;
13956                 if (!aassign_common_vars(o))
13957                     o->op_private &=~ OPpASSIGN_COMMON;
13958             }
13959             else if (S_aassign_common_vars_aliases_only(aTHX_ o))
13960                 o->op_private |= OPpASSIGN_COMMON;
13961             break;
13962
13963         case OP_CUSTOM: {
13964             Perl_cpeep_t cpeep =
13965                 XopENTRYCUSTOM(o, xop_peep);
13966             if (cpeep)
13967                 cpeep(aTHX_ o, oldop);
13968             break;
13969         }
13970
13971         }
13972         /* did we just null the current op? If so, re-process it to handle
13973          * eliding "empty" ops from the chain */
13974         if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
13975             o->op_opt = 0;
13976             o = oldop;
13977         }
13978         else {
13979             oldoldop = oldop;
13980             oldop = o;
13981         }
13982     }
13983     LEAVE;
13984 }
13985
13986 void
13987 Perl_peep(pTHX_ OP *o)
13988 {
13989     CALL_RPEEP(o);
13990 }
13991
13992 /*
13993 =head1 Custom Operators
13994
13995 =for apidoc Ao||custom_op_xop
13996 Return the XOP structure for a given custom op.  This macro should be
13997 considered internal to OP_NAME and the other access macros: use them instead.
13998 This macro does call a function.  Prior
13999 to 5.19.6, this was implemented as a
14000 function.
14001
14002 =cut
14003 */
14004
14005 XOPRETANY
14006 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
14007 {
14008     SV *keysv;
14009     HE *he = NULL;
14010     XOP *xop;
14011
14012     static const XOP xop_null = { 0, 0, 0, 0, 0 };
14013
14014     PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
14015     assert(o->op_type == OP_CUSTOM);
14016
14017     /* This is wrong. It assumes a function pointer can be cast to IV,
14018      * which isn't guaranteed, but this is what the old custom OP code
14019      * did. In principle it should be safer to Copy the bytes of the
14020      * pointer into a PV: since the new interface is hidden behind
14021      * functions, this can be changed later if necessary.  */
14022     /* Change custom_op_xop if this ever happens */
14023     keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
14024
14025     if (PL_custom_ops)
14026         he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
14027
14028     /* assume noone will have just registered a desc */
14029     if (!he && PL_custom_op_names &&
14030         (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
14031     ) {
14032         const char *pv;
14033         STRLEN l;
14034
14035         /* XXX does all this need to be shared mem? */
14036         Newxz(xop, 1, XOP);
14037         pv = SvPV(HeVAL(he), l);
14038         XopENTRY_set(xop, xop_name, savepvn(pv, l));
14039         if (PL_custom_op_descs &&
14040             (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
14041         ) {
14042             pv = SvPV(HeVAL(he), l);
14043             XopENTRY_set(xop, xop_desc, savepvn(pv, l));
14044         }
14045         Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
14046     }
14047     else {
14048         if (!he)
14049             xop = (XOP *)&xop_null;
14050         else
14051             xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
14052     }
14053     {
14054         XOPRETANY any;
14055         if(field == XOPe_xop_ptr) {
14056             any.xop_ptr = xop;
14057         } else {
14058             const U32 flags = XopFLAGS(xop);
14059             if(flags & field) {
14060                 switch(field) {
14061                 case XOPe_xop_name:
14062                     any.xop_name = xop->xop_name;
14063                     break;
14064                 case XOPe_xop_desc:
14065                     any.xop_desc = xop->xop_desc;
14066                     break;
14067                 case XOPe_xop_class:
14068                     any.xop_class = xop->xop_class;
14069                     break;
14070                 case XOPe_xop_peep:
14071                     any.xop_peep = xop->xop_peep;
14072                     break;
14073                 default:
14074                     NOT_REACHED;
14075                     break;
14076                 }
14077             } else {
14078                 switch(field) {
14079                 case XOPe_xop_name:
14080                     any.xop_name = XOPd_xop_name;
14081                     break;
14082                 case XOPe_xop_desc:
14083                     any.xop_desc = XOPd_xop_desc;
14084                     break;
14085                 case XOPe_xop_class:
14086                     any.xop_class = XOPd_xop_class;
14087                     break;
14088                 case XOPe_xop_peep:
14089                     any.xop_peep = XOPd_xop_peep;
14090                     break;
14091                 default:
14092                     NOT_REACHED;
14093                     break;
14094                 }
14095             }
14096         }
14097         /* Some gcc releases emit a warning for this function:
14098          * op.c: In function 'Perl_custom_op_get_field':
14099          * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
14100          * Whether this is true, is currently unknown. */
14101         return any;
14102     }
14103 }
14104
14105 /*
14106 =for apidoc Ao||custom_op_register
14107 Register a custom op.  See L<perlguts/"Custom Operators">.
14108
14109 =cut
14110 */
14111
14112 void
14113 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
14114 {
14115     SV *keysv;
14116
14117     PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
14118
14119     /* see the comment in custom_op_xop */
14120     keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
14121
14122     if (!PL_custom_ops)
14123         PL_custom_ops = newHV();
14124
14125     if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
14126         Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
14127 }
14128
14129 /*
14130
14131 =for apidoc core_prototype
14132
14133 This function assigns the prototype of the named core function to C<sv>, or
14134 to a new mortal SV if C<sv> is NULL.  It returns the modified C<sv>, or
14135 NULL if the core function has no prototype.  C<code> is a code as returned
14136 by C<keyword()>.  It must not be equal to 0.
14137
14138 =cut
14139 */
14140
14141 SV *
14142 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
14143                           int * const opnum)
14144 {
14145     int i = 0, n = 0, seen_question = 0, defgv = 0;
14146     I32 oa;
14147 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
14148     char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
14149     bool nullret = FALSE;
14150
14151     PERL_ARGS_ASSERT_CORE_PROTOTYPE;
14152
14153     assert (code);
14154
14155     if (!sv) sv = sv_newmortal();
14156
14157 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
14158
14159     switch (code < 0 ? -code : code) {
14160     case KEY_and   : case KEY_chop: case KEY_chomp:
14161     case KEY_cmp   : case KEY_defined: case KEY_delete: case KEY_exec  :
14162     case KEY_exists: case KEY_eq     : case KEY_ge    : case KEY_goto  :
14163     case KEY_grep  : case KEY_gt     : case KEY_last  : case KEY_le    :
14164     case KEY_lt    : case KEY_map    : case KEY_ne    : case KEY_next  :
14165     case KEY_or    : case KEY_print  : case KEY_printf: case KEY_qr    :
14166     case KEY_redo  : case KEY_require: case KEY_return: case KEY_say   :
14167     case KEY_select: case KEY_sort   : case KEY_split : case KEY_system:
14168     case KEY_x     : case KEY_xor    :
14169         if (!opnum) return NULL; nullret = TRUE; goto findopnum;
14170     case KEY_glob:    retsetpvs("_;", OP_GLOB);
14171     case KEY_keys:    retsetpvs("+", OP_KEYS);
14172     case KEY_values:  retsetpvs("+", OP_VALUES);
14173     case KEY_each:    retsetpvs("+", OP_EACH);
14174     case KEY_push:    retsetpvs("+@", OP_PUSH);
14175     case KEY_unshift: retsetpvs("+@", OP_UNSHIFT);
14176     case KEY_pop:     retsetpvs(";+", OP_POP);
14177     case KEY_shift:   retsetpvs(";+", OP_SHIFT);
14178     case KEY_pos:     retsetpvs(";\\[$*]", OP_POS);
14179     case KEY_splice:
14180         retsetpvs("+;$$@", OP_SPLICE);
14181     case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
14182         retsetpvs("", 0);
14183     case KEY_evalbytes:
14184         name = "entereval"; break;
14185     case KEY_readpipe:
14186         name = "backtick";
14187     }
14188
14189 #undef retsetpvs
14190
14191   findopnum:
14192     while (i < MAXO) {  /* The slow way. */
14193         if (strEQ(name, PL_op_name[i])
14194             || strEQ(name, PL_op_desc[i]))
14195         {
14196             if (nullret) { assert(opnum); *opnum = i; return NULL; }
14197             goto found;
14198         }
14199         i++;
14200     }
14201     return NULL;
14202   found:
14203     defgv = PL_opargs[i] & OA_DEFGV;
14204     oa = PL_opargs[i] >> OASHIFT;
14205     while (oa) {
14206         if (oa & OA_OPTIONAL && !seen_question && (
14207               !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
14208         )) {
14209             seen_question = 1;
14210             str[n++] = ';';
14211         }
14212         if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
14213             && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
14214             /* But globs are already references (kinda) */
14215             && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
14216         ) {
14217             str[n++] = '\\';
14218         }
14219         if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
14220          && !scalar_mod_type(NULL, i)) {
14221             str[n++] = '[';
14222             str[n++] = '$';
14223             str[n++] = '@';
14224             str[n++] = '%';
14225             if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
14226             str[n++] = '*';
14227             str[n++] = ']';
14228         }
14229         else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
14230         if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
14231             str[n-1] = '_'; defgv = 0;
14232         }
14233         oa = oa >> 4;
14234     }
14235     if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
14236     str[n++] = '\0';
14237     sv_setpvn(sv, str, n - 1);
14238     if (opnum) *opnum = i;
14239     return sv;
14240 }
14241
14242 OP *
14243 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
14244                       const int opnum)
14245 {
14246     OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
14247     OP *o;
14248
14249     PERL_ARGS_ASSERT_CORESUB_OP;
14250
14251     switch(opnum) {
14252     case 0:
14253         return op_append_elem(OP_LINESEQ,
14254                        argop,
14255                        newSLICEOP(0,
14256                                   newSVOP(OP_CONST, 0, newSViv(-code % 3)),
14257                                   newOP(OP_CALLER,0)
14258                        )
14259                );
14260     case OP_SELECT: /* which represents OP_SSELECT as well */
14261         if (code)
14262             return newCONDOP(
14263                          0,
14264                          newBINOP(OP_GT, 0,
14265                                   newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
14266                                   newSVOP(OP_CONST, 0, newSVuv(1))
14267                                  ),
14268                          coresub_op(newSVuv((UV)OP_SSELECT), 0,
14269                                     OP_SSELECT),
14270                          coresub_op(coreargssv, 0, OP_SELECT)
14271                    );
14272         /* FALLTHROUGH */
14273     default:
14274         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
14275         case OA_BASEOP:
14276             return op_append_elem(
14277                         OP_LINESEQ, argop,
14278                         newOP(opnum,
14279                               opnum == OP_WANTARRAY || opnum == OP_RUNCV
14280                                 ? OPpOFFBYONE << 8 : 0)
14281                    );
14282         case OA_BASEOP_OR_UNOP:
14283             if (opnum == OP_ENTEREVAL) {
14284                 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
14285                 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
14286             }
14287             else o = newUNOP(opnum,0,argop);
14288             if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
14289             else {
14290           onearg:
14291               if (is_handle_constructor(o, 1))
14292                 argop->op_private |= OPpCOREARGS_DEREF1;
14293               if (scalar_mod_type(NULL, opnum))
14294                 argop->op_private |= OPpCOREARGS_SCALARMOD;
14295             }
14296             return o;
14297         default:
14298             o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
14299             if (is_handle_constructor(o, 2))
14300                 argop->op_private |= OPpCOREARGS_DEREF2;
14301             if (opnum == OP_SUBSTR) {
14302                 o->op_private |= OPpMAYBE_LVSUB;
14303                 return o;
14304             }
14305             else goto onearg;
14306         }
14307     }
14308 }
14309
14310 void
14311 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
14312                                SV * const *new_const_svp)
14313 {
14314     const char *hvname;
14315     bool is_const = !!CvCONST(old_cv);
14316     SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
14317
14318     PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
14319
14320     if (is_const && new_const_svp && old_const_sv == *new_const_svp)
14321         return;
14322         /* They are 2 constant subroutines generated from
14323            the same constant. This probably means that
14324            they are really the "same" proxy subroutine
14325            instantiated in 2 places. Most likely this is
14326            when a constant is exported twice.  Don't warn.
14327         */
14328     if (
14329         (ckWARN(WARN_REDEFINE)
14330          && !(
14331                 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
14332              && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
14333              && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
14334                  strEQ(hvname, "autouse"))
14335              )
14336         )
14337      || (is_const
14338          && ckWARN_d(WARN_REDEFINE)
14339          && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
14340         )
14341     )
14342         Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
14343                           is_const
14344                             ? "Constant subroutine %"SVf" redefined"
14345                             : "Subroutine %"SVf" redefined",
14346                           SVfARG(name));
14347 }
14348
14349 /*
14350 =head1 Hook manipulation
14351
14352 These functions provide convenient and thread-safe means of manipulating
14353 hook variables.
14354
14355 =cut
14356 */
14357
14358 /*
14359 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
14360
14361 Puts a C function into the chain of check functions for a specified op
14362 type.  This is the preferred way to manipulate the L</PL_check> array.
14363 I<opcode> specifies which type of op is to be affected.  I<new_checker>
14364 is a pointer to the C function that is to be added to that opcode's
14365 check chain, and I<old_checker_p> points to the storage location where a
14366 pointer to the next function in the chain will be stored.  The value of
14367 I<new_pointer> is written into the L</PL_check> array, while the value
14368 previously stored there is written to I<*old_checker_p>.
14369
14370 The function should be defined like this:
14371
14372     static OP *new_checker(pTHX_ OP *op) { ... }
14373
14374 It is intended to be called in this manner:
14375
14376     new_checker(aTHX_ op)
14377
14378 I<old_checker_p> should be defined like this:
14379
14380     static Perl_check_t old_checker_p;
14381
14382 L</PL_check> is global to an entire process, and a module wishing to
14383 hook op checking may find itself invoked more than once per process,
14384 typically in different threads.  To handle that situation, this function
14385 is idempotent.  The location I<*old_checker_p> must initially (once
14386 per process) contain a null pointer.  A C variable of static duration
14387 (declared at file scope, typically also marked C<static> to give
14388 it internal linkage) will be implicitly initialised appropriately,
14389 if it does not have an explicit initialiser.  This function will only
14390 actually modify the check chain if it finds I<*old_checker_p> to be null.
14391 This function is also thread safe on the small scale.  It uses appropriate
14392 locking to avoid race conditions in accessing L</PL_check>.
14393
14394 When this function is called, the function referenced by I<new_checker>
14395 must be ready to be called, except for I<*old_checker_p> being unfilled.
14396 In a threading situation, I<new_checker> may be called immediately,
14397 even before this function has returned.  I<*old_checker_p> will always
14398 be appropriately set before I<new_checker> is called.  If I<new_checker>
14399 decides not to do anything special with an op that it is given (which
14400 is the usual case for most uses of op check hooking), it must chain the
14401 check function referenced by I<*old_checker_p>.
14402
14403 If you want to influence compilation of calls to a specific subroutine,
14404 then use L</cv_set_call_checker> rather than hooking checking of all
14405 C<entersub> ops.
14406
14407 =cut
14408 */
14409
14410 void
14411 Perl_wrap_op_checker(pTHX_ Optype opcode,
14412     Perl_check_t new_checker, Perl_check_t *old_checker_p)
14413 {
14414     dVAR;
14415
14416     PERL_UNUSED_CONTEXT;
14417     PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
14418     if (*old_checker_p) return;
14419     OP_CHECK_MUTEX_LOCK;
14420     if (!*old_checker_p) {
14421         *old_checker_p = PL_check[opcode];
14422         PL_check[opcode] = new_checker;
14423     }
14424     OP_CHECK_MUTEX_UNLOCK;
14425 }
14426
14427 #include "XSUB.h"
14428
14429 /* Efficient sub that returns a constant scalar value. */
14430 static void
14431 const_sv_xsub(pTHX_ CV* cv)
14432 {
14433     dXSARGS;
14434     SV *const sv = MUTABLE_SV(XSANY.any_ptr);
14435     PERL_UNUSED_ARG(items);
14436     if (!sv) {
14437         XSRETURN(0);
14438     }
14439     EXTEND(sp, 1);
14440     ST(0) = sv;
14441     XSRETURN(1);
14442 }
14443
14444 static void
14445 const_av_xsub(pTHX_ CV* cv)
14446 {
14447     dXSARGS;
14448     AV * const av = MUTABLE_AV(XSANY.any_ptr);
14449     SP -= items;
14450     assert(av);
14451 #ifndef DEBUGGING
14452     if (!av) {
14453         XSRETURN(0);
14454     }
14455 #endif
14456     if (SvRMAGICAL(av))
14457         Perl_croak(aTHX_ "Magical list constants are not supported");
14458     if (GIMME_V != G_ARRAY) {
14459         EXTEND(SP, 1);
14460         ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
14461         XSRETURN(1);
14462     }
14463     EXTEND(SP, AvFILLp(av)+1);
14464     Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
14465     XSRETURN(AvFILLp(av)+1);
14466 }
14467
14468 /*
14469  * Local variables:
14470  * c-indentation-style: bsd
14471  * c-basic-offset: 4
14472  * indent-tabs-mode: nil
14473  * End:
14474  *
14475  * ex: set ts=8 sts=4 sw=4 et:
14476  */