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 OP *o, 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, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);
 550 }
 551
 552 /* remove flags var, its unused in all callers, move to to right end since gv
 553   and kid are always the same */
 554 STATIC void
 555 S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)
 556 {
 557     SV * const namesv = cv_name((CV *)gv, NULL, 0);
 558     PERL_ARGS_ASSERT_BAD_TYPE_GV;
 559
 560     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
 561                  (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
 562 }
 563
 564 STATIC void
 565 S_no_bareword_allowed(pTHX_ OP *o)
 566 {
 567     PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
 568
 569     qerror(Perl_mess(aTHX_
 570                      "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
 571                      SVfARG(cSVOPo_sv)));
 572     o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
 573 }
 574
 575 /* "register" allocation */
 576
 577 PADOFFSET
 578 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
 579 {
 580     PADOFFSET off;
 581     const bool is_our = (PL_parser->in_my == KEY_our);
 582
 583     PERL_ARGS_ASSERT_ALLOCMY;
 584
 585     if (flags & ~SVf_UTF8)
 586         Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
 587                    (UV)flags);
 588
 589     /* complain about "my $<special_var>" etc etc */
 590     if (len &&
 591         !(is_our ||
 592           isALPHA(name[1]) ||
 593           ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
 594           (name[1] == '_' && (*name == '$' || len > 2))))
 595     {
 596         if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
 597          && isASCII(name[1])
 598          && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
 599             yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
 600                               name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
 601                               PL_parser->in_my == KEY_state ? "state" : "my"));
 602         } else {
 603             yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
 604                               PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
 605         }
 606     }
 607     else if (len == 2 && name[1] == '_' && !is_our)
 608         /* diag_listed_as: Use of my $_ is experimental */
 609         Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__LEXICAL_TOPIC),
 610                               "Use of %s $_ is experimental",
 611                                PL_parser->in_my == KEY_state
 612                                  ? "state"
 613                                  : "my");
 614
 615     /* allocate a spare slot and store the name in that slot */
 616
 617     off = pad_add_name_pvn(name, len,
 618                        (is_our ? padadd_OUR :
 619                         PL_parser->in_my == KEY_state ? padadd_STATE : 0),
 620                     PL_parser->in_my_stash,
 621                     (is_our
 622                         /* $_ is always in main::, even with our */
 623                         ? (PL_curstash && !memEQs(name,len,"$_")
 624                             ? PL_curstash
 625                             : PL_defstash)
 626                         : NULL
 627                     )
 628     );
 629     /* anon sub prototypes contains state vars should always be cloned,
 630      * otherwise the state var would be shared between anon subs */
 631
 632     if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
 633         CvCLONE_on(PL_compcv);
 634
 635     return off;
 636 }
 637
 638 /*
 639 =head1 Optree Manipulation Functions
 640
 641 =for apidoc alloccopstash
 642
 643 Available only under threaded builds, this function allocates an entry in
 644 C<PL_stashpad> for the stash passed to it.
 645
 646 =cut
 647 */
 648
 649 #ifdef USE_ITHREADS
 650 PADOFFSET
 651 Perl_alloccopstash(pTHX_ HV *hv)
 652 {
 653     PADOFFSET off = 0, o = 1;
 654     bool found_slot = FALSE;
 655
 656     PERL_ARGS_ASSERT_ALLOCCOPSTASH;
 657
 658     if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
 659
 660     for (; o < PL_stashpadmax; ++o) {
 661         if (PL_stashpad[o] == hv) return PL_stashpadix = o;
 662         if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
 663             found_slot = TRUE, off = o;
 664     }
 665     if (!found_slot) {
 666         Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
 667         Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
 668         off = PL_stashpadmax;
 669         PL_stashpadmax += 10;
 670     }
 671
 672     PL_stashpad[PL_stashpadix = off] = hv;
 673     return off;
 674 }
 675 #endif
 676
 677 /* free the body of an op without examining its contents.
 678  * Always use this rather than FreeOp directly */
 679
 680 static void
 681 S_op_destroy(pTHX_ OP *o)
 682 {
 683     FreeOp(o);
 684 }
 685
 686 /* Destructor */
 687
 688 /*
 689 =for apidoc Am|void|op_free|OP *o
 690
 691 Free an op.  Only use this when an op is no longer linked to from any
 692 optree.
 693
 694 =cut
 695 */
 696
 697 void
 698 Perl_op_free(pTHX_ OP *o)
 699 {
 700     dVAR;
 701     OPCODE type;
 702     SSize_t defer_ix = -1;
 703     SSize_t defer_stack_alloc = 0;
 704     OP **defer_stack = NULL;
 705
 706     do {
 707
 708         /* Though ops may be freed twice, freeing the op after its slab is a
 709            big no-no. */
 710         assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
 711         /* During the forced freeing of ops after compilation failure, kidops
 712            may be freed before their parents. */
 713         if (!o || o->op_type == OP_FREED)
 714             continue;
 715
 716         type = o->op_type;
 717
 718         /* an op should only ever acquire op_private flags that we know about.
 719          * If this fails, you may need to fix something in regen/op_private */
 720         if (o->op_ppaddr == PL_ppaddr[o->op_type]) {
 721             assert(!(o->op_private & ~PL_op_private_valid[type]));
 722         }
 723
 724         if (o->op_private & OPpREFCOUNTED) {
 725             switch (type) {
 726             case OP_LEAVESUB:
 727             case OP_LEAVESUBLV:
 728             case OP_LEAVEEVAL:
 729             case OP_LEAVE:
 730             case OP_SCOPE:
 731             case OP_LEAVEWRITE:
 732                 {
 733                 PADOFFSET refcnt;
 734                 OP_REFCNT_LOCK;
 735                 refcnt = OpREFCNT_dec(o);
 736                 OP_REFCNT_UNLOCK;
 737                 if (refcnt) {
 738                     /* Need to find and remove any pattern match ops from the list
 739                        we maintain for reset().  */
 740                     find_and_forget_pmops(o);
 741                     continue;
 742                 }
 743                 }
 744                 break;
 745             default:
 746                 break;
 747             }
 748         }
 749
 750         /* Call the op_free hook if it has been set. Do it now so that it's called
 751          * at the right time for refcounted ops, but still before all of the kids
 752          * are freed. */
 753         CALL_OPFREEHOOK(o);
 754
 755         if (o->op_flags & OPf_KIDS) {
 756             OP *kid, *nextkid;
 757             for (kid = cUNOPo->op_first; kid; kid = nextkid) {
 758                 nextkid = OpSIBLING(kid); /* Get before next freeing kid */
 759                 if (!kid || kid->op_type == OP_FREED)
 760                     /* During the forced freeing of ops after
 761                        compilation failure, kidops may be freed before
 762                        their parents. */
 763                     continue;
 764                 if (!(kid->op_flags & OPf_KIDS))
 765                     /* If it has no kids, just free it now */
 766                     op_free(kid);
 767                 else
 768                     DEFER_OP(kid);
 769             }
 770         }
 771         if (type == OP_NULL)
 772             type = (OPCODE)o->op_targ;
 773
 774         if (o->op_slabbed)
 775             Slab_to_rw(OpSLAB(o));
 776
 777         /* COP* is not cleared by op_clear() so that we may track line
 778          * numbers etc even after null() */
 779         if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
 780             cop_free((COP*)o);
 781         }
 782
 783         op_clear(o);
 784         FreeOp(o);
 785 #ifdef DEBUG_LEAKING_SCALARS
 786         if (PL_op == o)
 787             PL_op = NULL;
 788 #endif
 789     } while ( (o = POP_DEFERRED_OP()) );
 790
 791     Safefree(defer_stack);
 792 }
 793
 794 /* S_op_clear_gv(): free a GV attached to an OP */
 795
 796 #ifdef USE_ITHREADS
 797 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
 798 #else
 799 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
 800 #endif
 801 {
 802
 803     GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
 804             || o->op_type == OP_MULTIDEREF)
 805 #ifdef USE_ITHREADS
 806                 && PL_curpad
 807                 ? ((GV*)PAD_SVl(*ixp)) : NULL;
 808 #else
 809                 ? (GV*)(*svp) : NULL;
 810 #endif
 811     /* It's possible during global destruction that the GV is freed
 812        before the optree. Whilst the SvREFCNT_inc is happy to bump from
 813        0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
 814        will trigger an assertion failure, because the entry to sv_clear
 815        checks that the scalar is not already freed.  A check of for
 816        !SvIS_FREED(gv) turns out to be invalid, because during global
 817        destruction the reference count can be forced down to zero
 818        (with SVf_BREAK set).  In which case raising to 1 and then
 819        dropping to 0 triggers cleanup before it should happen.  I
 820        *think* that this might actually be a general, systematic,
 821        weakness of the whole idea of SVf_BREAK, in that code *is*
 822        allowed to raise and lower references during global destruction,
 823        so any *valid* code that happens to do this during global
 824        destruction might well trigger premature cleanup.  */
 825     bool still_valid = gv && SvREFCNT(gv);
 826
 827     if (still_valid)
 828         SvREFCNT_inc_simple_void(gv);
 829 #ifdef USE_ITHREADS
 830     if (*ixp > 0) {
 831         pad_swipe(*ixp, TRUE);
 832         *ixp = 0;
 833     }
 834 #else
 835     SvREFCNT_dec(*svp);
 836     *svp = NULL;
 837 #endif
 838     if (still_valid) {
 839         int try_downgrade = SvREFCNT(gv) == 2;
 840         SvREFCNT_dec_NN(gv);
 841         if (try_downgrade)
 842             gv_try_downgrade(gv);
 843     }
 844 }
 845
 846
 847 void
 848 Perl_op_clear(pTHX_ OP *o)
 849 {
 850
 851     dVAR;
 852
 853     PERL_ARGS_ASSERT_OP_CLEAR;
 854
 855     switch (o->op_type) {
 856     case OP_NULL:       /* Was holding old type, if any. */
 857         /* FALLTHROUGH */
 858     case OP_ENTERTRY:
 859     case OP_ENTEREVAL:  /* Was holding hints. */
 860         o->op_targ = 0;
 861         break;
 862     default:
 863         if (!(o->op_flags & OPf_REF)
 864             || (PL_check[o->op_type] != Perl_ck_ftst))
 865             break;
 866         /* FALLTHROUGH */
 867     case OP_GVSV:
 868     case OP_GV:
 869     case OP_AELEMFAST:
 870 #ifdef USE_ITHREADS
 871             S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
 872 #else
 873             S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
 874 #endif
 875         break;
 876     case OP_METHOD_REDIR:
 877     case OP_METHOD_REDIR_SUPER:
 878 #ifdef USE_ITHREADS
 879         if (cMETHOPx(o)->op_rclass_targ) {
 880             pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
 881             cMETHOPx(o)->op_rclass_targ = 0;
 882         }
 883 #else
 884         SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
 885         cMETHOPx(o)->op_rclass_sv = NULL;
 886 #endif
 887     case OP_METHOD_NAMED:
 888     case OP_METHOD_SUPER:
 889         SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
 890         cMETHOPx(o)->op_u.op_meth_sv = NULL;
 891 #ifdef USE_ITHREADS
 892         if (o->op_targ) {
 893             pad_swipe(o->op_targ, 1);
 894             o->op_targ = 0;
 895         }
 896 #endif
 897         break;
 898     case OP_CONST:
 899     case OP_HINTSEVAL:
 900         SvREFCNT_dec(cSVOPo->op_sv);
 901         cSVOPo->op_sv = NULL;
 902 #ifdef USE_ITHREADS
 903         /** Bug #15654
 904           Even if op_clear does a pad_free for the target of the op,
 905           pad_free doesn't actually remove the sv that exists in the pad;
 906           instead it lives on. This results in that it could be reused as
 907           a target later on when the pad was reallocated.
 908         **/
 909         if(o->op_targ) {
 910           pad_swipe(o->op_targ,1);
 911           o->op_targ = 0;
 912         }
 913 #endif
 914         break;
 915     case OP_DUMP:
 916     case OP_GOTO:
 917     case OP_NEXT:
 918     case OP_LAST:
 919     case OP_REDO:
 920         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
 921             break;
 922         /* FALLTHROUGH */
 923     case OP_TRANS:
 924     case OP_TRANSR:
 925         if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
 926             assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
 927 #ifdef USE_ITHREADS
 928             if (cPADOPo->op_padix > 0) {
 929                 pad_swipe(cPADOPo->op_padix, TRUE);
 930                 cPADOPo->op_padix = 0;
 931             }
 932 #else
 933             SvREFCNT_dec(cSVOPo->op_sv);
 934             cSVOPo->op_sv = NULL;
 935 #endif
 936         }
 937         else {
 938             PerlMemShared_free(cPVOPo->op_pv);
 939             cPVOPo->op_pv = NULL;
 940         }
 941         break;
 942     case OP_SUBST:
 943         op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
 944         goto clear_pmop;
 945     case OP_PUSHRE:
 946 #ifdef USE_ITHREADS
 947         if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
 948             pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
 949         }
 950 #else
 951         SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
 952 #endif
 953         /* FALLTHROUGH */
 954     case OP_MATCH:
 955     case OP_QR:
 956     clear_pmop:
 957         if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
 958             op_free(cPMOPo->op_code_list);
 959         cPMOPo->op_code_list = NULL;
 960         forget_pmop(cPMOPo);
 961         cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
 962         /* we use the same protection as the "SAFE" version of the PM_ macros
 963          * here since sv_clean_all might release some PMOPs
 964          * after PL_regex_padav has been cleared
 965          * and the clearing of PL_regex_padav needs to
 966          * happen before sv_clean_all
 967          */
 968 #ifdef USE_ITHREADS
 969         if(PL_regex_pad) {        /* We could be in destruction */
 970             const IV offset = (cPMOPo)->op_pmoffset;
 971             ReREFCNT_dec(PM_GETRE(cPMOPo));
 972             PL_regex_pad[offset] = &PL_sv_undef;
 973             sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
 974                            sizeof(offset));
 975         }
 976 #else
 977         ReREFCNT_dec(PM_GETRE(cPMOPo));
 978         PM_SETRE(cPMOPo, NULL);
 979 #endif
 980
 981         break;
 982
 983     case OP_MULTIDEREF:
 984         {
 985             UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
 986             UV actions = items->uv;
 987             bool last = 0;
 988             bool is_hash = FALSE;
 989
 990             while (!last) {
 991                 switch (actions & MDEREF_ACTION_MASK) {
 992
 993                 case MDEREF_reload:
 994                     actions = (++items)->uv;
 995                     continue;
 996
 997                 case MDEREF_HV_padhv_helem:
 998                     is_hash = TRUE;
 999                 case MDEREF_AV_padav_aelem:
1000                     pad_free((++items)->pad_offset);
1001                     goto do_elem;
1002
1003                 case MDEREF_HV_gvhv_helem:
1004                     is_hash = TRUE;
1005                 case MDEREF_AV_gvav_aelem:
1006 #ifdef USE_ITHREADS
1007                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1008 #else
1009                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1010 #endif
1011                     goto do_elem;
1012
1013                 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1014                     is_hash = TRUE;
1015                 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1016 #ifdef USE_ITHREADS
1017                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1018 #else
1019                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1020 #endif
1021                     goto do_vivify_rv2xv_elem;
1022
1023                 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1024                     is_hash = TRUE;
1025                 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1026                     pad_free((++items)->pad_offset);
1027                     goto do_vivify_rv2xv_elem;
1028
1029                 case MDEREF_HV_pop_rv2hv_helem:
1030                 case MDEREF_HV_vivify_rv2hv_helem:
1031                     is_hash = TRUE;
1032                 do_vivify_rv2xv_elem:
1033                 case MDEREF_AV_pop_rv2av_aelem:
1034                 case MDEREF_AV_vivify_rv2av_aelem:
1035                 do_elem:
1036                     switch (actions & MDEREF_INDEX_MASK) {
1037                     case MDEREF_INDEX_none:
1038                         last = 1;
1039                         break;
1040                     case MDEREF_INDEX_const:
1041                         if (is_hash) {
1042 #ifdef USE_ITHREADS
1043                             /* see RT #15654 */
1044                             pad_swipe((++items)->pad_offset, 1);
1045 #else
1046                             SvREFCNT_dec((++items)->sv);
1047 #endif
1048                         }
1049                         else
1050                             items++;
1051                         break;
1052                     case MDEREF_INDEX_padsv:
1053                         pad_free((++items)->pad_offset);
1054                         break;
1055                     case MDEREF_INDEX_gvsv:
1056 #ifdef USE_ITHREADS
1057                         S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1058 #else
1059                         S_op_clear_gv(aTHX_ o, &((++items)->sv));
1060 #endif
1061                         break;
1062                     }
1063
1064                     if (actions & MDEREF_FLAG_last)
1065                         last = 1;
1066                     is_hash = FALSE;
1067
1068                     break;
1069
1070                 default:
1071                     assert(0);
1072                     last = 1;
1073                     break;
1074
1075                 } /* switch */
1076
1077                 actions >>= MDEREF_SHIFT;
1078             } /* while */
1079
1080             /* start of malloc is at op_aux[-1], where the length is
1081              * stored */
1082             PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1083         }
1084         break;
1085     }
1086
1087     if (o->op_targ > 0) {
1088         pad_free(o->op_targ);
1089         o->op_targ = 0;
1090     }
1091 }
1092
1093 STATIC void
1094 S_cop_free(pTHX_ COP* cop)
1095 {
1096     PERL_ARGS_ASSERT_COP_FREE;
1097
1098     CopFILE_free(cop);
1099     if (! specialWARN(cop->cop_warnings))
1100         PerlMemShared_free(cop->cop_warnings);
1101     cophh_free(CopHINTHASH_get(cop));
1102     if (PL_curcop == cop)
1103        PL_curcop = NULL;
1104 }
1105
1106 STATIC void
1107 S_forget_pmop(pTHX_ PMOP *const o
1108               )
1109 {
1110     HV * const pmstash = PmopSTASH(o);
1111
1112     PERL_ARGS_ASSERT_FORGET_PMOP;
1113
1114     if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1115         MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1116         if (mg) {
1117             PMOP **const array = (PMOP**) mg->mg_ptr;
1118             U32 count = mg->mg_len / sizeof(PMOP**);
1119             U32 i = count;
1120
1121             while (i--) {
1122                 if (array[i] == o) {
1123                     /* Found it. Move the entry at the end to overwrite it.  */
1124                     array[i] = array[--count];
1125                     mg->mg_len = count * sizeof(PMOP**);
1126                     /* Could realloc smaller at this point always, but probably
1127                        not worth it. Probably worth free()ing if we're the
1128                        last.  */
1129                     if(!count) {
1130                         Safefree(mg->mg_ptr);
1131                         mg->mg_ptr = NULL;
1132                     }
1133                     break;
1134                 }
1135             }
1136         }
1137     }
1138     if (PL_curpm == o)
1139         PL_curpm = NULL;
1140 }
1141
1142 STATIC void
1143 S_find_and_forget_pmops(pTHX_ OP *o)
1144 {
1145     PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1146
1147     if (o->op_flags & OPf_KIDS) {
1148         OP *kid = cUNOPo->op_first;
1149         while (kid) {
1150             switch (kid->op_type) {
1151             case OP_SUBST:
1152             case OP_PUSHRE:
1153             case OP_MATCH:
1154             case OP_QR:
1155                 forget_pmop((PMOP*)kid);
1156             }
1157             find_and_forget_pmops(kid);
1158             kid = OpSIBLING(kid);
1159         }
1160     }
1161 }
1162
1163 /*
1164 =for apidoc Am|void|op_null|OP *o
1165
1166 Neutralizes an op when it is no longer needed, but is still linked to from
1167 other ops.
1168
1169 =cut
1170 */
1171
1172 void
1173 Perl_op_null(pTHX_ OP *o)
1174 {
1175     dVAR;
1176
1177     PERL_ARGS_ASSERT_OP_NULL;
1178
1179     if (o->op_type == OP_NULL)
1180         return;
1181     op_clear(o);
1182     o->op_targ = o->op_type;
1183     CHANGE_TYPE(o, OP_NULL);
1184 }
1185
1186 void
1187 Perl_op_refcnt_lock(pTHX)
1188 {
1189 #ifdef USE_ITHREADS
1190     dVAR;
1191 #endif
1192     PERL_UNUSED_CONTEXT;
1193     OP_REFCNT_LOCK;
1194 }
1195
1196 void
1197 Perl_op_refcnt_unlock(pTHX)
1198 {
1199 #ifdef USE_ITHREADS
1200     dVAR;
1201 #endif
1202     PERL_UNUSED_CONTEXT;
1203     OP_REFCNT_UNLOCK;
1204 }
1205
1206
1207 /*
1208 =for apidoc op_sibling_splice
1209
1210 A general function for editing the structure of an existing chain of
1211 op_sibling nodes.  By analogy with the perl-level splice() function, allows
1212 you to delete zero or more sequential nodes, replacing them with zero or
1213 more different nodes.  Performs the necessary op_first/op_last
1214 housekeeping on the parent node and op_sibling manipulation on the
1215 children.  The last deleted node will be marked as as the last node by
1216 updating the op_sibling or op_lastsib field as appropriate.
1217
1218 Note that op_next is not manipulated, and nodes are not freed; that is the
1219 responsibility of the caller.  It also won't create a new list op for an
1220 empty list etc; use higher-level functions like op_append_elem() for that.
1221
1222 parent is the parent node of the sibling chain.
1223
1224 start is the node preceding the first node to be spliced.  Node(s)
1225 following it will be deleted, and ops will be inserted after it.  If it is
1226 NULL, the first node onwards is deleted, and nodes are inserted at the
1227 beginning.
1228
1229 del_count is the number of nodes to delete.  If zero, no nodes are deleted.
1230 If -1 or greater than or equal to the number of remaining kids, all
1231 remaining kids are deleted.
1232
1233 insert is the first of a chain of nodes to be inserted in place of the nodes.
1234 If NULL, no nodes are inserted.
1235
1236 The head of the chain of deleted ops is returned, or NULL if no ops were
1237 deleted.
1238
1239 For example:
1240
1241     action                    before      after         returns
1242     ------                    -----       -----         -------
1243
1244                               P           P
1245     splice(P, A, 2, X-Y-Z)    |           |             B-C
1246                               A-B-C-D     A-X-Y-Z-D
1247
1248                               P           P
1249     splice(P, NULL, 1, X-Y)   |           |             A
1250                               A-B-C-D     X-Y-B-C-D
1251
1252                               P           P
1253     splice(P, NULL, 3, NULL)  |           |             A-B-C
1254                               A-B-C-D     D
1255
1256                               P           P
1257     splice(P, B, 0, X-Y)      |           |             NULL
1258                               A-B-C-D     A-B-X-Y-C-D
1259
1260 =cut
1261 */
1262
1263 OP *
1264 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1265 {
1266     OP *first = start ? OpSIBLING(start) : cLISTOPx(parent)->op_first;
1267     OP *rest;
1268     OP *last_del = NULL;
1269     OP *last_ins = NULL;
1270
1271     PERL_ARGS_ASSERT_OP_SIBLING_SPLICE;
1272
1273     assert(del_count >= -1);
1274
1275     if (del_count && first) {
1276         last_del = first;
1277         while (--del_count && OpHAS_SIBLING(last_del))
1278             last_del = OpSIBLING(last_del);
1279         rest = OpSIBLING(last_del);
1280         OpSIBLING_set(last_del, NULL);
1281         last_del->op_lastsib = 1;
1282     }
1283     else
1284         rest = first;
1285
1286     if (insert) {
1287         last_ins = insert;
1288         while (OpHAS_SIBLING(last_ins))
1289             last_ins = OpSIBLING(last_ins);
1290         OpSIBLING_set(last_ins, rest);
1291         last_ins->op_lastsib = rest ? 0 : 1;
1292     }
1293     else
1294         insert = rest;
1295
1296     if (start) {
1297         OpSIBLING_set(start, insert);
1298         start->op_lastsib = insert ? 0 : 1;
1299     }
1300     else {
1301         cLISTOPx(parent)->op_first = insert;
1302         if (insert)
1303             parent->op_flags |= OPf_KIDS;
1304         else
1305             parent->op_flags &= ~OPf_KIDS;
1306     }
1307
1308     if (!rest) {
1309         /* update op_last etc */
1310         U32 type = parent->op_type;
1311         OP *lastop;
1312
1313         if (type == OP_NULL)
1314             type = parent->op_targ;
1315         type = PL_opargs[type] & OA_CLASS_MASK;
1316
1317         lastop = last_ins ? last_ins : start ? start : NULL;
1318         if (   type == OA_BINOP
1319             || type == OA_LISTOP
1320             || type == OA_PMOP
1321             || type == OA_LOOP
1322         )
1323             cLISTOPx(parent)->op_last = lastop;
1324
1325         if (lastop) {
1326             lastop->op_lastsib = 1;
1327 #ifdef PERL_OP_PARENT
1328             lastop->op_sibling = parent;
1329 #endif
1330         }
1331     }
1332     return last_del ? first : NULL;
1333 }
1334
1335 /*
1336 =for apidoc op_parent
1337
1338 returns the parent OP of o, if it has a parent.  Returns NULL otherwise.
1339 (Currently perl must be built with C<-DPERL_OP_PARENT> for this feature to
1340 work.
1341
1342 =cut
1343 */
1344
1345 OP *
1346 Perl_op_parent(OP *o)
1347 {
1348     PERL_ARGS_ASSERT_OP_PARENT;
1349 #ifdef PERL_OP_PARENT
1350     while (OpHAS_SIBLING(o))
1351         o = OpSIBLING(o);
1352     return o->op_sibling;
1353 #else
1354     PERL_UNUSED_ARG(o);
1355     return NULL;
1356 #endif
1357 }
1358
1359
1360 /* replace the sibling following start with a new UNOP, which becomes
1361  * the parent of the original sibling; e.g.
1362  *
1363  *  op_sibling_newUNOP(P, A, unop-args...)
1364  *
1365  *  P              P
1366  *  |      becomes |
1367  *  A-B-C          A-U-C
1368  *                   |
1369  *                   B
1370  *
1371  * where U is the new UNOP.
1372  *
1373  * parent and start args are the same as for op_sibling_splice();
1374  * type and flags args are as newUNOP().
1375  *
1376  * Returns the new UNOP.
1377  */
1378
1379 OP *
1380 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1381 {
1382     OP *kid, *newop;
1383
1384     kid = op_sibling_splice(parent, start, 1, NULL);
1385     newop = newUNOP(type, flags, kid);
1386     op_sibling_splice(parent, start, 0, newop);
1387     return newop;
1388 }
1389
1390
1391 /* lowest-level newLOGOP-style function - just allocates and populates
1392  * the struct. Higher-level stuff should be done by S_new_logop() /
1393  * newLOGOP(). This function exists mainly to avoid op_first assignment
1394  * being spread throughout this file.
1395  */
1396
1397 LOGOP *
1398 S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1399 {
1400     dVAR;
1401     LOGOP *logop;
1402     OP *kid = first;
1403     NewOp(1101, logop, 1, LOGOP);
1404     CHANGE_TYPE(logop, type);
1405     logop->op_first = first;
1406     logop->op_other = other;
1407     logop->op_flags = OPf_KIDS;
1408     while (kid && OpHAS_SIBLING(kid))
1409         kid = OpSIBLING(kid);
1410     if (kid) {
1411         kid->op_lastsib = 1;
1412 #ifdef PERL_OP_PARENT
1413         kid->op_sibling = (OP*)logop;
1414 #endif
1415     }
1416     return logop;
1417 }
1418
1419
1420 /* Contextualizers */
1421
1422 /*
1423 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1424
1425 Applies a syntactic context to an op tree representing an expression.
1426 I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
1427 or C<G_VOID> to specify the context to apply.  The modified op tree
1428 is returned.
1429
1430 =cut
1431 */
1432
1433 OP *
1434 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1435 {
1436     PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1437     switch (context) {
1438         case G_SCALAR: return scalar(o);
1439         case G_ARRAY:  return list(o);
1440         case G_VOID:   return scalarvoid(o);
1441         default:
1442             Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1443                        (long) context);
1444     }
1445 }
1446
1447 /*
1448
1449 =for apidoc Am|OP*|op_linklist|OP *o
1450 This function is the implementation of the L</LINKLIST> macro.  It should
1451 not be called directly.
1452
1453 =cut
1454 */
1455
1456 OP *
1457 Perl_op_linklist(pTHX_ OP *o)
1458 {
1459     OP *first;
1460
1461     PERL_ARGS_ASSERT_OP_LINKLIST;
1462
1463     if (o->op_next)
1464         return o->op_next;
1465
1466     /* establish postfix order */
1467     first = cUNOPo->op_first;
1468     if (first) {
1469         OP *kid;
1470         o->op_next = LINKLIST(first);
1471         kid = first;
1472         for (;;) {
1473             OP *sibl = OpSIBLING(kid);
1474             if (sibl) {
1475                 kid->op_next = LINKLIST(sibl);
1476                 kid = sibl;
1477             } else {
1478                 kid->op_next = o;
1479                 break;
1480             }
1481         }
1482     }
1483     else
1484         o->op_next = o;
1485
1486     return o->op_next;
1487 }
1488
1489 static OP *
1490 S_scalarkids(pTHX_ OP *o)
1491 {
1492     if (o && o->op_flags & OPf_KIDS) {
1493         OP *kid;
1494         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1495             scalar(kid);
1496     }
1497     return o;
1498 }
1499
1500 STATIC OP *
1501 S_scalarboolean(pTHX_ OP *o)
1502 {
1503     PERL_ARGS_ASSERT_SCALARBOOLEAN;
1504
1505     if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
1506      && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
1507         if (ckWARN(WARN_SYNTAX)) {
1508             const line_t oldline = CopLINE(PL_curcop);
1509
1510             if (PL_parser && PL_parser->copline != NOLINE) {
1511                 /* This ensures that warnings are reported at the first line
1512                    of the conditional, not the last.  */
1513                 CopLINE_set(PL_curcop, PL_parser->copline);
1514             }
1515             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1516             CopLINE_set(PL_curcop, oldline);
1517         }
1518     }
1519     return scalar(o);
1520 }
1521
1522 static SV *
1523 S_op_varname(pTHX_ const OP *o)
1524 {
1525     assert(o);
1526     assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1527            o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1528     {
1529         const char funny  = o->op_type == OP_PADAV
1530                          || o->op_type == OP_RV2AV ? '@' : '%';
1531         if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1532             GV *gv;
1533             if (cUNOPo->op_first->op_type != OP_GV
1534              || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1535                 return NULL;
1536             return varname(gv, funny, 0, NULL, 0, 1);
1537         }
1538         return
1539             varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, 1);
1540     }
1541 }
1542
1543 static void
1544 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1545 { /* or not so pretty :-) */
1546     if (o->op_type == OP_CONST) {
1547         *retsv = cSVOPo_sv;
1548         if (SvPOK(*retsv)) {
1549             SV *sv = *retsv;
1550             *retsv = sv_newmortal();
1551             pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1552                       PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1553         }
1554         else if (!SvOK(*retsv))
1555             *retpv = "undef";
1556     }
1557     else *retpv = "...";
1558 }
1559
1560 static void
1561 S_scalar_slice_warning(pTHX_ const OP *o)
1562 {
1563     OP *kid;
1564     const char lbrack =
1565         o->op_type == OP_HSLICE ? '{' : '[';
1566     const char rbrack =
1567         o->op_type == OP_HSLICE ? '}' : ']';
1568     SV *name;
1569     SV *keysv = NULL; /* just to silence compiler warnings */
1570     const char *key = NULL;
1571
1572     if (!(o->op_private & OPpSLICEWARNING))
1573         return;
1574     if (PL_parser && PL_parser->error_count)
1575         /* This warning can be nonsensical when there is a syntax error. */
1576         return;
1577
1578     kid = cLISTOPo->op_first;
1579     kid = OpSIBLING(kid); /* get past pushmark */
1580     /* weed out false positives: any ops that can return lists */
1581     switch (kid->op_type) {
1582     case OP_BACKTICK:
1583     case OP_GLOB:
1584     case OP_READLINE:
1585     case OP_MATCH:
1586     case OP_RV2AV:
1587     case OP_EACH:
1588     case OP_VALUES:
1589     case OP_KEYS:
1590     case OP_SPLIT:
1591     case OP_LIST:
1592     case OP_SORT:
1593     case OP_REVERSE:
1594     case OP_ENTERSUB:
1595     case OP_CALLER:
1596     case OP_LSTAT:
1597     case OP_STAT:
1598     case OP_READDIR:
1599     case OP_SYSTEM:
1600     case OP_TMS:
1601     case OP_LOCALTIME:
1602     case OP_GMTIME:
1603     case OP_ENTEREVAL:
1604     case OP_REACH:
1605     case OP_RKEYS:
1606     case OP_RVALUES:
1607         return;
1608     }
1609
1610     /* Don't warn if we have a nulled list either. */
1611     if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1612         return;
1613
1614     assert(OpSIBLING(kid));
1615     name = S_op_varname(aTHX_ OpSIBLING(kid));
1616     if (!name) /* XS module fiddling with the op tree */
1617         return;
1618     S_op_pretty(aTHX_ kid, &keysv, &key);
1619     assert(SvPOK(name));
1620     sv_chop(name,SvPVX(name)+1);
1621     if (key)
1622        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1623         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1624                    "Scalar value @%"SVf"%c%s%c better written as $%"SVf
1625                    "%c%s%c",
1626                     SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1627                     lbrack, key, rbrack);
1628     else
1629        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1630         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1631                    "Scalar value @%"SVf"%c%"SVf"%c better written as $%"
1632                     SVf"%c%"SVf"%c",
1633                     SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1634                     SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1635 }
1636
1637 OP *
1638 Perl_scalar(pTHX_ OP *o)
1639 {
1640     OP *kid;
1641
1642     /* assumes no premature commitment */
1643     if (!o || (PL_parser && PL_parser->error_count)
1644          || (o->op_flags & OPf_WANT)
1645          || o->op_type == OP_RETURN)
1646     {
1647         return o;
1648     }
1649
1650     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1651
1652     switch (o->op_type) {
1653     case OP_REPEAT:
1654         scalar(cBINOPo->op_first);
1655         if (o->op_private & OPpREPEAT_DOLIST) {
1656             kid = cLISTOPx(cUNOPo->op_first)->op_first;
1657             assert(kid->op_type == OP_PUSHMARK);
1658             if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1659                 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1660                 o->op_private &=~ OPpREPEAT_DOLIST;
1661             }
1662         }
1663         break;
1664     case OP_OR:
1665     case OP_AND:
1666     case OP_COND_EXPR:
1667         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
1668             scalar(kid);
1669         break;
1670         /* FALLTHROUGH */
1671     case OP_SPLIT:
1672     case OP_MATCH:
1673     case OP_QR:
1674     case OP_SUBST:
1675     case OP_NULL:
1676     default:
1677         if (o->op_flags & OPf_KIDS) {
1678             for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1679                 scalar(kid);
1680         }
1681         break;
1682     case OP_LEAVE:
1683     case OP_LEAVETRY:
1684         kid = cLISTOPo->op_first;
1685         scalar(kid);
1686         kid = OpSIBLING(kid);
1687     do_kids:
1688         while (kid) {
1689             OP *sib = OpSIBLING(kid);
1690             if (sib && kid->op_type != OP_LEAVEWHEN
1691              && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
1692                 || (  sib->op_targ != OP_NEXTSTATE
1693                    && sib->op_targ != OP_DBSTATE  )))
1694                 scalarvoid(kid);
1695             else
1696                 scalar(kid);
1697             kid = sib;
1698         }
1699         PL_curcop = &PL_compiling;
1700         break;
1701     case OP_SCOPE:
1702     case OP_LINESEQ:
1703     case OP_LIST:
1704         kid = cLISTOPo->op_first;
1705         goto do_kids;
1706     case OP_SORT:
1707         Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1708         break;
1709     case OP_KVHSLICE:
1710     case OP_KVASLICE:
1711     {
1712         /* Warn about scalar context */
1713         const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1714         const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1715         SV *name;
1716         SV *keysv;
1717         const char *key = NULL;
1718
1719         /* This warning can be nonsensical when there is a syntax error. */
1720         if (PL_parser && PL_parser->error_count)
1721             break;
1722
1723         if (!ckWARN(WARN_SYNTAX)) break;
1724
1725         kid = cLISTOPo->op_first;
1726         kid = OpSIBLING(kid); /* get past pushmark */
1727         assert(OpSIBLING(kid));
1728         name = S_op_varname(aTHX_ OpSIBLING(kid));
1729         if (!name) /* XS module fiddling with the op tree */
1730             break;
1731         S_op_pretty(aTHX_ kid, &keysv, &key);
1732         assert(SvPOK(name));
1733         sv_chop(name,SvPVX(name)+1);
1734         if (key)
1735   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1736             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1737                        "%%%"SVf"%c%s%c in scalar context better written "
1738                        "as $%"SVf"%c%s%c",
1739                         SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1740                         lbrack, key, rbrack);
1741         else
1742   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1743             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1744                        "%%%"SVf"%c%"SVf"%c in scalar context better "
1745                        "written as $%"SVf"%c%"SVf"%c",
1746                         SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1747                         SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1748     }
1749     }
1750     return o;
1751 }
1752
1753 OP *
1754 Perl_scalarvoid(pTHX_ OP *arg)
1755 {
1756     dVAR;
1757     OP *kid;
1758     SV* sv;
1759     U8 want;
1760     SSize_t defer_stack_alloc = 0;
1761     SSize_t defer_ix = -1;
1762     OP **defer_stack = NULL;
1763     OP *o = arg;
1764
1765     PERL_ARGS_ASSERT_SCALARVOID;
1766
1767     do {
1768         SV *useless_sv = NULL;
1769         const char* useless = NULL;
1770         bool useless_is_grep = FALSE;
1771
1772         if (o->op_type == OP_NEXTSTATE
1773             || o->op_type == OP_DBSTATE
1774             || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1775                                           || o->op_targ == OP_DBSTATE)))
1776             PL_curcop = (COP*)o;                /* for warning below */
1777
1778         /* assumes no premature commitment */
1779         want = o->op_flags & OPf_WANT;
1780         if ((want && want != OPf_WANT_SCALAR)
1781             || (PL_parser && PL_parser->error_count)
1782             || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1783         {
1784             continue;
1785         }
1786
1787         if ((o->op_private & OPpTARGET_MY)
1788             && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1789         {
1790             /* newASSIGNOP has already applied scalar context, which we
1791                leave, as if this op is inside SASSIGN.  */
1792             continue;
1793         }
1794
1795         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1796
1797         switch (o->op_type) {
1798         default:
1799             if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1800                 break;
1801             /* FALLTHROUGH */
1802         case OP_REPEAT:
1803             if (o->op_flags & OPf_STACKED)
1804                 break;
1805             if (o->op_type == OP_REPEAT)
1806                 scalar(cBINOPo->op_first);
1807             goto func_ops;
1808         case OP_SUBSTR:
1809             if (o->op_private == 4)
1810                 break;
1811             /* FALLTHROUGH */
1812         case OP_WANTARRAY:
1813         case OP_GV:
1814         case OP_SMARTMATCH:
1815         case OP_AV2ARYLEN:
1816         case OP_REF:
1817         case OP_REFGEN:
1818         case OP_SREFGEN:
1819         case OP_DEFINED:
1820         case OP_HEX:
1821         case OP_OCT:
1822         case OP_LENGTH:
1823         case OP_VEC:
1824         case OP_INDEX:
1825         case OP_RINDEX:
1826         case OP_SPRINTF:
1827         case OP_KVASLICE:
1828         case OP_KVHSLICE:
1829         case OP_UNPACK:
1830         case OP_PACK:
1831         case OP_JOIN:
1832         case OP_LSLICE:
1833         case OP_ANONLIST:
1834         case OP_ANONHASH:
1835         case OP_SORT:
1836         case OP_REVERSE:
1837         case OP_RANGE:
1838         case OP_FLIP:
1839         case OP_FLOP:
1840         case OP_CALLER:
1841         case OP_FILENO:
1842         case OP_EOF:
1843         case OP_TELL:
1844         case OP_GETSOCKNAME:
1845         case OP_GETPEERNAME:
1846         case OP_READLINK:
1847         case OP_TELLDIR:
1848         case OP_GETPPID:
1849         case OP_GETPGRP:
1850         case OP_GETPRIORITY:
1851         case OP_TIME:
1852         case OP_TMS:
1853         case OP_LOCALTIME:
1854         case OP_GMTIME:
1855         case OP_GHBYNAME:
1856         case OP_GHBYADDR:
1857         case OP_GHOSTENT:
1858         case OP_GNBYNAME:
1859         case OP_GNBYADDR:
1860         case OP_GNETENT:
1861         case OP_GPBYNAME:
1862         case OP_GPBYNUMBER:
1863         case OP_GPROTOENT:
1864         case OP_GSBYNAME:
1865         case OP_GSBYPORT:
1866         case OP_GSERVENT:
1867         case OP_GPWNAM:
1868         case OP_GPWUID:
1869         case OP_GGRNAM:
1870         case OP_GGRGID:
1871         case OP_GETLOGIN:
1872         case OP_PROTOTYPE:
1873         case OP_RUNCV:
1874         func_ops:
1875             useless = OP_DESC(o);
1876             break;
1877
1878         case OP_GVSV:
1879         case OP_PADSV:
1880         case OP_PADAV:
1881         case OP_PADHV:
1882         case OP_PADANY:
1883         case OP_AELEM:
1884         case OP_AELEMFAST:
1885         case OP_AELEMFAST_LEX:
1886         case OP_ASLICE:
1887         case OP_HELEM:
1888         case OP_HSLICE:
1889             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1890                 useless = OP_DESC(o);
1891             break;
1892         case OP_GREPWHILE:
1893             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO))) {
1894                 /* Otherwise it's "Useless use of grep iterator" */
1895                 useless = "grep";
1896                 useless_is_grep = TRUE;
1897             }
1898             break;
1899
1900         case OP_SPLIT:
1901             kid = cLISTOPo->op_first;
1902             if (kid && kid->op_type == OP_PUSHRE
1903                 && !kid->op_targ
1904                 && !(o->op_flags & OPf_STACKED)
1905 #ifdef USE_ITHREADS
1906                 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
1907 #else
1908                 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
1909 #endif
1910                 )
1911                 useless = OP_DESC(o);
1912             break;
1913
1914         case OP_NOT:
1915             kid = cUNOPo->op_first;
1916             if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1917                 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1918                 goto func_ops;
1919             }
1920             useless = "negative pattern binding (!~)";
1921             break;
1922
1923         case OP_SUBST:
1924             if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1925                 useless = "non-destructive substitution (s///r)";
1926             break;
1927
1928         case OP_TRANSR:
1929             useless = "non-destructive transliteration (tr///r)";
1930             break;
1931
1932         case OP_RV2GV:
1933         case OP_RV2SV:
1934         case OP_RV2AV:
1935         case OP_RV2HV:
1936             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1937                 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
1938                 useless = "a variable";
1939             break;
1940
1941         case OP_CONST:
1942             sv = cSVOPo_sv;
1943             if (cSVOPo->op_private & OPpCONST_STRICT)
1944                 no_bareword_allowed(o);
1945             else {
1946                 if (ckWARN(WARN_VOID)) {
1947                     NV nv;
1948                     /* don't warn on optimised away booleans, eg
1949                      * use constant Foo, 5; Foo || print; */
1950                     if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1951                         useless = NULL;
1952                     /* the constants 0 and 1 are permitted as they are
1953                        conventionally used as dummies in constructs like
1954                        1 while some_condition_with_side_effects;  */
1955                     else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
1956                         useless = NULL;
1957                     else if (SvPOK(sv)) {
1958                         SV * const dsv = newSVpvs("");
1959                         useless_sv
1960                             = Perl_newSVpvf(aTHX_
1961                                             "a constant (%s)",
1962                                             pv_pretty(dsv, SvPVX_const(sv),
1963                                                       SvCUR(sv), 32, NULL, NULL,
1964                                                       PERL_PV_PRETTY_DUMP
1965                                                       | PERL_PV_ESCAPE_NOCLEAR
1966                                                       | PERL_PV_ESCAPE_UNI_DETECT));
1967                         SvREFCNT_dec_NN(dsv);
1968                     }
1969                     else if (SvOK(sv)) {
1970                         useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", SVfARG(sv));
1971                     }
1972                     else
1973                         useless = "a constant (undef)";
1974                 }
1975             }
1976             op_null(o);         /* don't execute or even remember it */
1977             break;
1978
1979         case OP_POSTINC:
1980             CHANGE_TYPE(o, OP_PREINC);  /* pre-increment is faster */
1981             break;
1982
1983         case OP_POSTDEC:
1984             CHANGE_TYPE(o, OP_PREDEC);  /* pre-decrement is faster */
1985             break;
1986
1987         case OP_I_POSTINC:
1988             CHANGE_TYPE(o, OP_I_PREINC);        /* pre-increment is faster */
1989             break;
1990
1991         case OP_I_POSTDEC:
1992             CHANGE_TYPE(o, OP_I_PREDEC);        /* pre-decrement is faster */
1993             break;
1994
1995         case OP_SASSIGN: {
1996             OP *rv2gv;
1997             UNOP *refgen, *rv2cv;
1998             LISTOP *exlist;
1999
2000             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2001                 break;
2002
2003             rv2gv = ((BINOP *)o)->op_last;
2004             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2005                 break;
2006
2007             refgen = (UNOP *)((BINOP *)o)->op_first;
2008
2009             if (!refgen || (refgen->op_type != OP_REFGEN
2010                             && refgen->op_type != OP_SREFGEN))
2011                 break;
2012
2013             exlist = (LISTOP *)refgen->op_first;
2014             if (!exlist || exlist->op_type != OP_NULL
2015                 || exlist->op_targ != OP_LIST)
2016                 break;
2017
2018             if (exlist->op_first->op_type != OP_PUSHMARK
2019                 && exlist->op_first != exlist->op_last)
2020                 break;
2021
2022             rv2cv = (UNOP*)exlist->op_last;
2023
2024             if (rv2cv->op_type != OP_RV2CV)
2025                 break;
2026
2027             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2028             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2029             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2030
2031             o->op_private |= OPpASSIGN_CV_TO_GV;
2032             rv2gv->op_private |= OPpDONT_INIT_GV;
2033             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2034
2035             break;
2036         }
2037
2038         case OP_AASSIGN: {
2039             inplace_aassign(o);
2040             break;
2041         }
2042
2043         case OP_OR:
2044         case OP_AND:
2045             kid = cLOGOPo->op_first;
2046             if (kid->op_type == OP_NOT
2047                 && (kid->op_flags & OPf_KIDS)) {
2048                 if (o->op_type == OP_AND) {
2049                     CHANGE_TYPE(o, OP_OR);
2050                 } else {
2051                     CHANGE_TYPE(o, OP_AND);
2052                 }
2053                 op_null(kid);
2054             }
2055             /* FALLTHROUGH */
2056
2057         case OP_DOR:
2058         case OP_COND_EXPR:
2059         case OP_ENTERGIVEN:
2060         case OP_ENTERWHEN:
2061             for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2062                 if (!(kid->op_flags & OPf_KIDS))
2063                     scalarvoid(kid);
2064                 else
2065                     DEFER_OP(kid);
2066         break;
2067
2068         case OP_NULL:
2069             if (o->op_flags & OPf_STACKED)
2070                 break;
2071             /* FALLTHROUGH */
2072         case OP_NEXTSTATE:
2073         case OP_DBSTATE:
2074         case OP_ENTERTRY:
2075         case OP_ENTER:
2076             if (!(o->op_flags & OPf_KIDS))
2077                 break;
2078             /* FALLTHROUGH */
2079         case OP_SCOPE:
2080         case OP_LEAVE:
2081         case OP_LEAVETRY:
2082         case OP_LEAVELOOP:
2083         case OP_LINESEQ:
2084         case OP_LEAVEGIVEN:
2085         case OP_LEAVEWHEN:
2086         kids:
2087             for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2088                 if (!(kid->op_flags & OPf_KIDS))
2089                     scalarvoid(kid);
2090                 else
2091                     DEFER_OP(kid);
2092             break;
2093         case OP_LIST:
2094             /* If the first kid after pushmark is something that the padrange
2095                optimisation would reject, then null the list and the pushmark.
2096             */
2097             if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2098                 && (  !(kid = OpSIBLING(kid))
2099                       || (  kid->op_type != OP_PADSV
2100                             && kid->op_type != OP_PADAV
2101                             && kid->op_type != OP_PADHV)
2102                       || kid->op_private & ~OPpLVAL_INTRO
2103                       || !(kid = OpSIBLING(kid))
2104                       || (  kid->op_type != OP_PADSV
2105                             && kid->op_type != OP_PADAV
2106                             && kid->op_type != OP_PADHV)
2107                       || kid->op_private & ~OPpLVAL_INTRO)
2108             ) {
2109                 op_null(cUNOPo->op_first); /* NULL the pushmark */
2110                 op_null(o); /* NULL the list */
2111             }
2112             goto kids;
2113         case OP_ENTEREVAL:
2114             scalarkids(o);
2115             break;
2116         case OP_SCALAR:
2117             scalar(o);
2118             break;
2119         }
2120
2121         if (useless_sv) {
2122             /* mortalise it, in case warnings are fatal.  */
2123             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2124                            "Useless use of %"SVf" in void context",
2125                            SVfARG(sv_2mortal(useless_sv)));
2126         }
2127         else if (useless) {
2128             if (useless_is_grep) {
2129                 Perl_ck_warner(aTHX_ packWARN(WARN_VOID_UNUSUAL),
2130                                "Unusual use of %s in void context",
2131                                useless);
2132             } else {
2133                 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2134                                "Useless use of %s in void context",
2135                                useless);
2136             }
2137         }
2138     } while ( (o = POP_DEFERRED_OP()) );
2139
2140     Safefree(defer_stack);
2141
2142     return arg;
2143 }
2144
2145 static OP *
2146 S_listkids(pTHX_ OP *o)
2147 {
2148     if (o && o->op_flags & OPf_KIDS) {
2149         OP *kid;
2150         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2151             list(kid);
2152     }
2153     return o;
2154 }
2155
2156 OP *
2157 Perl_list(pTHX_ OP *o)
2158 {
2159     OP *kid;
2160
2161     /* assumes no premature commitment */
2162     if (!o || (o->op_flags & OPf_WANT)
2163          || (PL_parser && PL_parser->error_count)
2164          || o->op_type == OP_RETURN)
2165     {
2166         return o;
2167     }
2168
2169     if ((o->op_private & OPpTARGET_MY)
2170         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2171     {
2172         return o;                               /* As if inside SASSIGN */
2173     }
2174
2175     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2176
2177     switch (o->op_type) {
2178     case OP_FLOP:
2179         list(cBINOPo->op_first);
2180         break;
2181     case OP_REPEAT:
2182         if (o->op_private & OPpREPEAT_DOLIST
2183          && !(o->op_flags & OPf_STACKED))
2184         {
2185             list(cBINOPo->op_first);
2186             kid = cBINOPo->op_last;
2187             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2188              && SvIVX(kSVOP_sv) == 1)
2189             {
2190                 op_null(o); /* repeat */
2191                 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2192                 /* const (rhs): */
2193                 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2194             }
2195         }
2196         break;
2197     case OP_OR:
2198     case OP_AND:
2199     case OP_COND_EXPR:
2200         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2201             list(kid);
2202         break;
2203     default:
2204     case OP_MATCH:
2205     case OP_QR:
2206     case OP_SUBST:
2207     case OP_NULL:
2208         if (!(o->op_flags & OPf_KIDS))
2209             break;
2210         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2211             list(cBINOPo->op_first);
2212             return gen_constant_list(o);
2213         }
2214         listkids(o);
2215         break;
2216     case OP_LIST:
2217         listkids(o);
2218         if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2219             op_null(cUNOPo->op_first); /* NULL the pushmark */
2220             op_null(o); /* NULL the list */
2221         }
2222         break;
2223     case OP_LEAVE:
2224     case OP_LEAVETRY:
2225         kid = cLISTOPo->op_first;
2226         list(kid);
2227         kid = OpSIBLING(kid);
2228     do_kids:
2229         while (kid) {
2230             OP *sib = OpSIBLING(kid);
2231             if (sib && kid->op_type != OP_LEAVEWHEN)
2232                 scalarvoid(kid);
2233             else
2234                 list(kid);
2235             kid = sib;
2236         }
2237         PL_curcop = &PL_compiling;
2238         break;
2239     case OP_SCOPE:
2240     case OP_LINESEQ:
2241         kid = cLISTOPo->op_first;
2242         goto do_kids;
2243     }
2244     return o;
2245 }
2246
2247 static OP *
2248 S_scalarseq(pTHX_ OP *o)
2249 {
2250     if (o) {
2251         const OPCODE type = o->op_type;
2252
2253         if (type == OP_LINESEQ || type == OP_SCOPE ||
2254             type == OP_LEAVE || type == OP_LEAVETRY)
2255         {
2256             OP *kid, *sib;
2257             for (kid = cLISTOPo->op_first; kid; kid = sib) {
2258                 if ((sib = OpSIBLING(kid))
2259                  && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2260                     || (  sib->op_targ != OP_NEXTSTATE
2261                        && sib->op_targ != OP_DBSTATE  )))
2262                 {
2263                     scalarvoid(kid);
2264                 }
2265             }
2266             PL_curcop = &PL_compiling;
2267         }
2268         o->op_flags &= ~OPf_PARENS;
2269         if (PL_hints & HINT_BLOCK_SCOPE)
2270             o->op_flags |= OPf_PARENS;
2271     }
2272     else
2273         o = newOP(OP_STUB, 0);
2274     return o;
2275 }
2276
2277 STATIC OP *
2278 S_modkids(pTHX_ OP *o, I32 type)
2279 {
2280     if (o && o->op_flags & OPf_KIDS) {
2281         OP *kid;
2282         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2283             op_lvalue(kid, type);
2284     }
2285     return o;
2286 }
2287
2288
2289 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2290  * const fields. Also, convert CONST keys to HEK-in-SVs.
2291  * rop is the op that retrieves the hash;
2292  * key_op is the first key
2293  */
2294
2295 void
2296 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op)
2297 {
2298     PADNAME *lexname;
2299     GV **fields;
2300     bool check_fields;
2301
2302     /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2303     if (rop) {
2304         if (rop->op_first->op_type == OP_PADSV)
2305             /* @$hash{qw(keys here)} */
2306             rop = (UNOP*)rop->op_first;
2307         else {
2308             /* @{$hash}{qw(keys here)} */
2309             if (rop->op_first->op_type == OP_SCOPE
2310                 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2311                 {
2312                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2313                 }
2314             else
2315                 rop = NULL;
2316         }
2317     }
2318
2319     lexname = NULL; /* just to silence compiler warnings */
2320     fields  = NULL; /* just to silence compiler warnings */
2321
2322     check_fields =
2323             rop
2324          && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2325              SvPAD_TYPED(lexname))
2326          && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2327          && isGV(*fields) && GvHV(*fields);
2328
2329     for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2330         SV **svp, *sv;
2331         if (key_op->op_type != OP_CONST)
2332             continue;
2333         svp = cSVOPx_svp(key_op);
2334
2335         /* Make the CONST have a shared SV */
2336         if (   !SvIsCOW_shared_hash(sv = *svp)
2337             && SvTYPE(sv) < SVt_PVMG
2338             && SvOK(sv)
2339             && !SvROK(sv))
2340         {
2341             SSize_t keylen;
2342             const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2343             SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2344             SvREFCNT_dec_NN(sv);
2345             *svp = nsv;
2346         }
2347
2348         if (   check_fields
2349             && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2350         {
2351             Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
2352                         "in variable %"PNf" of type %"HEKf,
2353                         SVfARG(*svp), PNfARG(lexname),
2354                         HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2355         }
2356     }
2357 }
2358
2359
2360 /*
2361 =for apidoc finalize_optree
2362
2363 This function finalizes the optree.  Should be called directly after
2364 the complete optree is built.  It does some additional
2365 checking which can't be done in the normal ck_xxx functions and makes
2366 the tree thread-safe.
2367
2368 =cut
2369 */
2370 void
2371 Perl_finalize_optree(pTHX_ OP* o)
2372 {
2373     PERL_ARGS_ASSERT_FINALIZE_OPTREE;
2374
2375     ENTER;
2376     SAVEVPTR(PL_curcop);
2377
2378     finalize_op(o);
2379
2380     LEAVE;
2381 }
2382
2383 #ifdef USE_ITHREADS
2384 /* Relocate sv to the pad for thread safety.
2385  * Despite being a "constant", the SV is written to,
2386  * for reference counts, sv_upgrade() etc. */
2387 PERL_STATIC_INLINE void
2388 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
2389 {
2390     PADOFFSET ix;
2391     PERL_ARGS_ASSERT_OP_RELOCATE_SV;
2392     if (!*svp) return;
2393     ix = pad_alloc(OP_CONST, SVf_READONLY);
2394     SvREFCNT_dec(PAD_SVl(ix));
2395     PAD_SETSV(ix, *svp);
2396     /* XXX I don't know how this isn't readonly already. */
2397     if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
2398     *svp = NULL;
2399     *targp = ix;
2400 }
2401 #endif
2402
2403
2404 STATIC void
2405 S_finalize_op(pTHX_ OP* o)
2406 {
2407     PERL_ARGS_ASSERT_FINALIZE_OP;
2408
2409
2410     switch (o->op_type) {
2411     case OP_NEXTSTATE:
2412     case OP_DBSTATE:
2413         PL_curcop = ((COP*)o);          /* for warnings */
2414         break;
2415     case OP_EXEC:
2416         if (OpHAS_SIBLING(o)) {
2417             OP *sib = OpSIBLING(o);
2418             if ((  sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
2419                 && ckWARN(WARN_EXEC)
2420                 && OpHAS_SIBLING(sib))
2421             {
2422                     const OPCODE type = OpSIBLING(sib)->op_type;
2423                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
2424                         const line_t oldline = CopLINE(PL_curcop);
2425                         CopLINE_set(PL_curcop, CopLINE((COP*)sib));
2426                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
2427                             "Statement unlikely to be reached");
2428                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
2429                             "\t(Maybe you meant system() when you said exec()?)\n");
2430                         CopLINE_set(PL_curcop, oldline);
2431                     }
2432             }
2433         }
2434         break;
2435
2436     case OP_GV:
2437         if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
2438             GV * const gv = cGVOPo_gv;
2439             if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
2440                 /* XXX could check prototype here instead of just carping */
2441                 SV * const sv = sv_newmortal();
2442                 gv_efullname3(sv, gv, NULL);
2443                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
2444                     "%"SVf"() called too early to check prototype",
2445                     SVfARG(sv));
2446             }
2447         }
2448         break;
2449
2450     case OP_CONST:
2451         if (cSVOPo->op_private & OPpCONST_STRICT)
2452             no_bareword_allowed(o);
2453         /* FALLTHROUGH */
2454 #ifdef USE_ITHREADS
2455     case OP_HINTSEVAL:
2456         op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
2457 #endif
2458         break;
2459
2460 #ifdef USE_ITHREADS
2461     /* Relocate all the METHOP's SVs to the pad for thread safety. */
2462     case OP_METHOD_NAMED:
2463     case OP_METHOD_SUPER:
2464     case OP_METHOD_REDIR:
2465     case OP_METHOD_REDIR_SUPER:
2466         op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
2467         break;
2468 #endif
2469
2470     case OP_HELEM: {
2471         UNOP *rop;
2472         SVOP *key_op;
2473         OP *kid;
2474
2475         if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
2476             break;
2477
2478         rop = (UNOP*)((BINOP*)o)->op_first;
2479
2480         goto check_keys;
2481
2482     case OP_HSLICE:
2483         S_scalar_slice_warning(aTHX_ o);
2484         /* FALLTHROUGH */
2485
2486     case OP_KVHSLICE:
2487         kid = OpSIBLING(cLISTOPo->op_first);
2488         if (/* I bet there's always a pushmark... */
2489             OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
2490             && OP_TYPE_ISNT_NN(kid, OP_CONST))
2491         {
2492             break;
2493         }
2494
2495         key_op = (SVOP*)(kid->op_type == OP_CONST
2496                                 ? kid
2497                                 : OpSIBLING(kLISTOP->op_first));
2498
2499         rop = (UNOP*)((LISTOP*)o)->op_last;
2500
2501       check_keys:
2502         if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
2503             rop = NULL;
2504         S_check_hash_fields_and_hekify(aTHX_ rop, key_op);
2505         break;
2506     }
2507     case OP_ASLICE:
2508         S_scalar_slice_warning(aTHX_ o);
2509         break;
2510
2511     case OP_SUBST: {
2512         if (cPMOPo->op_pmreplrootu.op_pmreplroot)
2513             finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
2514         break;
2515     }
2516     default:
2517         break;
2518     }
2519
2520     if (o->op_flags & OPf_KIDS) {
2521         OP *kid;
2522
2523 #ifdef DEBUGGING
2524         /* check that op_last points to the last sibling, and that
2525          * the last op_sibling field points back to the parent, and
2526          * that the only ops with KIDS are those which are entitled to
2527          * them */
2528         U32 type = o->op_type;
2529         U32 family;
2530         bool has_last;
2531
2532         if (type == OP_NULL) {
2533             type = o->op_targ;
2534             /* ck_glob creates a null UNOP with ex-type GLOB
2535              * (which is a list op. So pretend it wasn't a listop */
2536             if (type == OP_GLOB)
2537                 type = OP_NULL;
2538         }
2539         family = PL_opargs[type] & OA_CLASS_MASK;
2540
2541         has_last = (   family == OA_BINOP
2542                     || family == OA_LISTOP
2543                     || family == OA_PMOP
2544                     || family == OA_LOOP
2545                    );
2546         assert(  has_last /* has op_first and op_last, or ...
2547               ... has (or may have) op_first: */
2548               || family == OA_UNOP
2549               || family == OA_UNOP_AUX
2550               || family == OA_LOGOP
2551               || family == OA_BASEOP_OR_UNOP
2552               || family == OA_FILESTATOP
2553               || family == OA_LOOPEXOP
2554               || family == OA_METHOP
2555               /* I don't know why SASSIGN is tagged as OA_BASEOP - DAPM */
2556               || type == OP_SASSIGN
2557               || type == OP_CUSTOM
2558               || type == OP_NULL /* new_logop does this */
2559               );
2560
2561         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2562 #  ifdef PERL_OP_PARENT
2563             if (!OpHAS_SIBLING(kid)) {
2564                 if (has_last)
2565                     assert(kid == cLISTOPo->op_last);
2566                 assert(kid->op_sibling == o);
2567             }
2568 #  else
2569             if (OpHAS_SIBLING(kid)) {
2570                 assert(!kid->op_lastsib);
2571             }
2572             else {
2573                 assert(kid->op_lastsib);
2574                 if (has_last)
2575                     assert(kid == cLISTOPo->op_last);
2576             }
2577 #  endif
2578         }
2579 #endif
2580
2581         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
2582             finalize_op(kid);
2583     }
2584 }
2585
2586 /*
2587 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
2588
2589 Propagate lvalue ("modifiable") context to an op and its children.
2590 I<type> represents the context type, roughly based on the type of op that
2591 would do the modifying, although C<local()> is represented by OP_NULL,
2592 because it has no op type of its own (it is signalled by a flag on
2593 the lvalue op).
2594
2595 This function detects things that can't be modified, such as C<$x+1>, and
2596 generates errors for them.  For example, C<$x+1 = 2> would cause it to be
2597 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
2598
2599 It also flags things that need to behave specially in an lvalue context,
2600 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
2601
2602 =cut
2603 */
2604
2605 static void
2606 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
2607 {
2608     CV *cv = PL_compcv;
2609     PadnameLVALUE_on(pn);
2610     while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
2611         cv = CvOUTSIDE(cv);
2612         assert(cv);
2613         assert(CvPADLIST(cv));
2614         pn =
2615            PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
2616         assert(PadnameLEN(pn));
2617         PadnameLVALUE_on(pn);
2618     }
2619 }
2620
2621 static bool
2622 S_vivifies(const OPCODE type)
2623 {
2624     switch(type) {
2625     case OP_RV2AV:     case   OP_ASLICE:
2626     case OP_RV2HV:     case OP_KVASLICE:
2627     case OP_RV2SV:     case   OP_HSLICE:
2628     case OP_AELEMFAST: case OP_KVHSLICE:
2629     case OP_HELEM:
2630     case OP_AELEM:
2631         return 1;
2632     }
2633     return 0;
2634 }
2635
2636 static void
2637 S_lvref(pTHX_ OP *o, I32 type)
2638 {
2639     dVAR;
2640     OP *kid;
2641     switch (o->op_type) {
2642     case OP_COND_EXPR:
2643         for (kid = OpSIBLING(cUNOPo->op_first); kid;
2644              kid = OpSIBLING(kid))
2645             S_lvref(aTHX_ kid, type);
2646         /* FALLTHROUGH */
2647     case OP_PUSHMARK:
2648         return;
2649     case OP_RV2AV:
2650         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2651         o->op_flags |= OPf_STACKED;
2652         if (o->op_flags & OPf_PARENS) {
2653             if (o->op_private & OPpLVAL_INTRO) {
2654                  yyerror(Perl_form(aTHX_ "Can't modify reference to "
2655                       "localized parenthesized array in list assignment"));
2656                 return;
2657             }
2658           slurpy:
2659             CHANGE_TYPE(o, OP_LVAVREF);
2660             o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
2661             o->op_flags |= OPf_MOD|OPf_REF;
2662             return;
2663         }
2664         o->op_private |= OPpLVREF_AV;
2665         goto checkgv;
2666     case OP_RV2CV:
2667         kid = cUNOPo->op_first;
2668         if (kid->op_type == OP_NULL)
2669             kid = cUNOPx(kUNOP->op_first->op_sibling)
2670                 ->op_first;
2671         o->op_private = OPpLVREF_CV;
2672         if (kid->op_type == OP_GV)
2673             o->op_flags |= OPf_STACKED;
2674         else if (kid->op_type == OP_PADCV) {
2675             o->op_targ = kid->op_targ;
2676             kid->op_targ = 0;
2677             op_free(cUNOPo->op_first);
2678             cUNOPo->op_first = NULL;
2679             o->op_flags &=~ OPf_KIDS;
2680         }
2681         else goto badref;
2682         break;
2683     case OP_RV2HV:
2684         if (o->op_flags & OPf_PARENS) {
2685           parenhash:
2686             yyerror(Perl_form(aTHX_ "Can't modify reference to "
2687                                  "parenthesized hash in list assignment"));
2688                 return;
2689         }
2690         o->op_private |= OPpLVREF_HV;
2691         /* FALLTHROUGH */
2692     case OP_RV2SV:
2693       checkgv:
2694         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2695         o->op_flags |= OPf_STACKED;
2696         break;
2697     case OP_PADHV:
2698         if (o->op_flags & OPf_PARENS) goto parenhash;
2699         o->op_private |= OPpLVREF_HV;
2700         /* FALLTHROUGH */
2701     case OP_PADSV:
2702         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2703         break;
2704     case OP_PADAV:
2705         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2706         if (o->op_flags & OPf_PARENS) goto slurpy;
2707         o->op_private |= OPpLVREF_AV;
2708         break;
2709     case OP_AELEM:
2710     case OP_HELEM:
2711         o->op_private |= OPpLVREF_ELEM;
2712         o->op_flags   |= OPf_STACKED;
2713         break;
2714     case OP_ASLICE:
2715     case OP_HSLICE:
2716         CHANGE_TYPE(o, OP_LVREFSLICE);
2717         o->op_private &= OPpLVAL_INTRO|OPpLVREF_ELEM;
2718         return;
2719     case OP_NULL:
2720         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
2721             goto badref;
2722         else if (!(o->op_flags & OPf_KIDS))
2723             return;
2724         if (o->op_targ != OP_LIST) {
2725             S_lvref(aTHX_ cBINOPo->op_first, type);
2726             return;
2727         }
2728         /* FALLTHROUGH */
2729     case OP_LIST:
2730         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
2731             assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
2732             S_lvref(aTHX_ kid, type);
2733         }
2734         return;
2735     case OP_STUB:
2736         if (o->op_flags & OPf_PARENS)
2737             return;
2738         /* FALLTHROUGH */
2739     default:
2740       badref:
2741         /* diag_listed_as: Can't modify reference to %s in %s assignment */
2742         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
2743                      o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
2744                       ? "do block"
2745                       : OP_DESC(o),
2746                      PL_op_desc[type]));
2747         return;
2748     }
2749     CHANGE_TYPE(o, OP_LVREF);
2750     o->op_private &=
2751         OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
2752     if (type == OP_ENTERLOOP)
2753         o->op_private |= OPpLVREF_ITER;
2754 }
2755
2756 OP *
2757 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
2758 {
2759     dVAR;
2760     OP *kid;
2761     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2762     int localize = -1;
2763
2764     if (!o || (PL_parser && PL_parser->error_count))
2765         return o;
2766
2767     if ((o->op_private & OPpTARGET_MY)
2768         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2769     {
2770         return o;
2771     }
2772
2773     assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2774
2775     if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2776
2777     switch (o->op_type) {
2778     case OP_UNDEF:
2779         PL_modcount++;
2780         return o;
2781     case OP_STUB:
2782         if ((o->op_flags & OPf_PARENS))
2783             break;
2784         goto nomod;
2785     case OP_ENTERSUB:
2786         if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
2787             !(o->op_flags & OPf_STACKED)) {
2788             CHANGE_TYPE(o, OP_RV2CV);           /* entersub => rv2cv */
2789             assert(cUNOPo->op_first->op_type == OP_NULL);
2790             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
2791             break;
2792         }
2793         else {                          /* lvalue subroutine call */
2794             o->op_private |= OPpLVAL_INTRO;
2795             PL_modcount = RETURN_UNLIMITED_NUMBER;
2796             if (type == OP_GREPSTART || type == OP_ENTERSUB
2797              || type == OP_REFGEN    || type == OP_LEAVESUBLV) {
2798                 /* Potential lvalue context: */
2799                 o->op_private |= OPpENTERSUB_INARGS;
2800                 break;
2801             }
2802             else {                      /* Compile-time error message: */
2803                 OP *kid = cUNOPo->op_first;
2804                 CV *cv;
2805                 GV *gv;
2806
2807                 if (kid->op_type != OP_PUSHMARK) {
2808                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2809                         Perl_croak(aTHX_
2810                                 "panic: unexpected lvalue entersub "
2811                                 "args: type/targ %ld:%"UVuf,
2812                                 (long)kid->op_type, (UV)kid->op_targ);
2813                     kid = kLISTOP->op_first;
2814                 }
2815                 while (OpHAS_SIBLING(kid))
2816                     kid = OpSIBLING(kid);
2817                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
2818                     break;      /* Postpone until runtime */
2819                 }
2820
2821                 kid = kUNOP->op_first;
2822                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2823                     kid = kUNOP->op_first;
2824                 if (kid->op_type == OP_NULL)
2825                     Perl_croak(aTHX_
2826                                "Unexpected constant lvalue entersub "
2827                                "entry via type/targ %ld:%"UVuf,
2828                                (long)kid->op_type, (UV)kid->op_targ);
2829                 if (kid->op_type != OP_GV) {
2830                     break;
2831                 }
2832
2833                 gv = kGVOP_gv;
2834                 cv = isGV(gv)
2835                     ? GvCV(gv)
2836                     : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
2837                         ? MUTABLE_CV(SvRV(gv))
2838                         : NULL;
2839                 if (!cv)
2840                     break;
2841                 if (CvLVALUE(cv))
2842                     break;
2843             }
2844         }
2845         /* FALLTHROUGH */
2846     default:
2847       nomod:
2848         if (flags & OP_LVALUE_NO_CROAK) return NULL;
2849         /* grep, foreach, subcalls, refgen */
2850         if (type == OP_GREPSTART || type == OP_ENTERSUB
2851          || type == OP_REFGEN    || type == OP_LEAVESUBLV)
2852             break;
2853         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2854                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
2855                       ? "do block"
2856                       : (o->op_type == OP_ENTERSUB
2857                         ? "non-lvalue subroutine call"
2858                         : OP_DESC(o))),
2859                      type ? PL_op_desc[type] : "local"));
2860         return o;
2861
2862     case OP_PREINC:
2863     case OP_PREDEC:
2864     case OP_POW:
2865     case OP_MULTIPLY:
2866     case OP_DIVIDE:
2867     case OP_MODULO:
2868     case OP_ADD:
2869     case OP_SUBTRACT:
2870     case OP_CONCAT:
2871     case OP_LEFT_SHIFT:
2872     case OP_RIGHT_SHIFT:
2873     case OP_BIT_AND:
2874     case OP_BIT_XOR:
2875     case OP_BIT_OR:
2876     case OP_I_MULTIPLY:
2877     case OP_I_DIVIDE:
2878     case OP_I_MODULO:
2879     case OP_I_ADD:
2880     case OP_I_SUBTRACT:
2881         if (!(o->op_flags & OPf_STACKED))
2882             goto nomod;
2883         PL_modcount++;
2884         break;
2885
2886     case OP_REPEAT:
2887         if (o->op_flags & OPf_STACKED) {
2888             PL_modcount++;
2889             break;
2890         }
2891         if (!(o->op_private & OPpREPEAT_DOLIST))
2892             goto nomod;
2893         else {
2894             const I32 mods = PL_modcount;
2895             modkids(cBINOPo->op_first, type);
2896             if (type != OP_AASSIGN)
2897                 goto nomod;
2898             kid = cBINOPo->op_last;
2899             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
2900                 const IV iv = SvIV(kSVOP_sv);
2901                 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
2902                     PL_modcount =
2903                         mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
2904             }
2905             else
2906                 PL_modcount = RETURN_UNLIMITED_NUMBER;
2907         }
2908         break;
2909
2910     case OP_COND_EXPR:
2911         localize = 1;
2912         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2913             op_lvalue(kid, type);
2914         break;
2915
2916     case OP_RV2AV:
2917     case OP_RV2HV:
2918         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
2919            PL_modcount = RETURN_UNLIMITED_NUMBER;
2920             return o;           /* Treat \(@foo) like ordinary list. */
2921         }
2922         /* FALLTHROUGH */
2923     case OP_RV2GV:
2924         if (scalar_mod_type(o, type))
2925             goto nomod;
2926         ref(cUNOPo->op_first, o->op_type);
2927         /* FALLTHROUGH */
2928     case OP_ASLICE:
2929     case OP_HSLICE:
2930         localize = 1;
2931         /* FALLTHROUGH */
2932     case OP_AASSIGN:
2933         /* Do not apply the lvsub flag for rv2[ah]v in scalar context.  */
2934         if (type == OP_LEAVESUBLV && (
2935                 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
2936              || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2937            ))
2938             o->op_private |= OPpMAYBE_LVSUB;
2939         /* FALLTHROUGH */
2940     case OP_NEXTSTATE:
2941     case OP_DBSTATE:
2942        PL_modcount = RETURN_UNLIMITED_NUMBER;
2943         break;
2944     case OP_KVHSLICE:
2945     case OP_KVASLICE:
2946         if (type == OP_LEAVESUBLV)
2947             o->op_private |= OPpMAYBE_LVSUB;
2948         goto nomod;
2949     case OP_AV2ARYLEN:
2950         PL_hints |= HINT_BLOCK_SCOPE;
2951         if (type == OP_LEAVESUBLV)
2952             o->op_private |= OPpMAYBE_LVSUB;
2953         PL_modcount++;
2954         break;
2955     case OP_RV2SV:
2956         ref(cUNOPo->op_first, o->op_type);
2957         localize = 1;
2958         /* FALLTHROUGH */
2959     case OP_GV:
2960         PL_hints |= HINT_BLOCK_SCOPE;
2961         /* FALLTHROUGH */
2962     case OP_SASSIGN:
2963     case OP_ANDASSIGN:
2964     case OP_ORASSIGN:
2965     case OP_DORASSIGN:
2966         PL_modcount++;
2967         break;
2968
2969     case OP_AELEMFAST:
2970     case OP_AELEMFAST_LEX:
2971         localize = -1;
2972         PL_modcount++;
2973         break;
2974
2975     case OP_PADAV:
2976     case OP_PADHV:
2977        PL_modcount = RETURN_UNLIMITED_NUMBER;
2978         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
2979             return o;           /* Treat \(@foo) like ordinary list. */
2980         if (scalar_mod_type(o, type))
2981             goto nomod;
2982         if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2983           && type == OP_LEAVESUBLV)
2984             o->op_private |= OPpMAYBE_LVSUB;
2985         /* FALLTHROUGH */
2986     case OP_PADSV:
2987         PL_modcount++;
2988         if (!type) /* local() */
2989             Perl_croak(aTHX_ "Can't localize lexical variable %"PNf,
2990                               PNfARG(PAD_COMPNAME(o->op_targ)));
2991         if (!(o->op_private & OPpLVAL_INTRO)
2992          || (  type != OP_SASSIGN && type != OP_AASSIGN
2993             && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ))  ))
2994             S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
2995         break;
2996
2997     case OP_PUSHMARK:
2998         localize = 0;
2999         break;
3000
3001     case OP_KEYS:
3002     case OP_RKEYS:
3003         if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
3004             goto nomod;
3005         goto lvalue_func;
3006     case OP_SUBSTR:
3007         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
3008             goto nomod;
3009         /* FALLTHROUGH */
3010     case OP_POS:
3011     case OP_VEC:
3012       lvalue_func:
3013         if (type == OP_LEAVESUBLV)
3014             o->op_private |= OPpMAYBE_LVSUB;
3015         if (o->op_flags & OPf_KIDS)
3016             op_lvalue(OpSIBLING(cBINOPo->op_first), type);
3017         break;
3018
3019     case OP_AELEM:
3020     case OP_HELEM:
3021         ref(cBINOPo->op_first, o->op_type);
3022         if (type == OP_ENTERSUB &&
3023              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
3024             o->op_private |= OPpLVAL_DEFER;
3025         if (type == OP_LEAVESUBLV)
3026             o->op_private |= OPpMAYBE_LVSUB;
3027         localize = 1;
3028         PL_modcount++;
3029         break;
3030
3031     case OP_LEAVE:
3032     case OP_LEAVELOOP:
3033         o->op_private |= OPpLVALUE;
3034         /* FALLTHROUGH */
3035     case OP_SCOPE:
3036     case OP_ENTER:
3037     case OP_LINESEQ:
3038         localize = 0;
3039         if (o->op_flags & OPf_KIDS)
3040             op_lvalue(cLISTOPo->op_last, type);
3041         break;
3042
3043     case OP_NULL:
3044         localize = 0;
3045         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
3046             goto nomod;
3047         else if (!(o->op_flags & OPf_KIDS))
3048             break;
3049         if (o->op_targ != OP_LIST) {
3050             op_lvalue(cBINOPo->op_first, type);
3051             break;
3052         }
3053         /* FALLTHROUGH */
3054     case OP_LIST:
3055         localize = 0;
3056         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3057             /* elements might be in void context because the list is
3058                in scalar context or because they are attribute sub calls */
3059             if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
3060                 op_lvalue(kid, type);
3061         break;
3062
3063     case OP_COREARGS:
3064         return o;
3065
3066     case OP_AND:
3067     case OP_OR:
3068         if (type == OP_LEAVESUBLV
3069          || !S_vivifies(cLOGOPo->op_first->op_type))
3070             op_lvalue(cLOGOPo->op_first, type);
3071         if (type == OP_LEAVESUBLV
3072          || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
3073             op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
3074         goto nomod;
3075
3076     case OP_SREFGEN:
3077         if (type != OP_AASSIGN && type != OP_SASSIGN
3078          && type != OP_ENTERLOOP)
3079             goto nomod;
3080         /* Don’t bother applying lvalue context to the ex-list.  */
3081         kid = cUNOPx(cUNOPo->op_first)->op_first;
3082         assert (!OpHAS_SIBLING(kid));
3083         goto kid_2lvref;
3084     case OP_REFGEN:
3085         if (type != OP_AASSIGN) goto nomod;
3086         kid = cUNOPo->op_first;
3087       kid_2lvref:
3088         {
3089             const U8 ec = PL_parser ? PL_parser->error_count : 0;
3090             S_lvref(aTHX_ kid, type);
3091             if (!PL_parser || PL_parser->error_count == ec) {
3092                 if (!FEATURE_REFALIASING_IS_ENABLED)
3093                     Perl_croak(aTHX_
3094                        "Experimental aliasing via reference not enabled");
3095                 Perl_ck_warner_d(aTHX_
3096                                  packWARN(WARN_EXPERIMENTAL__REFALIASING),
3097                                 "Aliasing via reference is experimental");
3098             }
3099         }
3100         if (o->op_type == OP_REFGEN)
3101             op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
3102         op_null(o);
3103         return o;
3104
3105     case OP_SPLIT:
3106         kid = cLISTOPo->op_first;
3107         if (kid && kid->op_type == OP_PUSHRE &&
3108                 (  kid->op_targ
3109                 || o->op_flags & OPf_STACKED
3110 #ifdef USE_ITHREADS
3111                 || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
3112 #else
3113                 || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
3114 #endif
3115         )) {
3116             /* This is actually @array = split.  */
3117             PL_modcount = RETURN_UNLIMITED_NUMBER;
3118             break;
3119         }
3120         goto nomod;
3121
3122     case OP_SCALAR:
3123         op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
3124         goto nomod;
3125     }
3126
3127     /* [20011101.069] File test operators interpret OPf_REF to mean that
3128        their argument is a filehandle; thus \stat(".") should not set
3129        it. AMS 20011102 */
3130     if (type == OP_REFGEN &&
3131         PL_check[o->op_type] == Perl_ck_ftst)
3132         return o;
3133
3134     if (type != OP_LEAVESUBLV)
3135         o->op_flags |= OPf_MOD;
3136
3137     if (type == OP_AASSIGN || type == OP_SASSIGN)
3138         o->op_flags |= OPf_SPECIAL|OPf_REF;
3139     else if (!type) { /* local() */
3140         switch (localize) {
3141         case 1:
3142             o->op_private |= OPpLVAL_INTRO;
3143             o->op_flags &= ~OPf_SPECIAL;
3144             PL_hints |= HINT_BLOCK_SCOPE;
3145             break;
3146         case 0:
3147             break;
3148         case -1:
3149             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
3150                            "Useless localization of %s", OP_DESC(o));
3151         }
3152     }
3153     else if (type != OP_GREPSTART && type != OP_ENTERSUB
3154              && type != OP_LEAVESUBLV)
3155         o->op_flags |= OPf_REF;
3156     return o;
3157 }
3158
3159 STATIC bool
3160 S_scalar_mod_type(const OP *o, I32 type)
3161 {
3162     switch (type) {
3163     case OP_POS:
3164     case OP_SASSIGN:
3165         if (o && o->op_type == OP_RV2GV)
3166             return FALSE;
3167         /* FALLTHROUGH */
3168     case OP_PREINC:
3169     case OP_PREDEC:
3170     case OP_POSTINC:
3171     case OP_POSTDEC:
3172     case OP_I_PREINC:
3173     case OP_I_PREDEC:
3174     case OP_I_POSTINC:
3175     case OP_I_POSTDEC:
3176     case OP_POW:
3177     case OP_MULTIPLY:
3178     case OP_DIVIDE:
3179     case OP_MODULO:
3180     case OP_REPEAT:
3181     case OP_ADD:
3182     case OP_SUBTRACT:
3183     case OP_I_MULTIPLY:
3184     case OP_I_DIVIDE:
3185     case OP_I_MODULO:
3186     case OP_I_ADD:
3187     case OP_I_SUBTRACT:
3188     case OP_LEFT_SHIFT:
3189     case OP_RIGHT_SHIFT:
3190     case OP_BIT_AND:
3191     case OP_BIT_XOR:
3192     case OP_BIT_OR:
3193     case OP_CONCAT:
3194     case OP_SUBST:
3195     case OP_TRANS:
3196     case OP_TRANSR:
3197     case OP_READ:
3198     case OP_SYSREAD:
3199     case OP_RECV:
3200     case OP_ANDASSIGN:
3201     case OP_ORASSIGN:
3202     case OP_DORASSIGN:
3203         return TRUE;
3204     default:
3205         return FALSE;
3206     }
3207 }
3208
3209 STATIC bool
3210 S_is_handle_constructor(const OP *o, I32 numargs)
3211 {
3212     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
3213
3214     switch (o->op_type) {
3215     case OP_PIPE_OP:
3216     case OP_SOCKPAIR:
3217         if (numargs == 2)
3218             return TRUE;
3219         /* FALLTHROUGH */
3220     case OP_SYSOPEN:
3221     case OP_OPEN:
3222     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
3223     case OP_SOCKET:
3224     case OP_OPEN_DIR:
3225     case OP_ACCEPT:
3226         if (numargs == 1)
3227             return TRUE;
3228         /* FALLTHROUGH */
3229     default:
3230         return FALSE;
3231     }
3232 }
3233
3234 static OP *
3235 S_refkids(pTHX_ OP *o, I32 type)
3236 {
3237     if (o && o->op_flags & OPf_KIDS) {
3238         OP *kid;
3239         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3240             ref(kid, type);
3241     }
3242     return o;
3243 }
3244
3245 OP *
3246 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
3247 {
3248     dVAR;
3249     OP *kid;
3250
3251     PERL_ARGS_ASSERT_DOREF;
3252
3253     if (!o || (PL_parser && PL_parser->error_count))
3254         return o;
3255
3256     switch (o->op_type) {
3257     case OP_ENTERSUB:
3258         if ((type == OP_EXISTS || type == OP_DEFINED) &&
3259             !(o->op_flags & OPf_STACKED)) {
3260             CHANGE_TYPE(o, OP_RV2CV);             /* entersub => rv2cv */
3261             assert(cUNOPo->op_first->op_type == OP_NULL);
3262             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
3263             o->op_flags |= OPf_SPECIAL;
3264         }
3265         else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
3266             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3267                               : type == OP_RV2HV ? OPpDEREF_HV
3268                               : OPpDEREF_SV);
3269             o->op_flags |= OPf_MOD;
3270         }
3271
3272         break;
3273
3274     case OP_COND_EXPR:
3275         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
3276             doref(kid, type, set_op_ref);
3277         break;
3278     case OP_RV2SV:
3279         if (type == OP_DEFINED)
3280             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
3281         doref(cUNOPo->op_first, o->op_type, set_op_ref);
3282         /* FALLTHROUGH */
3283     case OP_PADSV:
3284         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3285             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3286                               : type == OP_RV2HV ? OPpDEREF_HV
3287                               : OPpDEREF_SV);
3288             o->op_flags |= OPf_MOD;
3289         }
3290         break;
3291
3292     case OP_RV2AV:
3293     case OP_RV2HV:
3294         if (set_op_ref)
3295             o->op_flags |= OPf_REF;
3296         /* FALLTHROUGH */
3297     case OP_RV2GV:
3298         if (type == OP_DEFINED)
3299             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
3300         doref(cUNOPo->op_first, o->op_type, set_op_ref);
3301         break;
3302
3303     case OP_PADAV:
3304     case OP_PADHV:
3305         if (set_op_ref)
3306             o->op_flags |= OPf_REF;
3307         break;
3308
3309     case OP_SCALAR:
3310     case OP_NULL:
3311         if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
3312             break;
3313         doref(cBINOPo->op_first, type, set_op_ref);
3314         break;
3315     case OP_AELEM:
3316     case OP_HELEM:
3317         doref(cBINOPo->op_first, o->op_type, set_op_ref);
3318         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3319             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3320                               : type == OP_RV2HV ? OPpDEREF_HV
3321                               : OPpDEREF_SV);
3322             o->op_flags |= OPf_MOD;
3323         }
3324         break;
3325
3326     case OP_SCOPE:
3327     case OP_LEAVE:
3328         set_op_ref = FALSE;
3329         /* FALLTHROUGH */
3330     case OP_ENTER:
3331     case OP_LIST:
3332         if (!(o->op_flags & OPf_KIDS))
3333             break;
3334         doref(cLISTOPo->op_last, type, set_op_ref);
3335         break;
3336     default:
3337         break;
3338     }
3339     return scalar(o);
3340
3341 }
3342
3343 STATIC OP *
3344 S_dup_attrlist(pTHX_ OP *o)
3345 {
3346     OP *rop;
3347
3348     PERL_ARGS_ASSERT_DUP_ATTRLIST;
3349
3350     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
3351      * where the first kid is OP_PUSHMARK and the remaining ones
3352      * are OP_CONST.  We need to push the OP_CONST values.
3353      */
3354     if (o->op_type == OP_CONST)
3355         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
3356     else {
3357         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
3358         rop = NULL;
3359         for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
3360             if (o->op_type == OP_CONST)
3361                 rop = op_append_elem(OP_LIST, rop,
3362                                   newSVOP(OP_CONST, o->op_flags,
3363                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
3364         }
3365     }
3366     return rop;
3367 }
3368
3369 STATIC void
3370 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
3371 {
3372     SV * const stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
3373
3374     PERL_ARGS_ASSERT_APPLY_ATTRS;
3375
3376     /* fake up C<use attributes $pkg,$rv,@attrs> */
3377
3378 #define ATTRSMODULE "attributes"
3379 #define ATTRSMODULE_PM "attributes.pm"
3380
3381     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3382                          newSVpvs(ATTRSMODULE),
3383                          NULL,
3384                          op_prepend_elem(OP_LIST,
3385                                       newSVOP(OP_CONST, 0, stashsv),
3386                                       op_prepend_elem(OP_LIST,
3387                                                    newSVOP(OP_CONST, 0,
3388                                                            newRV(target)),
3389                                                    dup_attrlist(attrs))));
3390 }
3391
3392 STATIC void
3393 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
3394 {
3395     OP *pack, *imop, *arg;
3396     SV *meth, *stashsv, **svp;
3397
3398     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
3399
3400     if (!attrs)
3401         return;
3402
3403     assert(target->op_type == OP_PADSV ||
3404            target->op_type == OP_PADHV ||
3405            target->op_type == OP_PADAV);
3406
3407     /* Ensure that attributes.pm is loaded. */
3408     /* Don't force the C<use> if we don't need it. */
3409     svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
3410     if (svp && *svp != &PL_sv_undef)
3411         NOOP;   /* already in %INC */
3412     else
3413         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
3414                                newSVpvs(ATTRSMODULE), NULL);
3415
3416     /* Need package name for method call. */
3417     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
3418
3419     /* Build up the real arg-list. */
3420     stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
3421
3422     arg = newOP(OP_PADSV, 0);
3423     arg->op_targ = target->op_targ;
3424     arg = op_prepend_elem(OP_LIST,
3425                        newSVOP(OP_CONST, 0, stashsv),
3426                        op_prepend_elem(OP_LIST,
3427                                     newUNOP(OP_REFGEN, 0,
3428                                             op_lvalue(arg, OP_REFGEN)),
3429                                     dup_attrlist(attrs)));
3430
3431     /* Fake up a method call to import */
3432     meth = newSVpvs_share("import");
3433     imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
3434                    op_append_elem(OP_LIST,
3435                                op_prepend_elem(OP_LIST, pack, arg),
3436                                newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
3437
3438     /* Combine the ops. */
3439     *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
3440 }
3441
3442 /*
3443 =notfor apidoc apply_attrs_string
3444
3445 Attempts to apply a list of attributes specified by the C<attrstr> and
3446 C<len> arguments to the subroutine identified by the C<cv> argument which
3447 is expected to be associated with the package identified by the C<stashpv>
3448 argument (see L<attributes>).  It gets this wrong, though, in that it
3449 does not correctly identify the boundaries of the individual attribute
3450 specifications within C<attrstr>.  This is not really intended for the
3451 public API, but has to be listed here for systems such as AIX which
3452 need an explicit export list for symbols.  (It's called from XS code
3453 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
3454 to respect attribute syntax properly would be welcome.
3455
3456 =cut
3457 */
3458
3459 void
3460 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
3461                         const char *attrstr, STRLEN len)
3462 {
3463     OP *attrs = NULL;
3464
3465     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
3466
3467     if (!len) {
3468         len = strlen(attrstr);
3469     }
3470
3471     while (len) {
3472         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
3473         if (len) {
3474             const char * const sstr = attrstr;
3475             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
3476             attrs = op_append_elem(OP_LIST, attrs,
3477                                 newSVOP(OP_CONST, 0,
3478                                         newSVpvn(sstr, attrstr-sstr)));
3479         }
3480     }
3481
3482     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3483                      newSVpvs(ATTRSMODULE),
3484                      NULL, op_prepend_elem(OP_LIST,
3485                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
3486                                   op_prepend_elem(OP_LIST,
3487                                                newSVOP(OP_CONST, 0,
3488                                                        newRV(MUTABLE_SV(cv))),
3489                                                attrs)));
3490 }
3491
3492 STATIC void
3493 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
3494 {
3495     OP *new_proto = NULL;
3496     STRLEN pvlen;
3497     char *pv;
3498     OP *o;
3499
3500     PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
3501
3502     if (!*attrs)
3503         return;
3504
3505     o = *attrs;
3506     if (o->op_type == OP_CONST) {
3507         pv = SvPV(cSVOPo_sv, pvlen);
3508         if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3509             SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3510             SV ** const tmpo = cSVOPx_svp(o);
3511             SvREFCNT_dec(cSVOPo_sv);
3512             *tmpo = tmpsv;
3513             new_proto = o;
3514             *attrs = NULL;
3515         }
3516     } else if (o->op_type == OP_LIST) {
3517         OP * lasto;
3518         assert(o->op_flags & OPf_KIDS);
3519         lasto = cLISTOPo->op_first;
3520         assert(lasto->op_type == OP_PUSHMARK);
3521         for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
3522             if (o->op_type == OP_CONST) {
3523                 pv = SvPV(cSVOPo_sv, pvlen);
3524                 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3525                     SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3526                     SV ** const tmpo = cSVOPx_svp(o);
3527                     SvREFCNT_dec(cSVOPo_sv);
3528                     *tmpo = tmpsv;
3529                     if (new_proto && ckWARN(WARN_MISC)) {
3530                         STRLEN new_len;
3531                         const char * newp = SvPV(cSVOPo_sv, new_len);
3532                         Perl_warner(aTHX_ packWARN(WARN_MISC),
3533                             "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub",
3534                             UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
3535                         op_free(new_proto);
3536                     }
3537                     else if (new_proto)
3538                         op_free(new_proto);
3539                     new_proto = o;
3540                     /* excise new_proto from the list */
3541                     op_sibling_splice(*attrs, lasto, 1, NULL);
3542                     o = lasto;
3543                     continue;
3544                 }
3545             }
3546             lasto = o;
3547         }
3548         /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
3549            would get pulled in with no real need */
3550         if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
3551             op_free(*attrs);
3552             *attrs = NULL;
3553         }
3554     }
3555
3556     if (new_proto) {
3557         SV *svname;
3558         if (isGV(name)) {
3559             svname = sv_newmortal();
3560             gv_efullname3(svname, name, NULL);
3561         }
3562         else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
3563             svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
3564         else
3565             svname = (SV *)name;
3566         if (ckWARN(WARN_ILLEGALPROTO))
3567             (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
3568         if (*proto && ckWARN(WARN_PROTOTYPE)) {
3569             STRLEN old_len, new_len;
3570             const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
3571             const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
3572
3573             Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3574                 "Prototype '%"UTF8f"' overridden by attribute 'prototype(%"UTF8f")'"
3575                 " in %"SVf,
3576                 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
3577                 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
3578                 SVfARG(svname));
3579         }
3580         if (*proto)
3581             op_free(*proto);
3582         *proto = new_proto;
3583     }
3584 }
3585
3586 static void
3587 S_cant_declare(pTHX_ OP *o)
3588 {
3589     if (o->op_type == OP_NULL
3590      && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
3591         o = cUNOPo->op_first;
3592     yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
3593                              o->op_type == OP_NULL
3594                                && o->op_flags & OPf_SPECIAL
3595                                  ? "do block"
3596                                  : OP_DESC(o),
3597                              PL_parser->in_my == KEY_our   ? "our"   :
3598                              PL_parser->in_my == KEY_state ? "state" :
3599                                                              "my"));
3600 }
3601
3602 STATIC OP *
3603 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
3604 {
3605     I32 type;
3606     const bool stately = PL_parser && PL_parser->in_my == KEY_state;
3607
3608     PERL_ARGS_ASSERT_MY_KID;
3609
3610     if (!o || (PL_parser && PL_parser->error_count))
3611         return o;
3612
3613     type = o->op_type;
3614
3615     if (type == OP_LIST) {
3616         OP *kid;
3617         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3618             my_kid(kid, attrs, imopsp);
3619         return o;
3620     } else if (type == OP_UNDEF || type == OP_STUB) {
3621         return o;
3622     } else if (type == OP_RV2SV ||      /* "our" declaration */
3623                type == OP_RV2AV ||
3624                type == OP_RV2HV) { /* XXX does this let anything illegal in? */
3625         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
3626             S_cant_declare(aTHX_ o);
3627         } else if (attrs) {
3628             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
3629             assert(PL_parser);
3630             PL_parser->in_my = FALSE;
3631             PL_parser->in_my_stash = NULL;
3632             apply_attrs(GvSTASH(gv),
3633                         (type == OP_RV2SV ? GvSV(gv) :
3634                          type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
3635                          type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
3636                         attrs);
3637         }
3638         o->op_private |= OPpOUR_INTRO;
3639         return o;
3640     }
3641     else if (type != OP_PADSV &&
3642              type != OP_PADAV &&
3643              type != OP_PADHV &&
3644              type != OP_PUSHMARK)
3645     {
3646         S_cant_declare(aTHX_ o);
3647         return o;
3648     }
3649     else if (attrs && type != OP_PUSHMARK) {
3650         HV *stash;
3651
3652         assert(PL_parser);
3653         PL_parser->in_my = FALSE;
3654         PL_parser->in_my_stash = NULL;
3655
3656         /* check for C<my Dog $spot> when deciding package */
3657         stash = PAD_COMPNAME_TYPE(o->op_targ);
3658         if (!stash)
3659             stash = PL_curstash;
3660         apply_attrs_my(stash, o, attrs, imopsp);
3661     }
3662     o->op_flags |= OPf_MOD;
3663     o->op_private |= OPpLVAL_INTRO;
3664     if (stately)
3665         o->op_private |= OPpPAD_STATE;
3666     return o;
3667 }
3668
3669 OP *
3670 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
3671 {
3672     OP *rops;
3673     int maybe_scalar = 0;
3674
3675     PERL_ARGS_ASSERT_MY_ATTRS;
3676
3677 /* [perl #17376]: this appears to be premature, and results in code such as
3678    C< our(%x); > executing in list mode rather than void mode */
3679 #if 0
3680     if (o->op_flags & OPf_PARENS)
3681         list(o);
3682     else
3683         maybe_scalar = 1;
3684 #else
3685     maybe_scalar = 1;
3686 #endif
3687     if (attrs)
3688         SAVEFREEOP(attrs);
3689     rops = NULL;
3690     o = my_kid(o, attrs, &rops);
3691     if (rops) {
3692         if (maybe_scalar && o->op_type == OP_PADSV) {
3693             o = scalar(op_append_list(OP_LIST, rops, o));
3694             o->op_private |= OPpLVAL_INTRO;
3695         }
3696         else {
3697             /* The listop in rops might have a pushmark at the beginning,
3698                which will mess up list assignment. */
3699             LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
3700             if (rops->op_type == OP_LIST &&
3701                 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
3702             {
3703                 OP * const pushmark = lrops->op_first;
3704                 /* excise pushmark */
3705                 op_sibling_splice(rops, NULL, 1, NULL);
3706                 op_free(pushmark);
3707             }
3708             o = op_append_list(OP_LIST, o, rops);
3709         }
3710     }
3711     PL_parser->in_my = FALSE;
3712     PL_parser->in_my_stash = NULL;
3713     return o;
3714 }
3715
3716 OP *
3717 Perl_sawparens(pTHX_ OP *o)
3718 {
3719     PERL_UNUSED_CONTEXT;
3720     if (o)
3721         o->op_flags |= OPf_PARENS;
3722     return o;
3723 }
3724
3725 OP *
3726 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
3727 {
3728     OP *o;
3729     bool ismatchop = 0;
3730     const OPCODE ltype = left->op_type;
3731     const OPCODE rtype = right->op_type;
3732
3733     PERL_ARGS_ASSERT_BIND_MATCH;
3734
3735     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
3736           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
3737     {
3738       const char * const desc
3739           = PL_op_desc[(
3740                           rtype == OP_SUBST || rtype == OP_TRANS
3741                        || rtype == OP_TRANSR
3742                        )
3743                        ? (int)rtype : OP_MATCH];
3744       const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
3745       SV * const name =
3746         S_op_varname(aTHX_ left);
3747       if (name)
3748         Perl_warner(aTHX_ packWARN(WARN_MISC),
3749              "Applying %s to %"SVf" will act on scalar(%"SVf")",
3750              desc, SVfARG(name), SVfARG(name));
3751       else {
3752         const char * const sample = (isary
3753              ? "@array" : "%hash");
3754         Perl_warner(aTHX_ packWARN(WARN_MISC),
3755              "Applying %s to %s will act on scalar(%s)",
3756              desc, sample, sample);
3757       }
3758     }
3759
3760     if (rtype == OP_CONST &&
3761         cSVOPx(right)->op_private & OPpCONST_BARE &&
3762         cSVOPx(right)->op_private & OPpCONST_STRICT)
3763     {
3764         no_bareword_allowed(right);
3765     }
3766
3767     /* !~ doesn't make sense with /r, so error on it for now */
3768     if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
3769         type == OP_NOT)
3770         /* diag_listed_as: Using !~ with %s doesn't make sense */
3771         yyerror("Using !~ with s///r doesn't make sense");
3772     if (rtype == OP_TRANSR && type == OP_NOT)
3773         /* diag_listed_as: Using !~ with %s doesn't make sense */
3774         yyerror("Using !~ with tr///r doesn't make sense");
3775
3776     ismatchop = (rtype == OP_MATCH ||
3777                  rtype == OP_SUBST ||
3778                  rtype == OP_TRANS || rtype == OP_TRANSR)
3779              && !(right->op_flags & OPf_SPECIAL);
3780     if (ismatchop && right->op_private & OPpTARGET_MY) {
3781         right->op_targ = 0;
3782         right->op_private &= ~OPpTARGET_MY;
3783     }
3784     if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
3785         if (left->op_type == OP_PADSV
3786          && !(left->op_private & OPpLVAL_INTRO))
3787         {
3788             right->op_targ = left->op_targ;
3789             op_free(left);
3790             o = right;
3791         }
3792         else {
3793             right->op_flags |= OPf_STACKED;
3794             if (rtype != OP_MATCH && rtype != OP_TRANSR &&
3795             ! (rtype == OP_TRANS &&
3796                right->op_private & OPpTRANS_IDENTICAL) &&
3797             ! (rtype == OP_SUBST &&
3798                (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3799                 left = op_lvalue(left, rtype);
3800             if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
3801                 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
3802             else
3803                 o = op_prepend_elem(rtype, scalar(left), right);
3804         }
3805         if (type == OP_NOT)
3806             return newUNOP(OP_NOT, 0, scalar(o));
3807         return o;
3808     }
3809     else
3810         return bind_match(type, left,
3811                 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
3812 }
3813
3814 OP *
3815 Perl_invert(pTHX_ OP *o)
3816 {
3817     if (!o)
3818         return NULL;
3819     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
3820 }
3821
3822 /*
3823 =for apidoc Amx|OP *|op_scope|OP *o
3824
3825 Wraps up an op tree with some additional ops so that at runtime a dynamic
3826 scope will be created.  The original ops run in the new dynamic scope,
3827 and then, provided that they exit normally, the scope will be unwound.
3828 The additional ops used to create and unwind the dynamic scope will
3829 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
3830 instead if the ops are simple enough to not need the full dynamic scope
3831 structure.
3832
3833 =cut
3834 */
3835
3836 OP *
3837 Perl_op_scope(pTHX_ OP *o)
3838 {
3839     dVAR;
3840     if (o) {
3841         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
3842             o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
3843             CHANGE_TYPE(o, OP_LEAVE);
3844         }
3845         else if (o->op_type == OP_LINESEQ) {
3846             OP *kid;
3847             CHANGE_TYPE(o, OP_SCOPE);
3848             kid = ((LISTOP*)o)->op_first;
3849             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
3850                 op_null(kid);
3851
3852                 /* The following deals with things like 'do {1 for 1}' */
3853                 kid = OpSIBLING(kid);
3854                 if (kid &&
3855                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
3856                     op_null(kid);
3857             }
3858         }
3859         else
3860             o = newLISTOP(OP_SCOPE, 0, o, NULL);
3861     }
3862     return o;
3863 }
3864
3865 OP *
3866 Perl_op_unscope(pTHX_ OP *o)
3867 {
3868     if (o && o->op_type == OP_LINESEQ) {
3869         OP *kid = cLISTOPo->op_first;
3870         for(; kid; kid = OpSIBLING(kid))
3871             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
3872                 op_null(kid);
3873     }
3874     return o;
3875 }
3876
3877 /*
3878 =for apidoc Am|int|block_start|int full
3879
3880 Handles compile-time scope entry.
3881 Arranges for hints to be restored on block
3882 exit and also handles pad sequence numbers to make lexical variables scope
3883 right.  Returns a savestack index for use with C<block_end>.
3884
3885 =cut
3886 */
3887
3888 int
3889 Perl_block_start(pTHX_ int full)
3890 {
3891     const int retval = PL_savestack_ix;
3892
3893     PL_compiling.cop_seq = PL_cop_seqmax;
3894     COP_SEQMAX_INC;
3895     pad_block_start(full);
3896     SAVEHINTS();
3897     PL_hints &= ~HINT_BLOCK_SCOPE;
3898     SAVECOMPILEWARNINGS();
3899     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
3900     SAVEI32(PL_compiling.cop_seq);
3901     PL_compiling.cop_seq = 0;
3902
3903     CALL_BLOCK_HOOKS(bhk_start, full);
3904
3905     return retval;
3906 }
3907
3908 /*
3909 =for apidoc Am|OP *|block_end|I32 floor|OP *seq
3910
3911 Handles compile-time scope exit.  I<floor>
3912 is the savestack index returned by
3913 C<block_start>, and I<seq> is the body of the block.  Returns the block,
3914 possibly modified.
3915
3916 =cut
3917 */
3918
3919 OP*
3920 Perl_block_end(pTHX_ I32 floor, OP *seq)
3921 {
3922     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
3923     OP* retval = scalarseq(seq);
3924     OP *o;
3925
3926     /* XXX Is the null PL_parser check necessary here? */
3927     assert(PL_parser); /* Let’s find out under debugging builds.  */
3928     if (PL_parser && PL_parser->parsed_sub) {
3929         o = newSTATEOP(0, NULL, NULL);
3930         op_null(o);
3931         retval = op_append_elem(OP_LINESEQ, retval, o);
3932     }
3933
3934     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
3935
3936     LEAVE_SCOPE(floor);
3937     if (needblockscope)
3938         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
3939     o = pad_leavemy();
3940
3941     if (o) {
3942         /* pad_leavemy has created a sequence of introcv ops for all my
3943            subs declared in the block.  We have to replicate that list with
3944            clonecv ops, to deal with this situation:
3945
3946                sub {
3947                    my sub s1;
3948                    my sub s2;
3949                    sub s1 { state sub foo { \&s2 } }
3950                }->()
3951
3952            Originally, I was going to have introcv clone the CV and turn
3953            off the stale flag.  Since &s1 is declared before &s2, the
3954            introcv op for &s1 is executed (on sub entry) before the one for
3955            &s2.  But the &foo sub inside &s1 (which is cloned when &s1 is
3956            cloned, since it is a state sub) closes over &s2 and expects
3957            to see it in its outer CV’s pad.  If the introcv op clones &s1,
3958            then &s2 is still marked stale.  Since &s1 is not active, and
3959            &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
3960            ble will not stay shared’ warning.  Because it is the same stub
3961            that will be used when the introcv op for &s2 is executed, clos-
3962            ing over it is safe.  Hence, we have to turn off the stale flag
3963            on all lexical subs in the block before we clone any of them.
3964            Hence, having introcv clone the sub cannot work.  So we create a
3965            list of ops like this:
3966
3967                lineseq
3968                   |
3969                   +-- introcv
3970                   |
3971                   +-- introcv
3972                   |
3973                   +-- introcv
3974                   |
3975                   .
3976                   .
3977                   .
3978                   |
3979                   +-- clonecv
3980                   |
3981                   +-- clonecv
3982                   |
3983                   +-- clonecv
3984                   |
3985                   .
3986                   .
3987                   .
3988          */
3989         OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
3990         OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
3991         for (;; kid = OpSIBLING(kid)) {
3992             OP *newkid = newOP(OP_CLONECV, 0);
3993             newkid->op_targ = kid->op_targ;
3994             o = op_append_elem(OP_LINESEQ, o, newkid);
3995             if (kid == last) break;
3996         }
3997         retval = op_prepend_elem(OP_LINESEQ, o, retval);
3998     }
3999
4000     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
4001
4002     return retval;
4003 }
4004
4005 /*
4006 =head1 Compile-time scope hooks
4007
4008 =for apidoc Aox||blockhook_register
4009
4010 Register a set of hooks to be called when the Perl lexical scope changes
4011 at compile time.  See L<perlguts/"Compile-time scope hooks">.
4012
4013 =cut
4014 */
4015
4016 void
4017 Perl_blockhook_register(pTHX_ BHK *hk)
4018 {
4019     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
4020
4021     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
4022 }
4023
4024 void
4025 Perl_newPROG(pTHX_ OP *o)
4026 {
4027     PERL_ARGS_ASSERT_NEWPROG;
4028
4029     if (PL_in_eval) {
4030         PERL_CONTEXT *cx;
4031         I32 i;
4032         if (PL_eval_root)
4033                 return;
4034         PL_eval_root = newUNOP(OP_LEAVEEVAL,
4035                                ((PL_in_eval & EVAL_KEEPERR)
4036                                 ? OPf_SPECIAL : 0), o);
4037
4038         cx = &cxstack[cxstack_ix];
4039         assert(CxTYPE(cx) == CXt_EVAL);
4040
4041         if ((cx->blk_gimme & G_WANT) == G_VOID)
4042             scalarvoid(PL_eval_root);
4043         else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
4044             list(PL_eval_root);
4045         else
4046             scalar(PL_eval_root);
4047
4048         PL_eval_start = op_linklist(PL_eval_root);
4049         PL_eval_root->op_private |= OPpREFCOUNTED;
4050         OpREFCNT_set(PL_eval_root, 1);
4051         PL_eval_root->op_next = 0;
4052         i = PL_savestack_ix;
4053         SAVEFREEOP(o);
4054         ENTER;
4055         CALL_PEEP(PL_eval_start);
4056         finalize_optree(PL_eval_root);
4057         S_prune_chain_head(&PL_eval_start);
4058         LEAVE;
4059         PL_savestack_ix = i;
4060     }
4061     else {
4062         if (o->op_type == OP_STUB) {
4063             /* This block is entered if nothing is compiled for the main
4064                program. This will be the case for an genuinely empty main
4065                program, or one which only has BEGIN blocks etc, so already
4066                run and freed.
4067
4068                Historically (5.000) the guard above was !o. However, commit
4069                f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
4070                c71fccf11fde0068, changed perly.y so that newPROG() is now
4071                called with the output of block_end(), which returns a new
4072                OP_STUB for the case of an empty optree. ByteLoader (and
4073                maybe other things) also take this path, because they set up
4074                PL_main_start and PL_main_root directly, without generating an
4075                optree.
4076
4077                If the parsing the main program aborts (due to parse errors,
4078                or due to BEGIN or similar calling exit), then newPROG()
4079                isn't even called, and hence this code path and its cleanups
4080                are skipped. This shouldn't make a make a difference:
4081                * a non-zero return from perl_parse is a failure, and
4082                  perl_destruct() should be called immediately.
4083                * however, if exit(0) is called during the parse, then
4084                  perl_parse() returns 0, and perl_run() is called. As
4085                  PL_main_start will be NULL, perl_run() will return
4086                  promptly, and the exit code will remain 0.
4087             */
4088
4089             PL_comppad_name = 0;
4090             PL_compcv = 0;
4091             S_op_destroy(aTHX_ o);
4092             return;
4093         }
4094         PL_main_root = op_scope(sawparens(scalarvoid(o)));
4095         PL_curcop = &PL_compiling;
4096         PL_main_start = LINKLIST(PL_main_root);
4097         PL_main_root->op_private |= OPpREFCOUNTED;
4098         OpREFCNT_set(PL_main_root, 1);
4099         PL_main_root->op_next = 0;
4100         CALL_PEEP(PL_main_start);
4101         finalize_optree(PL_main_root);
4102         S_prune_chain_head(&PL_main_start);
4103         cv_forget_slab(PL_compcv);
4104         PL_compcv = 0;
4105
4106         /* Register with debugger */
4107         if (PERLDB_INTER) {
4108             CV * const cv = get_cvs("DB::postponed", 0);
4109             if (cv) {
4110                 dSP;
4111                 PUSHMARK(SP);
4112                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
4113                 PUTBACK;
4114                 call_sv(MUTABLE_SV(cv), G_DISCARD);
4115             }
4116         }
4117     }
4118 }
4119
4120 OP *
4121 Perl_localize(pTHX_ OP *o, I32 lex)
4122 {
4123     PERL_ARGS_ASSERT_LOCALIZE;
4124
4125     if (o->op_flags & OPf_PARENS)
4126 /* [perl #17376]: this appears to be premature, and results in code such as
4127    C< our(%x); > executing in list mode rather than void mode */
4128 #if 0
4129         list(o);
4130 #else
4131         NOOP;
4132 #endif
4133     else {
4134         if ( PL_parser->bufptr > PL_parser->oldbufptr
4135             && PL_parser->bufptr[-1] == ','
4136             && ckWARN(WARN_PARENTHESIS))
4137         {
4138             char *s = PL_parser->bufptr;
4139             bool sigil = FALSE;
4140
4141             /* some heuristics to detect a potential error */
4142             while (*s && (strchr(", \t\n", *s)))
4143                 s++;
4144
4145             while (1) {
4146                 if (*s && strchr("@$%*", *s) && *++s
4147                        && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
4148                     s++;
4149                     sigil = TRUE;
4150                     while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
4151                         s++;
4152                     while (*s && (strchr(", \t\n", *s)))
4153                         s++;
4154                 }
4155                 else
4156                     break;
4157             }
4158             if (sigil && (*s == ';' || *s == '=')) {
4159                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
4160                                 "Parentheses missing around \"%s\" list",
4161                                 lex
4162                                     ? (PL_parser->in_my == KEY_our
4163                                         ? "our"
4164                                         : PL_parser->in_my == KEY_state
4165                                             ? "state"
4166                                             : "my")
4167                                     : "local");
4168             }
4169         }
4170     }
4171     if (lex)
4172         o = my(o);
4173     else
4174         o = op_lvalue(o, OP_NULL);              /* a bit kludgey */
4175     PL_parser->in_my = FALSE;
4176     PL_parser->in_my_stash = NULL;
4177     return o;
4178 }
4179
4180 OP *
4181 Perl_jmaybe(pTHX_ OP *o)
4182 {
4183     PERL_ARGS_ASSERT_JMAYBE;
4184
4185     if (o->op_type == OP_LIST) {
4186         OP * const o2
4187             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
4188         o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
4189     }
4190     return o;
4191 }
4192
4193 PERL_STATIC_INLINE OP *
4194 S_op_std_init(pTHX_ OP *o)
4195 {
4196     I32 type = o->op_type;
4197
4198     PERL_ARGS_ASSERT_OP_STD_INIT;
4199
4200     if (PL_opargs[type] & OA_RETSCALAR)
4201         scalar(o);
4202     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
4203         o->op_targ = pad_alloc(type, SVs_PADTMP);
4204
4205     return o;
4206 }
4207
4208 PERL_STATIC_INLINE OP *
4209 S_op_integerize(pTHX_ OP *o)
4210 {
4211     I32 type = o->op_type;
4212
4213     PERL_ARGS_ASSERT_OP_INTEGERIZE;
4214
4215     /* integerize op. */
4216     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
4217     {
4218         dVAR;
4219         o->op_ppaddr = PL_ppaddr[++(o->op_type)];
4220     }
4221
4222     if (type == OP_NEGATE)
4223         /* XXX might want a ck_negate() for this */
4224         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
4225
4226     return o;
4227 }
4228
4229 static OP *
4230 S_fold_constants(pTHX_ OP *o)
4231 {
4232     dVAR;
4233     OP * VOL curop;
4234     OP *newop;
4235     VOL I32 type = o->op_type;
4236     bool is_stringify;
4237     SV * VOL sv = NULL;
4238     int ret = 0;
4239     I32 oldscope;
4240     OP *old_next;
4241     SV * const oldwarnhook = PL_warnhook;
4242     SV * const olddiehook  = PL_diehook;
4243     COP not_compiling;
4244     U8 oldwarn = PL_dowarn;
4245     dJMPENV;
4246
4247     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
4248
4249     if (!(PL_opargs[type] & OA_FOLDCONST))
4250         goto nope;
4251
4252     switch (type) {
4253     case OP_UCFIRST:
4254     case OP_LCFIRST:
4255     case OP_UC:
4256     case OP_LC:
4257     case OP_FC:
4258 #ifdef USE_LOCALE_CTYPE
4259         if (IN_LC_COMPILETIME(LC_CTYPE))
4260             goto nope;
4261 #endif
4262         break;
4263     case OP_SLT:
4264     case OP_SGT:
4265     case OP_SLE:
4266     case OP_SGE:
4267     case OP_SCMP:
4268 #ifdef USE_LOCALE_COLLATE
4269         if (IN_LC_COMPILETIME(LC_COLLATE))
4270             goto nope;
4271 #endif
4272         break;
4273     case OP_SPRINTF:
4274         /* XXX what about the numeric ops? */
4275 #ifdef USE_LOCALE_NUMERIC
4276         if (IN_LC_COMPILETIME(LC_NUMERIC))
4277             goto nope;
4278 #endif
4279         break;
4280     case OP_PACK:
4281         if (!OpHAS_SIBLING(cLISTOPo->op_first)
4282           || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
4283             goto nope;
4284         {
4285             SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
4286             if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
4287             {
4288                 const char *s = SvPVX_const(sv);
4289                 while (s < SvEND(sv)) {
4290                     if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
4291                     s++;
4292                 }
4293             }
4294         }
4295         break;
4296     case OP_REPEAT:
4297         if (o->op_private & OPpREPEAT_DOLIST) goto nope;
4298         break;
4299     case OP_SREFGEN:
4300         if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
4301          || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
4302             goto nope;
4303     }
4304
4305     if (PL_parser && PL_parser->error_count)
4306         goto nope;              /* Don't try to run w/ errors */
4307
4308     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4309         const OPCODE type = curop->op_type;
4310         if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
4311             type != OP_LIST &&
4312             type != OP_SCALAR &&
4313             type != OP_NULL &&
4314             type != OP_PUSHMARK)
4315         {
4316             goto nope;
4317         }
4318     }
4319
4320     curop = LINKLIST(o);
4321     old_next = o->op_next;
4322     o->op_next = 0;
4323     PL_op = curop;
4324
4325     oldscope = PL_scopestack_ix;
4326     create_eval_scope(G_FAKINGEVAL);
4327
4328     /* Verify that we don't need to save it:  */
4329     assert(PL_curcop == &PL_compiling);
4330     StructCopy(&PL_compiling, &not_compiling, COP);
4331     PL_curcop = &not_compiling;
4332     /* The above ensures that we run with all the correct hints of the
4333        currently compiling COP, but that IN_PERL_RUNTIME is true. */
4334     assert(IN_PERL_RUNTIME);
4335     PL_warnhook = PERL_WARNHOOK_FATAL;
4336     PL_diehook  = NULL;
4337     JMPENV_PUSH(ret);
4338
4339     /* Effective $^W=1.  */
4340     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
4341         PL_dowarn |= G_WARN_ON;
4342
4343     switch (ret) {
4344     case 0:
4345         CALLRUNOPS(aTHX);
4346         sv = *(PL_stack_sp--);
4347         if (o->op_targ && sv == PAD_SV(o->op_targ)) {   /* grab pad temp? */
4348             pad_swipe(o->op_targ,  FALSE);
4349         }
4350         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
4351             SvREFCNT_inc_simple_void(sv);
4352             SvTEMP_off(sv);
4353         }
4354         else { assert(SvIMMORTAL(sv)); }
4355         break;
4356     case 3:
4357         /* Something tried to die.  Abandon constant folding.  */
4358         /* Pretend the error never happened.  */
4359         CLEAR_ERRSV();
4360         o->op_next = old_next;
4361         break;
4362     default:
4363         JMPENV_POP;
4364         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
4365         PL_warnhook = oldwarnhook;
4366         PL_diehook  = olddiehook;
4367         /* XXX note that this croak may fail as we've already blown away
4368          * the stack - eg any nested evals */
4369         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
4370     }
4371     JMPENV_POP;
4372     PL_dowarn   = oldwarn;
4373     PL_warnhook = oldwarnhook;
4374     PL_diehook  = olddiehook;
4375     PL_curcop = &PL_compiling;
4376
4377     if (PL_scopestack_ix > oldscope)
4378         delete_eval_scope();
4379
4380     if (ret)
4381         goto nope;
4382
4383     /* OP_STRINGIFY and constant folding are used to implement qq.
4384        Here the constant folding is an implementation detail that we
4385        want to hide.  If the stringify op is itself already marked
4386        folded, however, then it is actually a folded join.  */
4387     is_stringify = type == OP_STRINGIFY && !o->op_folded;
4388     op_free(o);
4389     assert(sv);
4390     if (is_stringify)
4391         SvPADTMP_off(sv);
4392     else if (!SvIMMORTAL(sv)) {
4393         SvPADTMP_on(sv);
4394         SvREADONLY_on(sv);
4395     }
4396     newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
4397     if (!is_stringify) newop->op_folded = 1;
4398     return newop;
4399
4400  nope:
4401     return o;
4402 }
4403
4404 static OP *
4405 S_gen_constant_list(pTHX_ OP *o)
4406 {
4407     dVAR;
4408     OP *curop;
4409     const SSize_t oldtmps_floor = PL_tmps_floor;
4410     SV **svp;
4411     AV *av;
4412
4413     list(o);
4414     if (PL_parser && PL_parser->error_count)
4415         return o;               /* Don't attempt to run with errors */
4416
4417     curop = LINKLIST(o);
4418     o->op_next = 0;
4419     CALL_PEEP(curop);
4420     S_prune_chain_head(&curop);
4421     PL_op = curop;
4422     Perl_pp_pushmark(aTHX);
4423     CALLRUNOPS(aTHX);
4424     PL_op = curop;
4425     assert (!(curop->op_flags & OPf_SPECIAL));
4426     assert(curop->op_type == OP_RANGE);
4427     Perl_pp_anonlist(aTHX);
4428     PL_tmps_floor = oldtmps_floor;
4429
4430     CHANGE_TYPE(o, OP_RV2AV);
4431     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
4432     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
4433     o->op_opt = 0;              /* needs to be revisited in rpeep() */
4434     av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
4435
4436     /* replace subtree with an OP_CONST */
4437     curop = ((UNOP*)o)->op_first;
4438     op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
4439     op_free(curop);
4440
4441     if (AvFILLp(av) != -1)
4442         for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
4443         {
4444             SvPADTMP_on(*svp);
4445             SvREADONLY_on(*svp);
4446         }
4447     LINKLIST(o);
4448     return list(o);
4449 }
4450
4451 /*
4452 =head1 Optree Manipulation Functions
4453 */
4454
4455 /* List constructors */
4456
4457 /*
4458 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
4459
4460 Append an item to the list of ops contained directly within a list-type
4461 op, returning the lengthened list.  I<first> is the list-type op,
4462 and I<last> is the op to append to the list.  I<optype> specifies the
4463 intended opcode for the list.  If I<first> is not already a list of the
4464 right type, it will be upgraded into one.  If either I<first> or I<last>
4465 is null, the other is returned unchanged.
4466
4467 =cut
4468 */
4469
4470 OP *
4471 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
4472 {
4473     if (!first)
4474         return last;
4475
4476     if (!last)
4477         return first;
4478
4479     if (first->op_type != (unsigned)type
4480         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
4481     {
4482         return newLISTOP(type, 0, first, last);
4483     }
4484
4485     op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
4486     first->op_flags |= OPf_KIDS;
4487     return first;
4488 }
4489
4490 /*
4491 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
4492
4493 Concatenate the lists of ops contained directly within two list-type ops,
4494 returning the combined list.  I<first> and I<last> are the list-type ops
4495 to concatenate.  I<optype> specifies the intended opcode for the list.
4496 If either I<first> or I<last> is not already a list of the right type,
4497 it will be upgraded into one.  If either I<first> or I<last> is null,
4498 the other is returned unchanged.
4499
4500 =cut
4501 */
4502
4503 OP *
4504 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
4505 {
4506     if (!first)
4507         return last;
4508
4509     if (!last)
4510         return first;
4511
4512     if (first->op_type != (unsigned)type)
4513         return op_prepend_elem(type, first, last);
4514
4515     if (last->op_type != (unsigned)type)
4516         return op_append_elem(type, first, last);
4517
4518     ((LISTOP*)first)->op_last->op_lastsib = 0;
4519     OpSIBLING_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
4520     ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
4521     ((LISTOP*)first)->op_last->op_lastsib = 1;
4522 #ifdef PERL_OP_PARENT
4523     ((LISTOP*)first)->op_last->op_sibling = first;
4524 #endif
4525     first->op_flags |= (last->op_flags & OPf_KIDS);
4526
4527
4528     S_op_destroy(aTHX_ last);
4529
4530     return first;
4531 }
4532
4533 /*
4534 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
4535
4536 Prepend an item to the list of ops contained directly within a list-type
4537 op, returning the lengthened list.  I<first> is the op to prepend to the
4538 list, and I<last> is the list-type op.  I<optype> specifies the intended
4539 opcode for the list.  If I<last> is not already a list of the right type,
4540 it will be upgraded into one.  If either I<first> or I<last> is null,
4541 the other is returned unchanged.
4542
4543 =cut
4544 */
4545
4546 OP *
4547 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
4548 {
4549     if (!first)
4550         return last;
4551
4552     if (!last)
4553         return first;
4554
4555     if (last->op_type == (unsigned)type) {
4556         if (type == OP_LIST) {  /* already a PUSHMARK there */
4557             /* insert 'first' after pushmark */
4558             op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
4559             if (!(first->op_flags & OPf_PARENS))
4560                 last->op_flags &= ~OPf_PARENS;
4561         }
4562         else
4563             op_sibling_splice(last, NULL, 0, first);
4564         last->op_flags |= OPf_KIDS;
4565         return last;
4566     }
4567
4568     return newLISTOP(type, 0, first, last);
4569 }
4570
4571 /*
4572 =for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
4573
4574 Converts I<o> into a list op if it is not one already, and then converts it
4575 into the specified I<type>, calling its check function, allocating a target if
4576 it needs one, and folding constants.
4577
4578 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
4579 C<op_prepend_elem> and C<op_append_elem>.  Then finally it is passed to
4580 C<op_convert_list> to make it the right type.
4581
4582 =cut
4583 */
4584
4585 OP *
4586 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
4587 {
4588     dVAR;
4589     if (type < 0) type = -type, flags |= OPf_SPECIAL;
4590     if (!o || o->op_type != OP_LIST)
4591         o = force_list(o, 0);
4592     else
4593         o->op_flags &= ~OPf_WANT;
4594
4595     if (!(PL_opargs[type] & OA_MARK))
4596         op_null(cLISTOPo->op_first);
4597     else {
4598         OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
4599         if (kid2 && kid2->op_type == OP_COREARGS) {
4600             op_null(cLISTOPo->op_first);
4601             kid2->op_private |= OPpCOREARGS_PUSHMARK;
4602         }
4603     }
4604
4605     CHANGE_TYPE(o, type);
4606     o->op_flags |= flags;
4607     if (flags & OPf_FOLDED)
4608         o->op_folded = 1;
4609
4610     o = CHECKOP(type, o);
4611     if (o->op_type != (unsigned)type)
4612         return o;
4613
4614     return fold_constants(op_integerize(op_std_init(o)));
4615 }
4616
4617 /* Constructors */
4618
4619
4620 /*
4621 =head1 Optree construction
4622
4623 =for apidoc Am|OP *|newNULLLIST
4624
4625 Constructs, checks, and returns a new C<stub> op, which represents an
4626 empty list expression.
4627
4628 =cut
4629 */
4630
4631 OP *
4632 Perl_newNULLLIST(pTHX)
4633 {
4634     return newOP(OP_STUB, 0);
4635 }
4636
4637 /* promote o and any siblings to be a list if its not already; i.e.
4638  *
4639  *  o - A - B
4640  *
4641  * becomes
4642  *
4643  *  list
4644  *    |
4645  *  pushmark - o - A - B
4646  *
4647  * If nullit it true, the list op is nulled.
4648  */
4649
4650 static OP *
4651 S_force_list(pTHX_ OP *o, bool nullit)
4652 {
4653     if (!o || o->op_type != OP_LIST) {
4654         OP *rest = NULL;
4655         if (o) {
4656             /* manually detach any siblings then add them back later */
4657             rest = OpSIBLING(o);
4658             OpSIBLING_set(o, NULL);
4659             o->op_lastsib = 1;
4660         }
4661         o = newLISTOP(OP_LIST, 0, o, NULL);
4662         if (rest)
4663             op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
4664     }
4665     if (nullit)
4666         op_null(o);
4667     return o;
4668 }
4669
4670 /*
4671 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
4672
4673 Constructs, checks, and returns an op of any list type.  I<type> is
4674 the opcode.  I<flags> gives the eight bits of C<op_flags>, except that
4675 C<OPf_KIDS> will be set automatically if required.  I<first> and I<last>
4676 supply up to two ops to be direct children of the list op; they are
4677 consumed by this function and become part of the constructed op tree.
4678
4679 For most list operators, the check function expects all the kid ops to be
4680 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.,) is not
4681 appropriate.  What you want to do in that case is create an op of type
4682 OP_LIST, append more children to it, and then call L</op_convert_list>.
4683 See L</op_convert_list> for more information.
4684
4685
4686 =cut
4687 */
4688
4689 OP *
4690 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4691 {
4692     dVAR;
4693     LISTOP *listop;
4694
4695     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
4696         || type == OP_CUSTOM);
4697
4698     NewOp(1101, listop, 1, LISTOP);
4699
4700     CHANGE_TYPE(listop, type);
4701     if (first || last)
4702         flags |= OPf_KIDS;
4703     listop->op_flags = (U8)flags;
4704
4705     if (!last && first)
4706         last = first;
4707     else if (!first && last)
4708         first = last;
4709     else if (first)
4710         OpSIBLING_set(first, last);
4711     listop->op_first = first;
4712     listop->op_last = last;
4713     if (type == OP_LIST) {
4714         OP* const pushop = newOP(OP_PUSHMARK, 0);
4715         pushop->op_lastsib = 0;
4716         OpSIBLING_set(pushop, first);
4717         listop->op_first = pushop;
4718         listop->op_flags |= OPf_KIDS;
4719         if (!last)
4720             listop->op_last = pushop;
4721     }
4722     if (first)
4723         first->op_lastsib = 0;
4724     if (listop->op_last) {
4725         listop->op_last->op_lastsib = 1;
4726 #ifdef PERL_OP_PARENT
4727         listop->op_last->op_sibling = (OP*)listop;
4728 #endif
4729     }
4730
4731     return CHECKOP(type, listop);
4732 }
4733
4734 /*
4735 =for apidoc Am|OP *|newOP|I32 type|I32 flags
4736
4737 Constructs, checks, and returns an op of any base type (any type that
4738 has no extra fields).  I<type> is the opcode.  I<flags> gives the
4739 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
4740 of C<op_private>.
4741
4742 =cut
4743 */
4744
4745 OP *
4746 Perl_newOP(pTHX_ I32 type, I32 flags)
4747 {
4748     dVAR;
4749     OP *o;
4750
4751     if (type == -OP_ENTEREVAL) {
4752         type = OP_ENTEREVAL;
4753         flags |= OPpEVAL_BYTES<<8;
4754     }
4755
4756     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
4757         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4758         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4759         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4760
4761     NewOp(1101, o, 1, OP);
4762     CHANGE_TYPE(o, type);
4763     o->op_flags = (U8)flags;
4764
4765     o->op_next = o;
4766     o->op_private = (U8)(0 | (flags >> 8));
4767     if (PL_opargs[type] & OA_RETSCALAR)
4768         scalar(o);
4769     if (PL_opargs[type] & OA_TARGET)
4770         o->op_targ = pad_alloc(type, SVs_PADTMP);
4771     return CHECKOP(type, o);
4772 }
4773
4774 /*
4775 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
4776
4777 Constructs, checks, and returns an op of any unary type.  I<type> is
4778 the opcode.  I<flags> gives the eight bits of C<op_flags>, except that
4779 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
4780 bits, the eight bits of C<op_private>, except that the bit with value 1
4781 is automatically set.  I<first> supplies an optional op to be the direct
4782 child of the unary op; it is consumed by this function and become part
4783 of the constructed op tree.
4784
4785 =cut
4786 */
4787
4788 OP *
4789 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
4790 {
4791     dVAR;
4792     UNOP *unop;
4793
4794     if (type == -OP_ENTEREVAL) {
4795         type = OP_ENTEREVAL;
4796         flags |= OPpEVAL_BYTES<<8;
4797     }
4798
4799     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
4800         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4801         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4802         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
4803         || type == OP_SASSIGN
4804         || type == OP_ENTERTRY
4805         || type == OP_CUSTOM
4806         || type == OP_NULL );
4807
4808     if (!first)
4809         first = newOP(OP_STUB, 0);
4810     if (PL_opargs[type] & OA_MARK)
4811         first = force_list(first, 1);
4812
4813     NewOp(1101, unop, 1, UNOP);
4814     CHANGE_TYPE(unop, type);
4815     unop->op_first = first;
4816     unop->op_flags = (U8)(flags | OPf_KIDS);
4817     unop->op_private = (U8)(1 | (flags >> 8));
4818
4819 #ifdef PERL_OP_PARENT
4820     if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
4821         first->op_sibling = (OP*)unop;
4822 #endif
4823
4824     unop = (UNOP*) CHECKOP(type, unop);
4825     if (unop->op_next)
4826         return (OP*)unop;
4827
4828     return fold_constants(op_integerize(op_std_init((OP *) unop)));
4829 }
4830
4831 /*
4832 =for apidoc newUNOP_AUX
4833
4834 Similar to C<newUNOP>, but creates an UNOP_AUX struct instead, with op_aux
4835 initialised to aux
4836
4837 =cut
4838 */
4839
4840 OP *
4841 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
4842 {
4843     dVAR;
4844     UNOP_AUX *unop;
4845
4846     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
4847         || type == OP_CUSTOM);
4848
4849     NewOp(1101, unop, 1, UNOP_AUX);
4850     unop->op_type = (OPCODE)type;
4851     unop->op_ppaddr = PL_ppaddr[type];
4852     unop->op_first = first;
4853     unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
4854     unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
4855     unop->op_aux = aux;
4856
4857 #ifdef PERL_OP_PARENT
4858     if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
4859         first->op_sibling = (OP*)unop;
4860 #endif
4861
4862     unop = (UNOP_AUX*) CHECKOP(type, unop);
4863
4864     return op_std_init((OP *) unop);
4865 }
4866
4867 /*
4868 =for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
4869
4870 Constructs, checks, and returns an op of method type with a method name
4871 evaluated at runtime.  I<type> is the opcode.  I<flags> gives the eight
4872 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
4873 and, shifted up eight bits, the eight bits of C<op_private>, except that
4874 the bit with value 1 is automatically set.  I<dynamic_meth> supplies an
4875 op which evaluates method name; it is consumed by this function and
4876 become part of the constructed op tree.
4877 Supported optypes: OP_METHOD.
4878
4879 =cut
4880 */
4881
4882 static OP*
4883 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
4884     dVAR;
4885     METHOP *methop;
4886
4887     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
4888         || type == OP_CUSTOM);
4889
4890     NewOp(1101, methop, 1, METHOP);
4891     if (dynamic_meth) {
4892         if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
4893         methop->op_flags = (U8)(flags | OPf_KIDS);
4894         methop->op_u.op_first = dynamic_meth;
4895         methop->op_private = (U8)(1 | (flags >> 8));
4896
4897 #ifdef PERL_OP_PARENT
4898         if (!OpHAS_SIBLING(dynamic_meth))
4899             dynamic_meth->op_sibling = (OP*)methop;
4900 #endif
4901     }
4902     else {
4903         assert(const_meth);
4904         methop->op_flags = (U8)(flags & ~OPf_KIDS);
4905         methop->op_u.op_meth_sv = const_meth;
4906         methop->op_private = (U8)(0 | (flags >> 8));
4907         methop->op_next = (OP*)methop;
4908     }
4909
4910 #ifdef USE_ITHREADS
4911     methop->op_rclass_targ = 0;
4912 #else
4913     methop->op_rclass_sv = NULL;
4914 #endif
4915
4916     CHANGE_TYPE(methop, type);
4917     return CHECKOP(type, methop);
4918 }
4919
4920 OP *
4921 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
4922     PERL_ARGS_ASSERT_NEWMETHOP;
4923     return newMETHOP_internal(type, flags, dynamic_meth, NULL);
4924 }
4925
4926 /*
4927 =for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
4928
4929 Constructs, checks, and returns an op of method type with a constant
4930 method name.  I<type> is the opcode.  I<flags> gives the eight bits of
4931 C<op_flags>, and, shifted up eight bits, the eight bits of
4932 C<op_private>.  I<const_meth> supplies a constant method name;
4933 it must be a shared COW string.
4934 Supported optypes: OP_METHOD_NAMED.
4935
4936 =cut
4937 */
4938
4939 OP *
4940 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
4941     PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
4942     return newMETHOP_internal(type, flags, NULL, const_meth);
4943 }
4944
4945 /*
4946 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
4947
4948 Constructs, checks, and returns an op of any binary type.  I<type>
4949 is the opcode.  I<flags> gives the eight bits of C<op_flags>, except
4950 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4951 the eight bits of C<op_private>, except that the bit with value 1 or
4952 2 is automatically set as required.  I<first> and I<last> supply up to
4953 two ops to be the direct children of the binary op; they are consumed
4954 by this function and become part of the constructed op tree.
4955
4956 =cut
4957 */
4958
4959 OP *
4960 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4961 {
4962     dVAR;
4963     BINOP *binop;
4964
4965     ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
4966         || type == OP_SASSIGN || type == OP_NULL || type == OP_CUSTOM);
4967
4968     NewOp(1101, binop, 1, BINOP);
4969
4970     if (!first)
4971         first = newOP(OP_NULL, 0);
4972
4973     CHANGE_TYPE(binop, type);
4974     binop->op_first = first;
4975     binop->op_flags = (U8)(flags | OPf_KIDS);
4976     if (!last) {
4977         last = first;
4978         binop->op_private = (U8)(1 | (flags >> 8));
4979     }
4980     else {
4981         binop->op_private = (U8)(2 | (flags >> 8));
4982         OpSIBLING_set(first, last);
4983         first->op_lastsib = 0;
4984     }
4985
4986 #ifdef PERL_OP_PARENT
4987     if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
4988         last->op_sibling = (OP*)binop;
4989 #endif
4990
4991     binop->op_last = OpSIBLING(binop->op_first);
4992 #ifdef PERL_OP_PARENT
4993     if (binop->op_last)
4994         binop->op_last->op_sibling = (OP*)binop;
4995 #endif
4996
4997     binop = (BINOP*)CHECKOP(type, binop);
4998     if (binop->op_next || binop->op_type != (OPCODE)type)
4999         return (OP*)binop;
5000
5001     return fold_constants(op_integerize(op_std_init((OP *)binop)));
5002 }
5003
5004 static int uvcompare(const void *a, const void *b)
5005     __attribute__nonnull__(1)
5006     __attribute__nonnull__(2)
5007     __attribute__pure__;
5008 static int uvcompare(const void *a, const void *b)
5009 {
5010     if (*((const UV *)a) < (*(const UV *)b))
5011         return -1;
5012     if (*((const UV *)a) > (*(const UV *)b))
5013         return 1;
5014     if (*((const UV *)a+1) < (*(const UV *)b+1))
5015         return -1;
5016     if (*((const UV *)a+1) > (*(const UV *)b+1))
5017         return 1;
5018     return 0;
5019 }
5020
5021 static OP *
5022 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
5023 {
5024     SV * const tstr = ((SVOP*)expr)->op_sv;
5025     SV * const rstr =
5026                               ((SVOP*)repl)->op_sv;
5027     STRLEN tlen;
5028     STRLEN rlen;
5029     const U8 *t = (U8*)SvPV_const(tstr, tlen);
5030     const U8 *r = (U8*)SvPV_const(rstr, rlen);
5031     I32 i;
5032     I32 j;
5033     I32 grows = 0;
5034     short *tbl;
5035
5036     const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
5037     const I32 squash     = o->op_private & OPpTRANS_SQUASH;
5038     I32 del              = o->op_private & OPpTRANS_DELETE;
5039     SV* swash;
5040
5041     PERL_ARGS_ASSERT_PMTRANS;
5042
5043     PL_hints |= HINT_BLOCK_SCOPE;
5044
5045     if (SvUTF8(tstr))
5046         o->op_private |= OPpTRANS_FROM_UTF;
5047
5048     if (SvUTF8(rstr))
5049         o->op_private |= OPpTRANS_TO_UTF;
5050
5051     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
5052         SV* const listsv = newSVpvs("# comment\n");
5053         SV* transv = NULL;
5054         const U8* tend = t + tlen;
5055         const U8* rend = r + rlen;
5056         STRLEN ulen;
5057         UV tfirst = 1;
5058         UV tlast = 0;
5059         IV tdiff;
5060         STRLEN tcount = 0;
5061         UV rfirst = 1;
5062         UV rlast = 0;
5063         IV rdiff;
5064         STRLEN rcount = 0;
5065         IV diff;
5066         I32 none = 0;
5067         U32 max = 0;
5068         I32 bits;
5069         I32 havefinal = 0;
5070         U32 final = 0;
5071         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
5072         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
5073         U8* tsave = NULL;
5074         U8* rsave = NULL;
5075         const U32 flags = UTF8_ALLOW_DEFAULT;
5076
5077         if (!from_utf) {
5078             STRLEN len = tlen;
5079             t = tsave = bytes_to_utf8(t, &len);
5080             tend = t + len;
5081         }
5082         if (!to_utf && rlen) {
5083             STRLEN len = rlen;
5084             r = rsave = bytes_to_utf8(r, &len);
5085             rend = r + len;
5086         }
5087
5088 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
5089  * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
5090  * odd.  */
5091
5092         if (complement) {
5093             U8 tmpbuf[UTF8_MAXBYTES+1];
5094             UV *cp;
5095             UV nextmin = 0;
5096             Newx(cp, 2*tlen, UV);
5097             i = 0;
5098             transv = newSVpvs("");
5099             while (t < tend) {
5100                 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
5101                 t += ulen;
5102                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
5103                     t++;
5104                     cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
5105                     t += ulen;
5106                 }
5107                 else {
5108                  cp[2*i+1] = cp[2*i];
5109                 }
5110                 i++;
5111             }
5112             qsort(cp, i, 2*sizeof(UV), uvcompare);
5113             for (j = 0; j < i; j++) {
5114                 UV  val = cp[2*j];
5115                 diff = val - nextmin;
5116                 if (diff > 0) {
5117                     t = uvchr_to_utf8(tmpbuf,nextmin);
5118                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5119                     if (diff > 1) {
5120                         U8  range_mark = ILLEGAL_UTF8_BYTE;
5121                         t = uvchr_to_utf8(tmpbuf, val - 1);
5122                         sv_catpvn(transv, (char *)&range_mark, 1);
5123                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5124                     }
5125                 }
5126                 val = cp[2*j+1];
5127                 if (val >= nextmin)
5128                     nextmin = val + 1;
5129             }
5130             t = uvchr_to_utf8(tmpbuf,nextmin);
5131             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5132             {
5133                 U8 range_mark = ILLEGAL_UTF8_BYTE;
5134                 sv_catpvn(transv, (char *)&range_mark, 1);
5135             }
5136             t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
5137             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5138             t = (const U8*)SvPVX_const(transv);
5139             tlen = SvCUR(transv);
5140             tend = t + tlen;
5141             Safefree(cp);
5142         }
5143         else if (!rlen && !del) {
5144             r = t; rlen = tlen; rend = tend;
5145         }
5146         if (!squash) {
5147                 if ((!rlen && !del) || t == r ||
5148                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
5149                 {
5150                     o->op_private |= OPpTRANS_IDENTICAL;
5151                 }
5152         }
5153
5154         while (t < tend || tfirst <= tlast) {
5155             /* see if we need more "t" chars */
5156             if (tfirst > tlast) {
5157                 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
5158                 t += ulen;
5159                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {      /* illegal utf8 val indicates range */
5160                     t++;
5161                     tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
5162                     t += ulen;
5163                 }
5164                 else
5165                     tlast = tfirst;
5166             }
5167
5168             /* now see if we need more "r" chars */
5169             if (rfirst > rlast) {
5170                 if (r < rend) {
5171                     rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
5172                     r += ulen;
5173                     if (r < rend && *r == ILLEGAL_UTF8_BYTE) {  /* illegal utf8 val indicates range */
5174                         r++;
5175                         rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
5176                         r += ulen;
5177                     }
5178                     else
5179                         rlast = rfirst;
5180                 }
5181                 else {
5182                     if (!havefinal++)
5183                         final = rlast;
5184                     rfirst = rlast = 0xffffffff;
5185                 }
5186             }
5187
5188             /* now see which range will peter our first, if either. */
5189             tdiff = tlast - tfirst;
5190             rdiff = rlast - rfirst;
5191             tcount += tdiff + 1;
5192             rcount += rdiff + 1;
5193
5194             if (tdiff <= rdiff)
5195                 diff = tdiff;
5196             else
5197                 diff = rdiff;
5198
5199             if (rfirst == 0xffffffff) {
5200                 diff = tdiff;   /* oops, pretend rdiff is infinite */
5201                 if (diff > 0)
5202                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
5203                                    (long)tfirst, (long)tlast);
5204                 else
5205                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
5206             }
5207             else {
5208                 if (diff > 0)
5209                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
5210                                    (long)tfirst, (long)(tfirst + diff),
5211                                    (long)rfirst);
5212                 else
5213                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
5214                                    (long)tfirst, (long)rfirst);
5215
5216                 if (rfirst + diff > max)
5217                     max = rfirst + diff;
5218                 if (!grows)
5219                     grows = (tfirst < rfirst &&
5220                              UNISKIP(tfirst) < UNISKIP(rfirst + diff));
5221                 rfirst += diff + 1;
5222             }
5223             tfirst += diff + 1;
5224         }
5225
5226         none = ++max;
5227         if (del)
5228             del = ++max;
5229
5230         if (max > 0xffff)
5231             bits = 32;
5232         else if (max > 0xff)
5233             bits = 16;
5234         else
5235             bits = 8;
5236
5237         swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
5238 #ifdef USE_ITHREADS
5239         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
5240         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
5241         PAD_SETSV(cPADOPo->op_padix, swash);
5242         SvPADTMP_on(swash);
5243         SvREADONLY_on(swash);
5244 #else
5245         cSVOPo->op_sv = swash;
5246 #endif
5247         SvREFCNT_dec(listsv);
5248         SvREFCNT_dec(transv);
5249
5250         if (!del && havefinal && rlen)
5251             (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
5252                            newSVuv((UV)final), 0);
5253
5254         Safefree(tsave);
5255         Safefree(rsave);
5256
5257         tlen = tcount;
5258         rlen = rcount;
5259         if (r < rend)
5260             rlen++;
5261         else if (rlast == 0xffffffff)
5262             rlen = 0;
5263
5264         goto warnins;
5265     }
5266
5267     tbl = (short*)PerlMemShared_calloc(
5268         (o->op_private & OPpTRANS_COMPLEMENT) &&
5269             !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
5270         sizeof(short));
5271     cPVOPo->op_pv = (char*)tbl;
5272     if (complement) {
5273         for (i = 0; i < (I32)tlen; i++)
5274             tbl[t[i]] = -1;
5275         for (i = 0, j = 0; i < 256; i++) {
5276             if (!tbl[i]) {
5277                 if (j >= (I32)rlen) {
5278                     if (del)
5279                         tbl[i] = -2;
5280                     else if (rlen)
5281                         tbl[i] = r[j-1];
5282                     else
5283                         tbl[i] = (short)i;
5284                 }
5285                 else {
5286                     if (i < 128 && r[j] >= 128)
5287                         grows = 1;
5288                     tbl[i] = r[j++];
5289                 }
5290             }
5291         }
5292         if (!del) {
5293             if (!rlen) {
5294                 j = rlen;
5295                 if (!squash)
5296                     o->op_private |= OPpTRANS_IDENTICAL;
5297             }
5298             else if (j >= (I32)rlen)
5299                 j = rlen - 1;
5300             else {
5301                 tbl =
5302                     (short *)
5303                     PerlMemShared_realloc(tbl,
5304                                           (0x101+rlen-j) * sizeof(short));
5305                 cPVOPo->op_pv = (char*)tbl;
5306             }
5307             tbl[0x100] = (short)(rlen - j);
5308             for (i=0; i < (I32)rlen - j; i++)
5309                 tbl[0x101+i] = r[j+i];
5310         }
5311     }
5312     else {
5313         if (!rlen && !del) {
5314             r = t; rlen = tlen;
5315             if (!squash)
5316                 o->op_private |= OPpTRANS_IDENTICAL;
5317         }
5318         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
5319             o->op_private |= OPpTRANS_IDENTICAL;
5320         }
5321         for (i = 0; i < 256; i++)
5322             tbl[i] = -1;
5323         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
5324             if (j >= (I32)rlen) {
5325                 if (del) {
5326                     if (tbl[t[i]] == -1)
5327                         tbl[t[i]] = -2;
5328                     continue;
5329                 }
5330                 --j;
5331             }
5332             if (tbl[t[i]] == -1) {
5333                 if (t[i] < 128 && r[j] >= 128)
5334                     grows = 1;
5335                 tbl[t[i]] = r[j];
5336             }
5337         }
5338     }
5339
5340   warnins:
5341     if(del && rlen == tlen) {
5342         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
5343     } else if(rlen > tlen && !complement) {
5344         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
5345     }
5346
5347     if (grows)
5348         o->op_private |= OPpTRANS_GROWS;
5349     op_free(expr);
5350     op_free(repl);
5351
5352     return o;
5353 }
5354
5355 /*
5356 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
5357
5358 Constructs, checks, and returns an op of any pattern matching type.
5359 I<type> is the opcode.  I<flags> gives the eight bits of C<op_flags>
5360 and, shifted up eight bits, the eight bits of C<op_private>.
5361
5362 =cut
5363 */
5364
5365 OP *
5366 Perl_newPMOP(pTHX_ I32 type, I32 flags)
5367 {
5368     dVAR;
5369     PMOP *pmop;
5370
5371     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
5372         || type == OP_CUSTOM);
5373
5374     NewOp(1101, pmop, 1, PMOP);
5375     CHANGE_TYPE(pmop, type);
5376     pmop->op_flags = (U8)flags;
5377     pmop->op_private = (U8)(0 | (flags >> 8));
5378     if (PL_opargs[type] & OA_RETSCALAR)
5379         scalar((OP *)pmop);
5380
5381     if (PL_hints & HINT_RE_TAINT)
5382         pmop->op_pmflags |= PMf_RETAINT;
5383 #ifdef USE_LOCALE_CTYPE
5384     if (IN_LC_COMPILETIME(LC_CTYPE)) {
5385         set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
5386     }
5387     else
5388 #endif
5389          if (IN_UNI_8_BIT) {
5390         set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
5391     }
5392     if (PL_hints & HINT_RE_FLAGS) {
5393         SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5394          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
5395         );
5396         if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
5397         reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5398          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
5399         );
5400         if (reflags && SvOK(reflags)) {
5401             set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
5402         }
5403     }
5404
5405
5406 #ifdef USE_ITHREADS
5407     assert(SvPOK(PL_regex_pad[0]));
5408     if (SvCUR(PL_regex_pad[0])) {
5409         /* Pop off the "packed" IV from the end.  */
5410         SV *const repointer_list = PL_regex_pad[0];
5411         const char *p = SvEND(repointer_list) - sizeof(IV);
5412         const IV offset = *((IV*)p);
5413
5414         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
5415
5416         SvEND_set(repointer_list, p);
5417
5418         pmop->op_pmoffset = offset;
5419         /* This slot should be free, so assert this:  */
5420         assert(PL_regex_pad[offset] == &PL_sv_undef);
5421     } else {
5422         SV * const repointer = &PL_sv_undef;
5423         av_push(PL_regex_padav, repointer);
5424         pmop->op_pmoffset = av_tindex(PL_regex_padav);
5425         PL_regex_pad = AvARRAY(PL_regex_padav);
5426     }
5427 #endif
5428
5429     return CHECKOP(type, pmop);
5430 }
5431
5432 static void
5433 S_set_haseval(pTHX)
5434 {
5435     PADOFFSET i = 1;
5436     PL_cv_has_eval = 1;
5437     /* Any pad names in scope are potentially lvalues.  */
5438     for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
5439         PADNAME *pn = PAD_COMPNAME_SV(i);
5440         if (!pn || !PadnameLEN(pn))
5441             continue;
5442         if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
5443             S_mark_padname_lvalue(aTHX_ pn);
5444     }
5445 }
5446
5447 /* Given some sort of match op o, and an expression expr containing a
5448  * pattern, either compile expr into a regex and attach it to o (if it's
5449  * constant), or convert expr into a runtime regcomp op sequence (if it's
5450  * not)
5451  *
5452  * isreg indicates that the pattern is part of a regex construct, eg
5453  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
5454  * split "pattern", which aren't. In the former case, expr will be a list
5455  * if the pattern contains more than one term (eg /a$b/).
5456  *
5457  * When the pattern has been compiled within a new anon CV (for
5458  * qr/(?{...})/ ), then floor indicates the savestack level just before
5459  * the new sub was created
5460  */
5461
5462 OP *
5463 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, bool isreg, I32 floor)
5464 {
5465     PMOP *pm;
5466     LOGOP *rcop;
5467     I32 repl_has_vars = 0;
5468     bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
5469     bool is_compiletime;
5470     bool has_code;
5471
5472     PERL_ARGS_ASSERT_PMRUNTIME;
5473
5474     if (is_trans) {
5475         return pmtrans(o, expr, repl);
5476     }
5477
5478     /* find whether we have any runtime or code elements;
5479      * at the same time, temporarily set the op_next of each DO block;
5480      * then when we LINKLIST, this will cause the DO blocks to be excluded
5481      * from the op_next chain (and from having LINKLIST recursively
5482      * applied to them). We fix up the DOs specially later */
5483
5484     is_compiletime = 1;
5485     has_code = 0;
5486     if (expr->op_type == OP_LIST) {
5487         OP *o;
5488         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
5489             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
5490                 has_code = 1;
5491                 assert(!o->op_next);
5492                 if (UNLIKELY(!OpHAS_SIBLING(o))) {
5493                     assert(PL_parser && PL_parser->error_count);
5494                     /* This can happen with qr/ (?{(^{})/.  Just fake up
5495                        the op we were expecting to see, to avoid crashing
5496                        elsewhere.  */
5497                     op_sibling_splice(expr, o, 0,
5498                                       newSVOP(OP_CONST, 0, &PL_sv_no));
5499                 }
5500                 o->op_next = OpSIBLING(o);
5501             }
5502             else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
5503                 is_compiletime = 0;
5504         }
5505     }
5506     else if (expr->op_type != OP_CONST)
5507         is_compiletime = 0;
5508
5509     LINKLIST(expr);
5510
5511     /* fix up DO blocks; treat each one as a separate little sub;
5512      * also, mark any arrays as LIST/REF */
5513
5514     if (expr->op_type == OP_LIST) {
5515         OP *o;
5516         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
5517
5518             if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
5519                 assert( !(o->op_flags  & OPf_WANT));
5520                 /* push the array rather than its contents. The regex
5521                  * engine will retrieve and join the elements later */
5522                 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
5523                 continue;
5524             }
5525
5526             if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
5527                 continue;
5528             o->op_next = NULL; /* undo temporary hack from above */
5529             scalar(o);
5530             LINKLIST(o);
5531             if (cLISTOPo->op_first->op_type == OP_LEAVE) {
5532                 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
5533                 /* skip ENTER */
5534                 assert(leaveop->op_first->op_type == OP_ENTER);
5535                 assert(OpHAS_SIBLING(leaveop->op_first));
5536                 o->op_next = OpSIBLING(leaveop->op_first);
5537                 /* skip leave */
5538                 assert(leaveop->op_flags & OPf_KIDS);
5539                 assert(leaveop->op_last->op_next == (OP*)leaveop);
5540                 leaveop->op_next = NULL; /* stop on last op */
5541                 op_null((OP*)leaveop);
5542             }
5543             else {
5544                 /* skip SCOPE */
5545                 OP *scope = cLISTOPo->op_first;
5546                 assert(scope->op_type == OP_SCOPE);
5547                 assert(scope->op_flags & OPf_KIDS);
5548                 scope->op_next = NULL; /* stop on last op */
5549                 op_null(scope);
5550             }
5551             /* have to peep the DOs individually as we've removed it from
5552              * the op_next chain */
5553             CALL_PEEP(o);
5554             S_prune_chain_head(&(o->op_next));
5555             if (is_compiletime)
5556                 /* runtime finalizes as part of finalizing whole tree */
5557                 finalize_optree(o);
5558         }
5559     }
5560     else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
5561         assert( !(expr->op_flags  & OPf_WANT));
5562         /* push the array rather than its contents. The regex
5563          * engine will retrieve and join the elements later */
5564         expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
5565     }
5566
5567     PL_hints |= HINT_BLOCK_SCOPE;
5568     pm = (PMOP*)o;
5569     assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
5570
5571     if (is_compiletime) {
5572         U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
5573         regexp_engine const *eng = current_re_engine();
5574
5575         if (o->op_flags & OPf_SPECIAL)
5576             rx_flags |= RXf_SPLIT;
5577
5578         if (!has_code || !eng->op_comp) {
5579             /* compile-time simple constant pattern */
5580
5581             if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
5582                 /* whoops! we guessed that a qr// had a code block, but we
5583                  * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
5584                  * that isn't required now. Note that we have to be pretty
5585                  * confident that nothing used that CV's pad while the
5586                  * regex was parsed, except maybe op targets for \Q etc.
5587                  * If there were any op targets, though, they should have
5588                  * been stolen by constant folding.
5589                  */
5590 #ifdef DEBUGGING
5591                 SSize_t i = 0;
5592                 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
5593                 while (++i <= AvFILLp(PL_comppad)) {
5594                     assert(!PL_curpad[i]);
5595                 }
5596 #endif
5597                 /* But we know that one op is using this CV's slab. */
5598                 cv_forget_slab(PL_compcv);
5599                 LEAVE_SCOPE(floor);
5600                 pm->op_pmflags &= ~PMf_HAS_CV;
5601             }
5602
5603             PM_SETRE(pm,
5604                 eng->op_comp
5605                     ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5606                                         rx_flags, pm->op_pmflags)
5607                     : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5608                                         rx_flags, pm->op_pmflags)
5609             );
5610             op_free(expr);
5611         }
5612         else {
5613             /* compile-time pattern that includes literal code blocks */
5614             REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5615                         rx_flags,
5616                         (pm->op_pmflags |
5617                             ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
5618                     );
5619             PM_SETRE(pm, re);
5620             if (pm->op_pmflags & PMf_HAS_CV) {
5621                 CV *cv;
5622                 /* this QR op (and the anon sub we embed it in) is never
5623                  * actually executed. It's just a placeholder where we can
5624                  * squirrel away expr in op_code_list without the peephole
5625                  * optimiser etc processing it for a second time */
5626                 OP *qr = newPMOP(OP_QR, 0);
5627                 ((PMOP*)qr)->op_code_list = expr;
5628
5629                 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
5630                 SvREFCNT_inc_simple_void(PL_compcv);
5631                 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
5632                 ReANY(re)->qr_anoncv = cv;
5633
5634                 /* attach the anon CV to the pad so that
5635                  * pad_fixup_inner_anons() can find it */
5636                 (void)pad_add_anon(cv, o->op_type);
5637                 SvREFCNT_inc_simple_void(cv);
5638             }
5639             else {
5640                 pm->op_code_list = expr;
5641             }
5642         }
5643     }
5644     else {
5645         /* runtime pattern: build chain of regcomp etc ops */
5646         bool reglist;
5647         PADOFFSET cv_targ = 0;
5648
5649         reglist = isreg && expr->op_type == OP_LIST;
5650         if (reglist)
5651             op_null(expr);
5652
5653         if (has_code) {
5654             pm->op_code_list = expr;
5655             /* don't free op_code_list; its ops are embedded elsewhere too */
5656             pm->op_pmflags |= PMf_CODELIST_PRIVATE;
5657         }
5658
5659         if (o->op_flags & OPf_SPECIAL)
5660             pm->op_pmflags |= PMf_SPLIT;
5661
5662         /* the OP_REGCMAYBE is a placeholder in the non-threaded case
5663          * to allow its op_next to be pointed past the regcomp and
5664          * preceding stacking ops;
5665          * OP_REGCRESET is there to reset taint before executing the
5666          * stacking ops */
5667         if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
5668             expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
5669
5670         if (pm->op_pmflags & PMf_HAS_CV) {
5671             /* we have a runtime qr with literal code. This means
5672              * that the qr// has been wrapped in a new CV, which
5673              * means that runtime consts, vars etc will have been compiled
5674              * against a new pad. So... we need to execute those ops
5675              * within the environment of the new CV. So wrap them in a call
5676              * to a new anon sub. i.e. for
5677              *
5678              *     qr/a$b(?{...})/,
5679              *
5680              * we build an anon sub that looks like
5681              *
5682              *     sub { "a", $b, '(?{...})' }
5683              *
5684              * and call it, passing the returned list to regcomp.
5685              * Or to put it another way, the list of ops that get executed
5686              * are:
5687              *
5688              *     normal              PMf_HAS_CV
5689              *     ------              -------------------
5690              *                         pushmark (for regcomp)
5691              *                         pushmark (for entersub)
5692              *                         anoncode
5693              *                         srefgen
5694              *                         entersub
5695              *     regcreset                  regcreset
5696              *     pushmark                   pushmark
5697              *     const("a")                 const("a")
5698              *     gvsv(b)                    gvsv(b)
5699              *     const("(?{...})")          const("(?{...})")
5700              *                                leavesub
5701              *     regcomp             regcomp
5702              */
5703
5704             SvREFCNT_inc_simple_void(PL_compcv);
5705             CvLVALUE_on(PL_compcv);
5706             /* these lines are just an unrolled newANONATTRSUB */
5707             expr = newSVOP(OP_ANONCODE, 0,
5708                     MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
5709             cv_targ = expr->op_targ;
5710             expr = newUNOP(OP_REFGEN, 0, expr);
5711
5712             expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
5713         }
5714
5715         rcop = S_alloc_LOGOP(aTHX_ OP_REGCOMP, scalar(expr), o);
5716         rcop->op_flags |=  ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
5717                            | (reglist ? OPf_STACKED : 0);
5718         rcop->op_targ = cv_targ;
5719
5720         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
5721         if (PL_hints & HINT_RE_EVAL)
5722             S_set_haseval(aTHX);
5723
5724         /* establish postfix order */
5725         if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
5726             LINKLIST(expr);
5727             rcop->op_next = expr;
5728             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
5729         }
5730         else {
5731             rcop->op_next = LINKLIST(expr);
5732             expr->op_next = (OP*)rcop;
5733         }
5734
5735         op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
5736     }
5737
5738     if (repl) {
5739         OP *curop = repl;
5740         bool konst;
5741         /* If we are looking at s//.../e with a single statement, get past
5742            the implicit do{}. */
5743         if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
5744              && cUNOPx(curop)->op_first->op_type == OP_SCOPE
5745              && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
5746          {
5747             OP *sib;
5748             OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
5749             if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
5750              && !OpHAS_SIBLING(sib))
5751                 curop = sib;
5752         }
5753         if (curop->op_type == OP_CONST)
5754             konst = TRUE;
5755         else if (( (curop->op_type == OP_RV2SV ||
5756                     curop->op_type == OP_RV2AV ||
5757                     curop->op_type == OP_RV2HV ||
5758                     curop->op_type == OP_RV2GV)
5759                    && cUNOPx(curop)->op_first
5760                    && cUNOPx(curop)->op_first->op_type == OP_GV )
5761                 || curop->op_type == OP_PADSV
5762                 || curop->op_type == OP_PADAV
5763                 || curop->op_type == OP_PADHV
5764                 || curop->op_type == OP_PADANY) {
5765             repl_has_vars = 1;
5766             konst = TRUE;
5767         }
5768         else konst = FALSE;
5769         if (konst
5770             && !(repl_has_vars
5771                  && (!PM_GETRE(pm)
5772                      || !RX_PRELEN(PM_GETRE(pm))
5773                      || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
5774         {
5775             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
5776             op_prepend_elem(o->op_type, scalar(repl), o);
5777         }
5778         else {
5779             rcop = S_alloc_LOGOP(aTHX_ OP_SUBSTCONT, scalar(repl), o);
5780             rcop->op_private = 1;
5781
5782             /* establish postfix order */
5783             rcop->op_next = LINKLIST(repl);
5784             repl->op_next = (OP*)rcop;
5785
5786             pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
5787             assert(!(pm->op_pmflags & PMf_ONCE));
5788             pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
5789             rcop->op_next = 0;
5790         }
5791     }
5792
5793     return (OP*)pm;
5794 }
5795
5796 /*
5797 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
5798
5799 Constructs, checks, and returns an op of any type that involves an
5800 embedded SV.  I<type> is the opcode.  I<flags> gives the eight bits
5801 of C<op_flags>.  I<sv> gives the SV to embed in the op; this function
5802 takes ownership of one reference to it.
5803
5804 =cut
5805 */
5806
5807 OP *
5808 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
5809 {
5810     dVAR;
5811     SVOP *svop;
5812
5813     PERL_ARGS_ASSERT_NEWSVOP;
5814
5815     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5816         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5817         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5818         || type == OP_CUSTOM);
5819
5820     NewOp(1101, svop, 1, SVOP);
5821     CHANGE_TYPE(svop, type);
5822     svop->op_sv = sv;
5823     svop->op_next = (OP*)svop;
5824     svop->op_flags = (U8)flags;
5825     svop->op_private = (U8)(0 | (flags >> 8));
5826     if (PL_opargs[type] & OA_RETSCALAR)
5827         scalar((OP*)svop);
5828     if (PL_opargs[type] & OA_TARGET)
5829         svop->op_targ = pad_alloc(type, SVs_PADTMP);
5830     return CHECKOP(type, svop);
5831 }
5832
5833 /*
5834 =for apidoc Am|OP *|newDEFSVOP|
5835
5836 Constructs and returns an op to access C<$_>, either as a lexical
5837 variable (if declared as C<my $_>) in the current scope, or the
5838 global C<$_>.
5839
5840 =cut
5841 */
5842
5843 OP *
5844 Perl_newDEFSVOP(pTHX)
5845 {
5846     const PADOFFSET offset = pad_findmy_pvs("$_", 0);
5847     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5848         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
5849     }
5850     else {
5851         OP * const o = newOP(OP_PADSV, 0);
5852         o->op_targ = offset;
5853         return o;
5854     }
5855 }
5856
5857 #ifdef USE_ITHREADS
5858
5859 /*
5860 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
5861
5862 Constructs, checks, and returns an op of any type that involves a
5863 reference to a pad element.  I<type> is the opcode.  I<flags> gives the
5864 eight bits of C<op_flags>.  A pad slot is automatically allocated, and
5865 is populated with I<sv>; this function takes ownership of one reference
5866 to it.
5867
5868 This function only exists if Perl has been compiled to use ithreads.
5869
5870 =cut
5871 */
5872
5873 OP *
5874 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
5875 {
5876     dVAR;
5877     PADOP *padop;
5878
5879     PERL_ARGS_ASSERT_NEWPADOP;
5880
5881     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5882         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5883         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5884         || type == OP_CUSTOM);
5885
5886     NewOp(1101, padop, 1, PADOP);
5887     CHANGE_TYPE(padop, type);
5888     padop->op_padix =
5889         pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
5890     SvREFCNT_dec(PAD_SVl(padop->op_padix));
5891     PAD_SETSV(padop->op_padix, sv);
5892     assert(sv);
5893     padop->op_next = (OP*)padop;
5894     padop->op_flags = (U8)flags;
5895     if (PL_opargs[type] & OA_RETSCALAR)
5896         scalar((OP*)padop);
5897     if (PL_opargs[type] & OA_TARGET)
5898         padop->op_targ = pad_alloc(type, SVs_PADTMP);
5899     return CHECKOP(type, padop);
5900 }
5901
5902 #endif /* USE_ITHREADS */
5903
5904 /*
5905 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
5906
5907 Constructs, checks, and returns an op of any type that involves an
5908 embedded reference to a GV.  I<type> is the opcode.  I<flags> gives the
5909 eight bits of C<op_flags>.  I<gv> identifies the GV that the op should
5910 reference; calling this function does not transfer ownership of any
5911 reference to it.
5912
5913 =cut
5914 */
5915
5916 OP *
5917 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
5918 {
5919     PERL_ARGS_ASSERT_NEWGVOP;
5920
5921 #ifdef USE_ITHREADS
5922     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5923 #else
5924     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5925 #endif
5926 }
5927
5928 /*
5929 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
5930
5931 Constructs, checks, and returns an op of any type that involves an
5932 embedded C-level pointer (PV).  I<type> is the opcode.  I<flags> gives
5933 the eight bits of C<op_flags>.  I<pv> supplies the C-level pointer, which
5934 must have been allocated using C<PerlMemShared_malloc>; the memory will
5935 be freed when the op is destroyed.
5936
5937 =cut
5938 */
5939
5940 OP *
5941 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
5942 {
5943     dVAR;
5944     const bool utf8 = cBOOL(flags & SVf_UTF8);
5945     PVOP *pvop;
5946
5947     flags &= ~SVf_UTF8;
5948
5949     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5950         || type == OP_RUNCV || type == OP_CUSTOM
5951         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5952
5953     NewOp(1101, pvop, 1, PVOP);
5954     CHANGE_TYPE(pvop, type);
5955     pvop->op_pv = pv;
5956     pvop->op_next = (OP*)pvop;
5957     pvop->op_flags = (U8)flags;
5958     pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
5959     if (PL_opargs[type] & OA_RETSCALAR)
5960         scalar((OP*)pvop);
5961     if (PL_opargs[type] & OA_TARGET)
5962         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
5963     return CHECKOP(type, pvop);
5964 }
5965
5966 void
5967 Perl_package(pTHX_ OP *o)
5968 {
5969     SV *const sv = cSVOPo->op_sv;
5970
5971     PERL_ARGS_ASSERT_PACKAGE;
5972
5973     SAVEGENERICSV(PL_curstash);
5974     save_item(PL_curstname);
5975
5976     PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
5977
5978     sv_setsv(PL_curstname, sv);
5979
5980     PL_hints |= HINT_BLOCK_SCOPE;
5981     PL_parser->copline = NOLINE;
5982
5983     op_free(o);
5984 }
5985
5986 void
5987 Perl_package_version( pTHX_ OP *v )
5988 {
5989     U32 savehints = PL_hints;
5990     PERL_ARGS_ASSERT_PACKAGE_VERSION;
5991     PL_hints &= ~HINT_STRICT_VARS;
5992     sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
5993     PL_hints = savehints;
5994     op_free(v);
5995 }
5996
5997 void
5998 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
5999 {
6000     OP *pack;
6001     OP *imop;
6002     OP *veop;
6003     SV *use_version = NULL;
6004
6005     PERL_ARGS_ASSERT_UTILIZE;
6006
6007     if (idop->op_type != OP_CONST)
6008         Perl_croak(aTHX_ "Module name must be constant");
6009
6010     veop = NULL;
6011
6012     if (version) {
6013         SV * const vesv = ((SVOP*)version)->op_sv;
6014
6015         if (!arg && !SvNIOKp(vesv)) {
6016             arg = version;
6017         }
6018         else {
6019             OP *pack;
6020             SV *meth;
6021
6022             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
6023                 Perl_croak(aTHX_ "Version number must be a constant number");
6024
6025             /* Make copy of idop so we don't free it twice */
6026             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
6027
6028             /* Fake up a method call to VERSION */
6029             meth = newSVpvs_share("VERSION");
6030             veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
6031                             op_append_elem(OP_LIST,
6032                                         op_prepend_elem(OP_LIST, pack, version),
6033                                         newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
6034         }
6035     }
6036
6037     /* Fake up an import/unimport */
6038     if (arg && arg->op_type == OP_STUB) {
6039         imop = arg;             /* no import on explicit () */
6040     }
6041     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
6042         imop = NULL;            /* use 5.0; */
6043         if (aver)
6044             use_version = ((SVOP*)idop)->op_sv;
6045         else
6046             idop->op_private |= OPpCONST_NOVER;
6047     }
6048     else {
6049         SV *meth;
6050
6051         /* Make copy of idop so we don't free it twice */
6052         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
6053
6054         /* Fake up a method call to import/unimport */
6055         meth = aver
6056             ? newSVpvs_share("import") : newSVpvs_share("unimport");
6057         imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
6058                        op_append_elem(OP_LIST,
6059                                    op_prepend_elem(OP_LIST, pack, arg),
6060                                    newMETHOP_named(OP_METHOD_NAMED, 0, meth)
6061                        ));
6062     }
6063
6064     /* Fake up the BEGIN {}, which does its thing immediately. */
6065     newATTRSUB(floor,
6066         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
6067         NULL,
6068         NULL,
6069         op_append_elem(OP_LINESEQ,
6070             op_append_elem(OP_LINESEQ,
6071                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
6072                 newSTATEOP(0, NULL, veop)),
6073             newSTATEOP(0, NULL, imop) ));
6074
6075     if (use_version) {
6076         /* Enable the
6077          * feature bundle that corresponds to the required version. */
6078         use_version = sv_2mortal(new_version(use_version));
6079         S_enable_feature_bundle(aTHX_ use_version);
6080
6081         /* If a version >= 5.11.0 is requested, strictures are on by default! */
6082         if (vcmp(use_version,
6083                  sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
6084             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
6085                 PL_hints |= HINT_STRICT_REFS;
6086             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
6087                 PL_hints |= HINT_STRICT_SUBS;
6088             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
6089                 PL_hints |= HINT_STRICT_VARS;
6090         }
6091         /* otherwise they are off */
6092         else {
6093             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
6094                 PL_hints &= ~HINT_STRICT_REFS;
6095             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
6096                 PL_hints &= ~HINT_STRICT_SUBS;
6097             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
6098                 PL_hints &= ~HINT_STRICT_VARS;
6099         }
6100     }
6101
6102     /* The "did you use incorrect case?" warning used to be here.
6103      * The problem is that on case-insensitive filesystems one
6104      * might get false positives for "use" (and "require"):
6105      * "use Strict" or "require CARP" will work.  This causes
6106      * portability problems for the script: in case-strict
6107      * filesystems the script will stop working.
6108      *
6109      * The "incorrect case" warning checked whether "use Foo"
6110      * imported "Foo" to your namespace, but that is wrong, too:
6111      * there is no requirement nor promise in the language that
6112      * a Foo.pm should or would contain anything in package "Foo".
6113      *
6114      * There is very little Configure-wise that can be done, either:
6115      * the case-sensitivity of the build filesystem of Perl does not
6116      * help in guessing the case-sensitivity of the runtime environment.
6117      */
6118
6119     PL_hints |= HINT_BLOCK_SCOPE;
6120     PL_parser->copline = NOLINE;
6121     COP_SEQMAX_INC; /* Purely for B::*'s benefit */
6122 }
6123
6124 /*
6125 =head1 Embedding Functions
6126
6127 =for apidoc load_module
6128
6129 Loads the module whose name is pointed to by the string part of name.
6130 Note that the actual module name, not its filename, should be given.
6131 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
6132 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
6133 (or 0 for no flags).  ver, if specified
6134 and not NULL, provides version semantics
6135 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
6136 arguments can be used to specify arguments to the module's import()
6137 method, similar to C<use Foo::Bar VERSION LIST>.  They must be
6138 terminated with a final NULL pointer.  Note that this list can only
6139 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
6140 Otherwise at least a single NULL pointer to designate the default
6141 import list is required.
6142
6143 The reference count for each specified C<SV*> parameter is decremented.
6144
6145 =cut */
6146
6147 void
6148 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
6149 {
6150     va_list args;
6151
6152     PERL_ARGS_ASSERT_LOAD_MODULE;
6153
6154     va_start(args, ver);
6155     vload_module(flags, name, ver, &args);
6156     va_end(args);
6157 }
6158
6159 #ifdef PERL_IMPLICIT_CONTEXT
6160 void
6161 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
6162 {
6163     dTHX;
6164     va_list args;
6165     PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
6166     va_start(args, ver);
6167     vload_module(flags, name, ver, &args);
6168     va_end(args);
6169 }
6170 #endif
6171
6172 void
6173 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
6174 {
6175     OP *veop, *imop;
6176     OP * const modname = newSVOP(OP_CONST, 0, name);
6177
6178     PERL_ARGS_ASSERT_VLOAD_MODULE;
6179
6180     modname->op_private |= OPpCONST_BARE;
6181     if (ver) {
6182         veop = newSVOP(OP_CONST, 0, ver);
6183     }
6184     else
6185         veop = NULL;
6186     if (flags & PERL_LOADMOD_NOIMPORT) {
6187         imop = sawparens(newNULLLIST());
6188     }
6189     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
6190         imop = va_arg(*args, OP*);
6191     }
6192     else {
6193         SV *sv;
6194         imop = NULL;
6195         sv = va_arg(*args, SV*);
6196         while (sv) {
6197             imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
6198             sv = va_arg(*args, SV*);
6199         }
6200     }
6201
6202     /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
6203      * that it has a PL_parser to play with while doing that, and also
6204      * that it doesn't mess with any existing parser, by creating a tmp
6205      * new parser with lex_start(). This won't actually be used for much,
6206      * since pp_require() will create another parser for the real work.
6207      * The ENTER/LEAVE pair protect callers from any side effects of use.  */
6208
6209     ENTER;
6210     SAVEVPTR(PL_curcop);
6211     lex_start(NULL, NULL, LEX_START_SAME_FILTER);
6212     utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
6213             veop, modname, imop);
6214     LEAVE;
6215 }
6216
6217 PERL_STATIC_INLINE OP *
6218 S_new_entersubop(pTHX_ GV *gv, OP *arg)
6219 {
6220     return newUNOP(OP_ENTERSUB, OPf_STACKED,
6221                    newLISTOP(OP_LIST, 0, arg,
6222                              newUNOP(OP_RV2CV, 0,
6223                                      newGVOP(OP_GV, 0, gv))));
6224 }
6225
6226 OP *
6227 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
6228 {
6229     OP *doop;
6230     GV *gv;
6231
6232     PERL_ARGS_ASSERT_DOFILE;
6233
6234     if (!force_builtin && (gv = gv_override("do", 2))) {
6235         doop = S_new_entersubop(aTHX_ gv, term);
6236     }
6237     else {
6238         doop = newUNOP(OP_DOFILE, 0, scalar(term));
6239     }
6240     return doop;
6241 }
6242
6243 /*
6244 =head1 Optree construction
6245
6246 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
6247
6248 Constructs, checks, and returns an C<lslice> (list slice) op.  I<flags>
6249 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
6250 be set automatically, and, shifted up eight bits, the eight bits of
6251 C<op_private>, except that the bit with value 1 or 2 is automatically
6252 set as required.  I<listval> and I<subscript> supply the parameters of
6253 the slice; they are consumed by this function and become part of the
6254 constructed op tree.
6255
6256 =cut
6257 */
6258
6259 OP *
6260 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
6261 {
6262     return newBINOP(OP_LSLICE, flags,
6263             list(force_list(subscript, 1)),
6264             list(force_list(listval,   1)) );
6265 }
6266
6267 #define ASSIGN_LIST   1
6268 #define ASSIGN_REF    2
6269
6270 STATIC I32
6271 S_assignment_type(pTHX_ const OP *o)
6272 {
6273     unsigned type;
6274     U8 flags;
6275     U8 ret;
6276
6277     if (!o)
6278         return TRUE;
6279
6280     if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
6281         o = cUNOPo->op_first;
6282
6283     flags = o->op_flags;
6284     type = o->op_type;
6285     if (type == OP_COND_EXPR) {
6286         OP * const sib = OpSIBLING(cLOGOPo->op_first);
6287         const I32 t = assignment_type(sib);
6288         const I32 f = assignment_type(OpSIBLING(sib));
6289
6290         if (t == ASSIGN_LIST && f == ASSIGN_LIST)
6291             return ASSIGN_LIST;
6292         if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
6293             yyerror("Assignment to both a list and a scalar");
6294         return FALSE;
6295     }
6296
6297     if (type == OP_SREFGEN)
6298     {
6299         OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
6300         type = kid->op_type;
6301         flags |= kid->op_flags;
6302         if (!(flags & OPf_PARENS)
6303           && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
6304               kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
6305             return ASSIGN_REF;
6306         ret = ASSIGN_REF;
6307     }
6308     else ret = 0;
6309
6310     if (type == OP_LIST &&
6311         (flags & OPf_WANT) == OPf_WANT_SCALAR &&
6312         o->op_private & OPpLVAL_INTRO)
6313         return ret;
6314
6315     if (type == OP_LIST || flags & OPf_PARENS ||
6316         type == OP_RV2AV || type == OP_RV2HV ||
6317         type == OP_ASLICE || type == OP_HSLICE ||
6318         type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
6319         return TRUE;
6320
6321     if (type == OP_PADAV || type == OP_PADHV)
6322         return TRUE;
6323
6324     if (type == OP_RV2SV)
6325         return ret;
6326
6327     return ret;
6328 }
6329
6330 /*
6331   Helper function for newASSIGNOP to detect commonality between the
6332   lhs and the rhs.  (It is actually called very indirectly.  newASSIGNOP
6333   flags the op and the peephole optimizer calls this helper function
6334   if the flag is set.)  Marks all variables with PL_generation.  If it
6335   returns TRUE the assignment must be able to handle common variables.
6336
6337   PL_generation sorcery:
6338   An assignment like ($a,$b) = ($c,$d) is easier than
6339   ($a,$b) = ($c,$a), since there is no need for temporary vars.
6340   To detect whether there are common vars, the global var
6341   PL_generation is incremented for each assign op we compile.
6342   Then, while compiling the assign op, we run through all the
6343   variables on both sides of the assignment, setting a spare slot
6344   in each of them to PL_generation.  If any of them already have
6345   that value, we know we've got commonality.  Also, if the
6346   generation number is already set to PERL_INT_MAX, then
6347   the variable is involved in aliasing, so we also have
6348   potential commonality in that case.  We could use a
6349   single bit marker, but then we'd have to make 2 passes, first
6350   to clear the flag, then to test and set it.  And that
6351   wouldn't help with aliasing, either.  To find somewhere
6352   to store these values, evil chicanery is done with SvUVX().
6353 */
6354 PERL_STATIC_INLINE bool
6355 S_aassign_common_vars(pTHX_ OP* o)
6356 {
6357     OP *curop;
6358     for (curop = cUNOPo->op_first; curop; curop = OpSIBLING(curop)) {
6359         if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
6360             if (curop->op_type == OP_GV || curop->op_type == OP_GVSV
6361              || curop->op_type == OP_AELEMFAST) {
6362                 GV *gv = cGVOPx_gv(curop);
6363                 if (gv == PL_defgv
6364                     || (int)GvASSIGN_GENERATION(gv) == PL_generation)
6365                     return TRUE;
6366                 GvASSIGN_GENERATION_set(gv, PL_generation);
6367             }
6368             else if (curop->op_type == OP_PADSV ||
6369                 curop->op_type == OP_PADAV ||
6370                 curop->op_type == OP_PADHV ||
6371                 curop->op_type == OP_AELEMFAST_LEX ||
6372                 curop->op_type == OP_PADANY)
6373                 {
6374                   padcheck:
6375                     if (PAD_COMPNAME_GEN(curop->op_targ)
6376                         == (STRLEN)PL_generation
6377                      || PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX)
6378                         return TRUE;
6379                     PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
6380
6381                 }
6382             else if (curop->op_type == OP_RV2CV)
6383                 return TRUE;
6384             else if (curop->op_type == OP_RV2SV ||
6385                 curop->op_type == OP_RV2AV ||
6386                 curop->op_type == OP_RV2HV ||
6387                 curop->op_type == OP_RV2GV) {
6388                 if (cUNOPx(curop)->op_first->op_type != OP_GV)  /* funny deref? */
6389                     return TRUE;
6390             }
6391             else if (curop->op_type == OP_PUSHRE) {
6392                 GV *const gv =
6393 #ifdef USE_ITHREADS
6394                     ((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff
6395                         ? MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff))
6396                         : NULL;
6397 #else
6398                     ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
6399 #endif
6400                 if (gv) {
6401                     if (gv == PL_defgv
6402                         || (int)GvASSIGN_GENERATION(gv) == PL_generation)
6403                         return TRUE;
6404                     GvASSIGN_GENERATION_set(gv, PL_generation);
6405                 }
6406                 else if (curop->op_targ)
6407                     goto padcheck;
6408             }
6409             else if (curop->op_type == OP_PADRANGE)
6410                 /* Ignore padrange; checking its siblings is sufficient. */
6411                 continue;
6412             else
6413                 return TRUE;
6414         }
6415         else if (PL_opargs[curop->op_type] & OA_TARGLEX
6416               && curop->op_private & OPpTARGET_MY)
6417             goto padcheck;
6418
6419         if (curop->op_flags & OPf_KIDS) {
6420             if (aassign_common_vars(curop))
6421                 return TRUE;
6422         }
6423     }
6424     return FALSE;
6425 }
6426
6427 /* This variant only handles lexical aliases.  It is called when
6428    newASSIGNOP decides that we don’t have any common vars, as lexical ali-
6429    ases trump that decision.  */
6430 PERL_STATIC_INLINE bool
6431 S_aassign_common_vars_aliases_only(pTHX_ OP *o)
6432 {
6433     OP *curop;
6434     for (curop = cUNOPo->op_first; curop; curop = OpSIBLING(curop)) {
6435         if ((curop->op_type == OP_PADSV ||
6436              curop->op_type == OP_PADAV ||
6437              curop->op_type == OP_PADHV ||
6438              curop->op_type == OP_AELEMFAST_LEX ||
6439              curop->op_type == OP_PADANY ||
6440              (  PL_opargs[curop->op_type] & OA_TARGLEX
6441              && curop->op_private & OPpTARGET_MY  ))
6442            && PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX)
6443             return TRUE;
6444
6445         if (curop->op_type == OP_PUSHRE && curop->op_targ
6446          && PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX)
6447             return TRUE;
6448
6449         if (curop->op_flags & OPf_KIDS) {
6450             if (S_aassign_common_vars_aliases_only(aTHX_ curop))
6451                 return TRUE;
6452         }
6453     }
6454     return FALSE;
6455 }
6456
6457 /*
6458 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
6459
6460 Constructs, checks, and returns an assignment op.  I<left> and I<right>
6461 supply the parameters of the assignment; they are consumed by this
6462 function and become part of the constructed op tree.
6463
6464 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
6465 a suitable conditional optree is constructed.  If I<optype> is the opcode
6466 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
6467 performs the binary operation and assigns the result to the left argument.
6468 Either way, if I<optype> is non-zero then I<flags> has no effect.
6469
6470 If I<optype> is zero, then a plain scalar or list assignment is
6471 constructed.  Which type of assignment it is is automatically determined.
6472 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6473 will be set automatically, and, shifted up eight bits, the eight bits
6474 of C<op_private>, except that the bit with value 1 or 2 is automatically
6475 set as required.
6476
6477 =cut
6478 */
6479
6480 OP *
6481 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
6482 {
6483     OP *o;
6484     I32 assign_type;
6485
6486     if (optype) {
6487         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
6488             return newLOGOP(optype, 0,
6489                 op_lvalue(scalar(left), optype),
6490                 newUNOP(OP_SASSIGN, 0, scalar(right)));
6491         }
6492         else {
6493             return newBINOP(optype, OPf_STACKED,
6494                 op_lvalue(scalar(left), optype), scalar(right));
6495         }
6496     }
6497
6498     if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
6499         static const char no_list_state[] = "Initialization of state variables"
6500             " in list context currently forbidden";
6501         OP *curop;
6502         bool maybe_common_vars = TRUE;
6503
6504         if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
6505             left->op_private &= ~ OPpSLICEWARNING;
6506
6507         PL_modcount = 0;
6508         left = op_lvalue(left, OP_AASSIGN);
6509         curop = list(force_list(left, 1));
6510         o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
6511         o->op_private = (U8)(0 | (flags >> 8));
6512
6513         if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
6514         {
6515             OP* lop = ((LISTOP*)left)->op_first;
6516             maybe_common_vars = FALSE;
6517             while (lop) {
6518                 if (lop->op_type == OP_PADSV ||
6519                     lop->op_type == OP_PADAV ||
6520                     lop->op_type == OP_PADHV ||
6521                     lop->op_type == OP_PADANY) {
6522                     if (!(lop->op_private & OPpLVAL_INTRO))
6523                         maybe_common_vars = TRUE;
6524
6525                     if (lop->op_private & OPpPAD_STATE) {
6526                         if (left->op_private & OPpLVAL_INTRO) {
6527                             /* Each variable in state($a, $b, $c) = ... */
6528                         }
6529                         else {
6530                             /* Each state variable in
6531                                (state $a, my $b, our $c, $d, undef) = ... */
6532                         }
6533                         yyerror(no_list_state);
6534                     } else {
6535                         /* Each my variable in
6536                            (state $a, my $b, our $c, $d, undef) = ... */
6537                     }
6538                 } else if (lop->op_type == OP_UNDEF ||
6539                            OP_TYPE_IS_OR_WAS(lop, OP_PUSHMARK)) {
6540                     /* undef may be interesting in
6541                        (state $a, undef, state $c) */
6542                 } else {
6543                     /* Other ops in the list. */
6544                     maybe_common_vars = TRUE;
6545                 }
6546                 lop = OpSIBLING(lop);
6547             }
6548         }
6549         else if ((left->op_private & OPpLVAL_INTRO)
6550                 && (   left->op_type == OP_PADSV
6551                     || left->op_type == OP_PADAV
6552                     || left->op_type == OP_PADHV
6553                     || left->op_type == OP_PADANY))
6554         {
6555             if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
6556             if (left->op_private & OPpPAD_STATE) {
6557                 /* All single variable list context state assignments, hence
6558                    state ($a) = ...
6559                    (state $a) = ...
6560                    state @a = ...
6561                    state (@a) = ...
6562                    (state @a) = ...
6563                    state %a = ...
6564                    state (%a) = ...
6565                    (state %a) = ...
6566                 */
6567                 yyerror(no_list_state);
6568             }
6569         }
6570
6571         if (maybe_common_vars) {
6572                 /* The peephole optimizer will do the full check and pos-
6573                    sibly turn this off.  */
6574                 o->op_private |= OPpASSIGN_COMMON;
6575         }
6576
6577         if (right && right->op_type == OP_SPLIT
6578          && !(right->op_flags & OPf_STACKED)) {
6579             OP* tmpop = ((LISTOP*)right)->op_first;
6580             PMOP * const pm = (PMOP*)tmpop;
6581             assert (tmpop && (tmpop->op_type == OP_PUSHRE));
6582             if (
6583 #ifdef USE_ITHREADS
6584                     !pm->op_pmreplrootu.op_pmtargetoff
6585 #else
6586                     !pm->op_pmreplrootu.op_pmtargetgv
6587 #endif
6588                  && !pm->op_targ
6589                 ) {
6590                     if (!(left->op_private & OPpLVAL_INTRO) &&
6591                         ( (left->op_type == OP_RV2AV &&
6592                           (tmpop=((UNOP*)left)->op_first)->op_type==OP_GV)
6593                         || left->op_type == OP_PADAV )
6594                         ) {
6595                         if (tmpop != (OP *)pm) {
6596 #ifdef USE_ITHREADS
6597                           pm->op_pmreplrootu.op_pmtargetoff
6598                             = cPADOPx(tmpop)->op_padix;
6599                           cPADOPx(tmpop)->op_padix = 0; /* steal it */
6600 #else
6601                           pm->op_pmreplrootu.op_pmtargetgv
6602                             = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
6603                           cSVOPx(tmpop)->op_sv = NULL;  /* steal it */
6604 #endif
6605                           right->op_private |=
6606                             left->op_private & OPpOUR_INTRO;
6607                         }
6608                         else {
6609                             pm->op_targ = left->op_targ;
6610                             left->op_targ = 0; /* filch it */
6611                         }
6612                       detach_split:
6613                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
6614                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
6615                         /* detach rest of siblings from o subtree,
6616                          * and free subtree */
6617                         op_sibling_splice(cUNOPo->op_first, tmpop, -1, NULL);
6618                         op_free(o);                     /* blow off assign */
6619                         right->op_flags &= ~OPf_WANT;
6620                                 /* "I don't know and I don't care." */
6621                         return right;
6622                     }
6623                     else if (left->op_type == OP_RV2AV
6624                           || left->op_type == OP_PADAV)
6625                     {
6626                         /* Detach the array.  */
6627 #ifdef DEBUGGING
6628                         OP * const ary =
6629 #endif
6630                         op_sibling_splice(cBINOPo->op_last,
6631                                           cUNOPx(cBINOPo->op_last)
6632                                                 ->op_first, 1, NULL);
6633                         assert(ary == left);
6634                         /* Attach it to the split.  */
6635                         op_sibling_splice(right, cLISTOPx(right)->op_last,
6636                                           0, left);
6637                         right->op_flags |= OPf_STACKED;
6638                         /* Detach split and expunge aassign as above.  */
6639                         goto detach_split;
6640                     }
6641                     else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
6642                             ((LISTOP*)right)->op_last->op_type == OP_CONST)
6643                     {
6644                         SV ** const svp =
6645                             &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
6646                         SV * const sv = *svp;
6647                         if (SvIOK(sv) && SvIVX(sv) == 0)
6648                         {
6649                           if (right->op_private & OPpSPLIT_IMPLIM) {
6650                             /* our own SV, created in ck_split */
6651                             SvREADONLY_off(sv);
6652                             sv_setiv(sv, PL_modcount+1);
6653                           }
6654                           else {
6655                             /* SV may belong to someone else */
6656                             SvREFCNT_dec(sv);
6657                             *svp = newSViv(PL_modcount+1);
6658                           }
6659                         }
6660                     }
6661             }
6662         }
6663         return o;
6664     }
6665     if (assign_type == ASSIGN_REF)
6666         return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
6667     if (!right)
6668         right = newOP(OP_UNDEF, 0);
6669     if (right->op_type == OP_READLINE) {
6670         right->op_flags |= OPf_STACKED;
6671         return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
6672                 scalar(right));
6673     }
6674     else {
6675         o = newBINOP(OP_SASSIGN, flags,
6676             scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
6677     }
6678     return o;
6679 }
6680
6681 /*
6682 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
6683
6684 Constructs a state op (COP).  The state op is normally a C<nextstate> op,
6685 but will be a C<dbstate> op if debugging is enabled for currently-compiled
6686 code.  The state op is populated from C<PL_curcop> (or C<PL_compiling>).
6687 If I<label> is non-null, it supplies the name of a label to attach to
6688 the state op; this function takes ownership of the memory pointed at by
6689 I<label>, and will free it.  I<flags> gives the eight bits of C<op_flags>
6690 for the state op.
6691
6692 If I<o> is null, the state op is returned.  Otherwise the state op is
6693 combined with I<o> into a C<lineseq> list op, which is returned.  I<o>
6694 is consumed by this function and becomes part of the returned op tree.
6695
6696 =cut
6697 */
6698
6699 OP *
6700 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
6701 {
6702     dVAR;
6703     const U32 seq = intro_my();
6704     const U32 utf8 = flags & SVf_UTF8;
6705     COP *cop;
6706
6707     PL_parser->parsed_sub = 0;
6708
6709     flags &= ~SVf_UTF8;
6710
6711     NewOp(1101, cop, 1, COP);
6712     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
6713         CHANGE_TYPE(cop, OP_DBSTATE);
6714     }
6715     else {
6716         CHANGE_TYPE(cop, OP_NEXTSTATE);
6717     }
6718     cop->op_flags = (U8)flags;
6719     CopHINTS_set(cop, PL_hints);
6720 #ifdef VMS
6721     if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
6722 #endif
6723     cop->op_next = (OP*)cop;
6724
6725     cop->cop_seq = seq;
6726     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
6727     CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
6728     if (label) {
6729         Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
6730
6731         PL_hints |= HINT_BLOCK_SCOPE;
6732         /* It seems that we need to defer freeing this pointer, as other parts
6733            of the grammar end up wanting to copy it after this op has been
6734            created. */
6735         SAVEFREEPV(label);
6736     }
6737
6738     if (PL_parser->preambling != NOLINE) {
6739         CopLINE_set(cop, PL_parser->preambling);
6740         PL_parser->copline = NOLINE;
6741     }
6742     else if (PL_parser->copline == NOLINE)
6743         CopLINE_set(cop, CopLINE(PL_curcop));
6744     else {
6745         CopLINE_set(cop, PL_parser->copline);
6746         PL_parser->copline = NOLINE;
6747     }
6748 #ifdef USE_ITHREADS
6749     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
6750 #else
6751     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
6752 #endif
6753     CopSTASH_set(cop, PL_curstash);
6754
6755     if (cop->op_type == OP_DBSTATE) {
6756         /* this line can have a breakpoint - store the cop in IV */
6757         AV *av = CopFILEAVx(PL_curcop);
6758         if (av) {
6759             SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
6760             if (svp && *svp != &PL_sv_undef ) {
6761                 (void)SvIOK_on(*svp);
6762                 SvIV_set(*svp, PTR2IV(cop));
6763             }
6764         }
6765     }
6766
6767     if (flags & OPf_SPECIAL)
6768         op_null((OP*)cop);
6769     return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
6770 }
6771
6772 /*
6773 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
6774
6775 Constructs, checks, and returns a logical (flow control) op.  I<type>
6776 is the opcode.  I<flags> gives the eight bits of C<op_flags>, except
6777 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6778 the eight bits of C<op_private>, except that the bit with value 1 is
6779 automatically set.  I<first> supplies the expression controlling the
6780 flow, and I<other> supplies the side (alternate) chain of ops; they are
6781 consumed by this function and become part of the constructed op tree.
6782
6783 =cut
6784 */
6785
6786 OP *
6787 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
6788 {
6789     PERL_ARGS_ASSERT_NEWLOGOP;
6790
6791     return new_logop(type, flags, &first, &other);
6792 }
6793
6794 STATIC OP *
6795 S_search_const(pTHX_ OP *o)
6796 {
6797     PERL_ARGS_ASSERT_SEARCH_CONST;
6798
6799     switch (o->op_type) {
6800         case OP_CONST:
6801             return o;
6802         case OP_NULL:
6803             if (o->op_flags & OPf_KIDS)
6804                 return search_const(cUNOPo->op_first);
6805             break;
6806         case OP_LEAVE:
6807         case OP_SCOPE:
6808         case OP_LINESEQ:
6809         {
6810             OP *kid;
6811             if (!(o->op_flags & OPf_KIDS))
6812                 return NULL;
6813             kid = cLISTOPo->op_first;
6814             do {
6815                 switch (kid->op_type) {
6816                     case OP_ENTER:
6817                     case OP_NULL:
6818                     case OP_NEXTSTATE:
6819                         kid = OpSIBLING(kid);
6820                         break;
6821                     default:
6822                         if (kid != cLISTOPo->op_last)
6823                             return NULL;
6824                         goto last;
6825                 }
6826             } while (kid);
6827             if (!kid)
6828                 kid = cLISTOPo->op_last;
6829           last:
6830             return search_const(kid);
6831         }
6832     }
6833
6834     return NULL;
6835 }
6836
6837 STATIC OP *
6838 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
6839 {
6840     dVAR;
6841     LOGOP *logop;
6842     OP *o;
6843     OP *first;
6844     OP *other;
6845     OP *cstop = NULL;
6846     int prepend_not = 0;
6847
6848     PERL_ARGS_ASSERT_NEW_LOGOP;
6849
6850     first = *firstp;
6851     other = *otherp;
6852
6853     /* [perl #59802]: Warn about things like "return $a or $b", which
6854        is parsed as "(return $a) or $b" rather than "return ($a or
6855        $b)".  NB: This also applies to xor, which is why we do it
6856        here.
6857      */
6858     switch (first->op_type) {
6859     case OP_NEXT:
6860     case OP_LAST:
6861     case OP_REDO:
6862         /* XXX: Perhaps we should emit a stronger warning for these.
6863            Even with the high-precedence operator they don't seem to do
6864            anything sensible.
6865
6866            But until we do, fall through here.
6867          */
6868     case OP_RETURN:
6869     case OP_EXIT:
6870     case OP_DIE:
6871     case OP_GOTO:
6872         /* XXX: Currently we allow people to "shoot themselves in the
6873            foot" by explicitly writing "(return $a) or $b".
6874
6875            Warn unless we are looking at the result from folding or if
6876            the programmer explicitly grouped the operators like this.
6877            The former can occur with e.g.
6878
6879                 use constant FEATURE => ( $] >= ... );
6880                 sub { not FEATURE and return or do_stuff(); }
6881          */
6882         if (!first->op_folded && !(first->op_flags & OPf_PARENS))
6883             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6884                            "Possible precedence issue with control flow operator");
6885         /* XXX: Should we optimze this to "return $a;" (i.e. remove
6886            the "or $b" part)?
6887         */
6888         break;
6889     }
6890
6891     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
6892         return newBINOP(type, flags, scalar(first), scalar(other));
6893
6894     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
6895         || type == OP_CUSTOM);
6896
6897     scalarboolean(first);
6898     /* optimize AND and OR ops that have NOTs as children */
6899     if (first->op_type == OP_NOT
6900         && (first->op_flags & OPf_KIDS)
6901         && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
6902             || (other->op_type == OP_NOT))  /* if (!$x && !$y) { } */
6903         ) {
6904         if (type == OP_AND || type == OP_OR) {
6905             if (type == OP_AND)
6906                 type = OP_OR;
6907             else
6908                 type = OP_AND;
6909             op_null(first);
6910             if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
6911                 op_null(other);
6912                 prepend_not = 1; /* prepend a NOT op later */
6913             }
6914         }
6915     }
6916     /* search for a constant op that could let us fold the test */
6917     if ((cstop = search_const(first))) {
6918         if (cstop->op_private & OPpCONST_STRICT)
6919             no_bareword_allowed(cstop);
6920         else if ((cstop->op_private & OPpCONST_BARE))
6921                 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
6922         if ((type == OP_AND &&  SvTRUE(((SVOP*)cstop)->op_sv)) ||
6923             (type == OP_OR  && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
6924             (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
6925             *firstp = NULL;
6926             if (other->op_type == OP_CONST)
6927                 other->op_private |= OPpCONST_SHORTCIRCUIT;
6928             op_free(first);
6929             if (other->op_type == OP_LEAVE)
6930                 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
6931             else if (other->op_type == OP_MATCH
6932                   || other->op_type == OP_SUBST
6933                   || other->op_type == OP_TRANSR
6934                   || other->op_type == OP_TRANS)
6935                 /* Mark the op as being unbindable with =~ */
6936                 other->op_flags |= OPf_SPECIAL;
6937
6938             other->op_folded = 1;
6939             return other;
6940         }
6941         else {
6942             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
6943             const OP *o2 = other;
6944             if ( ! (o2->op_type == OP_LIST
6945                     && (( o2 = cUNOPx(o2)->op_first))
6946                     && o2->op_type == OP_PUSHMARK
6947                     && (( o2 = OpSIBLING(o2))) )
6948             )
6949                 o2 = other;
6950             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
6951                         || o2->op_type == OP_PADHV)
6952                 && o2->op_private & OPpLVAL_INTRO
6953                 && !(o2->op_private & OPpPAD_STATE))
6954             {
6955                 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6956                                  "Deprecated use of my() in false conditional");
6957             }
6958
6959             *otherp = NULL;
6960             if (cstop->op_type == OP_CONST)
6961                 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
6962                 op_free(other);
6963             return first;
6964         }
6965     }
6966     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
6967         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
6968     {
6969         const OP * const k1 = ((UNOP*)first)->op_first;
6970         const OP * const k2 = OpSIBLING(k1);
6971         OPCODE warnop = 0;
6972         switch (first->op_type)
6973         {
6974         case OP_NULL:
6975             if (k2 && k2->op_type == OP_READLINE
6976                   && (k2->op_flags & OPf_STACKED)
6977                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6978             {
6979                 warnop = k2->op_type;
6980             }
6981             break;
6982
6983         case OP_SASSIGN:
6984             if (k1->op_type == OP_READDIR
6985                   || k1->op_type == OP_GLOB
6986                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6987                  || k1->op_type == OP_EACH
6988                  || k1->op_type == OP_AEACH)
6989             {
6990                 warnop = ((k1->op_type == OP_NULL)
6991                           ? (OPCODE)k1->op_targ : k1->op_type);
6992             }
6993             break;
6994         }
6995         if (warnop) {
6996             const line_t oldline = CopLINE(PL_curcop);
6997             /* This ensures that warnings are reported at the first line
6998                of the construction, not the last.  */
6999             CopLINE_set(PL_curcop, PL_parser->copline);
7000             Perl_warner(aTHX_ packWARN(WARN_MISC),
7001                  "Value of %s%s can be \"0\"; test with defined()",
7002                  PL_op_desc[warnop],
7003                  ((warnop == OP_READLINE || warnop == OP_GLOB)
7004                   ? " construct" : "() operator"));
7005             CopLINE_set(PL_curcop, oldline);
7006         }
7007     }
7008
7009     if (!other)
7010         return first;
7011
7012     if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
7013         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
7014
7015     logop = S_alloc_LOGOP(aTHX_ type, first, LINKLIST(other));
7016     logop->op_flags |= (U8)flags;
7017     logop->op_private = (U8)(1 | (flags >> 8));
7018
7019     /* establish postfix order */
7020     logop->op_next = LINKLIST(first);
7021     first->op_next = (OP*)logop;
7022     assert(!OpHAS_SIBLING(first));
7023     op_sibling_splice((OP*)logop, first, 0, other);
7024
7025     CHECKOP(type,logop);
7026
7027     o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
7028                 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
7029                 (OP*)logop);
7030     other->op_next = o;
7031
7032     return o;
7033 }
7034
7035 /*
7036 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
7037
7038 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
7039 op.  I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
7040 will be set automatically, and, shifted up eight bits, the eight bits of
7041 C<op_private>, except that the bit with value 1 is automatically set.
7042 I<first> supplies the expression selecting between the two branches,
7043 and I<trueop> and I<falseop> supply the branches; they are consumed by
7044 this function and become part of the constructed op tree.
7045
7046 =cut
7047 */
7048
7049 OP *
7050 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
7051 {
7052     dVAR;
7053     LOGOP *logop;
7054     OP *start;
7055     OP *o;
7056     OP *cstop;
7057
7058     PERL_ARGS_ASSERT_NEWCONDOP;
7059
7060     if (!falseop)
7061         return newLOGOP(OP_AND, 0, first, trueop);
7062     if (!trueop)
7063         return newLOGOP(OP_OR, 0, first, falseop);
7064
7065     scalarboolean(first);
7066     if ((cstop = search_const(first))) {
7067         /* Left or right arm of the conditional?  */
7068         const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
7069         OP *live = left ? trueop : falseop;
7070         OP *const dead = left ? falseop : trueop;
7071         if (cstop->op_private & OPpCONST_BARE &&
7072             cstop->op_private & OPpCONST_STRICT) {
7073             no_bareword_allowed(cstop);
7074         }
7075         op_free(first);
7076         op_free(dead);
7077         if (live->op_type == OP_LEAVE)
7078             live = newUNOP(OP_NULL, OPf_SPECIAL, live);
7079         else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
7080               || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
7081             /* Mark the op as being unbindable with =~ */
7082             live->op_flags |= OPf_SPECIAL;
7083         live->op_folded = 1;
7084         return live;
7085     }
7086     logop = S_alloc_LOGOP(aTHX_ OP_COND_EXPR, first, LINKLIST(trueop));
7087     logop->op_flags |= (U8)flags;
7088     logop->op_private = (U8)(1 | (flags >> 8));
7089     logop->op_next = LINKLIST(falseop);
7090
7091     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
7092             logop);
7093
7094     /* establish postfix order */
7095     start = LINKLIST(first);
7096     first->op_next = (OP*)logop;
7097
7098     /* make first, trueop, falseop siblings */
7099     op_sibling_splice((OP*)logop, first,  0, trueop);
7100     op_sibling_splice((OP*)logop, trueop, 0, falseop);
7101
7102     o = newUNOP(OP_NULL, 0, (OP*)logop);
7103
7104     trueop->op_next = falseop->op_next = o;
7105
7106     o->op_next = start;
7107     return o;
7108 }
7109
7110 /*
7111 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
7112
7113 Constructs and returns a C<range> op, with subordinate C<flip> and
7114 C<flop> ops.  I<flags> gives the eight bits of C<op_flags> for the
7115 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
7116 for both the C<flip> and C<range> ops, except that the bit with value
7117 1 is automatically set.  I<left> and I<right> supply the expressions
7118 controlling the endpoints of the range; they are consumed by this function
7119 and become part of the constructed op tree.
7120
7121 =cut
7122 */
7123
7124 OP *
7125 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
7126 {
7127     LOGOP *range;
7128     OP *flip;
7129     OP *flop;
7130     OP *leftstart;
7131     OP *o;
7132
7133     PERL_ARGS_ASSERT_NEWRANGE;
7134
7135     range = S_alloc_LOGOP(aTHX_ OP_RANGE, left, LINKLIST(right));
7136     range->op_flags = OPf_KIDS;
7137     leftstart = LINKLIST(left);
7138     range->op_private = (U8)(1 | (flags >> 8));
7139
7140     /* make left and right siblings */
7141     op_sibling_splice((OP*)range, left, 0, right);
7142
7143     range->op_next = (OP*)range;
7144     flip = newUNOP(OP_FLIP, flags, (OP*)range);
7145     flop = newUNOP(OP_FLOP, 0, flip);
7146     o = newUNOP(OP_NULL, 0, flop);
7147     LINKLIST(flop);
7148     range->op_next = leftstart;
7149
7150     left->op_next = flip;
7151     right->op_next = flop;
7152
7153     range->op_targ =
7154         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
7155     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
7156     flip->op_targ =
7157         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
7158     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
7159     SvPADTMP_on(PAD_SV(flip->op_targ));
7160
7161     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
7162     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
7163
7164     /* check barewords before they might be optimized aways */
7165     if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
7166         no_bareword_allowed(left);
7167     if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
7168         no_bareword_allowed(right);
7169
7170     flip->op_next = o;
7171     if (!flip->op_private || !flop->op_private)
7172         LINKLIST(o);            /* blow off optimizer unless constant */
7173
7174     return o;
7175 }
7176
7177 /*
7178 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
7179
7180 Constructs, checks, and returns an op tree expressing a loop.  This is
7181 only a loop in the control flow through the op tree; it does not have
7182 the heavyweight loop structure that allows exiting the loop by C<last>
7183 and suchlike.  I<flags> gives the eight bits of C<op_flags> for the
7184 top-level op, except that some bits will be set automatically as required.
7185 I<expr> supplies the expression controlling loop iteration, and I<block>
7186 supplies the body of the loop; they are consumed by this function and
7187 become part of the constructed op tree.  I<debuggable> is currently
7188 unused and should always be 1.
7189
7190 =cut
7191 */
7192
7193 OP *
7194 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
7195 {
7196     OP* listop;
7197     OP* o;
7198     const bool once = block && block->op_flags & OPf_SPECIAL &&
7199                       block->op_type == OP_NULL;
7200
7201     PERL_UNUSED_ARG(debuggable);
7202
7203     if (expr) {
7204         if (once && (
7205               (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
7206            || (  expr->op_type == OP_NOT
7207               && cUNOPx(expr)->op_first->op_type == OP_CONST
7208               && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
7209               )
7210            ))
7211             /* Return the block now, so that S_new_logop does not try to
7212                fold it away. */
7213             return block;       /* do {} while 0 does once */
7214         if (expr->op_type == OP_READLINE
7215             || expr->op_type == OP_READDIR
7216             || expr->op_type == OP_GLOB
7217             || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
7218             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
7219             expr = newUNOP(OP_DEFINED, 0,
7220                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
7221         } else if (expr->op_flags & OPf_KIDS) {
7222             const OP * const k1 = ((UNOP*)expr)->op_first;
7223             const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
7224             switch (expr->op_type) {
7225               case OP_NULL:
7226                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
7227                       && (k2->op_flags & OPf_STACKED)
7228                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7229                     expr = newUNOP(OP_DEFINED, 0, expr);
7230                 break;
7231
7232               case OP_SASSIGN:
7233                 if (k1 && (k1->op_type == OP_READDIR
7234                       || k1->op_type == OP_GLOB
7235                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7236                      || k1->op_type == OP_EACH
7237                      || k1->op_type == OP_AEACH))
7238                     expr = newUNOP(OP_DEFINED, 0, expr);
7239                 break;
7240             }
7241         }
7242     }
7243
7244     /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
7245      * op, in listop. This is wrong. [perl #27024] */
7246     if (!block)
7247         block = newOP(OP_NULL, 0);
7248     listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
7249     o = new_logop(OP_AND, 0, &expr, &listop);
7250
7251     if (once) {
7252         ASSUME(listop);
7253     }
7254
7255     if (listop)
7256         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
7257
7258     if (once && o != listop)
7259     {
7260         assert(cUNOPo->op_first->op_type == OP_AND
7261             || cUNOPo->op_first->op_type == OP_OR);
7262         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
7263     }
7264
7265     if (o == listop)
7266         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
7267
7268     o->op_flags |= flags;
7269     o = op_scope(o);
7270     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
7271     return o;
7272 }
7273
7274 /*
7275 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
7276
7277 Constructs, checks, and returns an op tree expressing a C<while> loop.
7278 This is a heavyweight loop, with structure that allows exiting the loop
7279 by C<last> and suchlike.
7280
7281 I<loop> is an optional preconstructed C<enterloop> op to use in the
7282 loop; if it is null then a suitable op will be constructed automatically.
7283 I<expr> supplies the loop's controlling expression.  I<block> supplies the
7284 main body of the loop, and I<cont> optionally supplies a C<continue> block
7285 that operates as a second half of the body.  All of these optree inputs
7286 are consumed by this function and become part of the constructed op tree.
7287
7288 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7289 op and, shifted up eight bits, the eight bits of C<op_private> for
7290 the C<leaveloop> op, except that (in both cases) some bits will be set
7291 automatically.  I<debuggable> is currently unused and should always be 1.
7292 I<has_my> can be supplied as true to force the
7293 loop body to be enclosed in its own scope.
7294
7295 =cut
7296 */
7297
7298 OP *
7299 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
7300         OP *expr, OP *block, OP *cont, I32 has_my)
7301 {
7302     dVAR;
7303     OP *redo;
7304     OP *next = NULL;
7305     OP *listop;
7306     OP *o;
7307     U8 loopflags = 0;
7308
7309     PERL_UNUSED_ARG(debuggable);
7310
7311     if (expr) {
7312         if (expr->op_type == OP_READLINE
7313          || expr->op_type == OP_READDIR
7314          || expr->op_type == OP_GLOB
7315          || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
7316                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
7317             expr = newUNOP(OP_DEFINED, 0,
7318                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
7319         } else if (expr->op_flags & OPf_KIDS) {
7320             const OP * const k1 = ((UNOP*)expr)->op_first;
7321             const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
7322             switch (expr->op_type) {
7323               case OP_NULL:
7324                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
7325                       && (k2->op_flags & OPf_STACKED)
7326                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7327                     expr = newUNOP(OP_DEFINED, 0, expr);
7328                 break;
7329
7330               case OP_SASSIGN:
7331                 if (k1 && (k1->op_type == OP_READDIR
7332                       || k1->op_type == OP_GLOB
7333                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7334                      || k1->op_type == OP_EACH
7335                      || k1->op_type == OP_AEACH))
7336                     expr = newUNOP(OP_DEFINED, 0, expr);
7337                 break;
7338             }
7339         }
7340     }
7341
7342     if (!block)
7343         block = newOP(OP_NULL, 0);
7344     else if (cont || has_my) {
7345         block = op_scope(block);
7346     }
7347
7348     if (cont) {
7349         next = LINKLIST(cont);
7350     }
7351     if (expr) {
7352         OP * const unstack = newOP(OP_UNSTACK, 0);
7353         if (!next)
7354             next = unstack;
7355         cont = op_append_elem(OP_LINESEQ, cont, unstack);
7356     }
7357
7358     assert(block);
7359     listop = op_append_list(OP_LINESEQ, block, cont);
7360     assert(listop);
7361     redo = LINKLIST(listop);
7362
7363     if (expr) {
7364         scalar(listop);
7365         o = new_logop(OP_AND, 0, &expr, &listop);
7366         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
7367             op_free((OP*)loop);
7368             return expr;                /* listop already freed by new_logop */
7369         }
7370         if (listop)
7371             ((LISTOP*)listop)->op_last->op_next =
7372                 (o == listop ? redo : LINKLIST(o));
7373     }
7374     else
7375         o = listop;
7376
7377     if (!loop) {
7378         NewOp(1101,loop,1,LOOP);
7379         CHANGE_TYPE(loop, OP_ENTERLOOP);
7380         loop->op_private = 0;
7381         loop->op_next = (OP*)loop;
7382     }
7383
7384     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
7385
7386     loop->op_redoop = redo;
7387     loop->op_lastop = o;
7388     o->op_private |= loopflags;
7389
7390     if (next)
7391         loop->op_nextop = next;
7392     else
7393         loop->op_nextop = o;
7394
7395     o->op_flags |= flags;
7396     o->op_private |= (flags >> 8);
7397     return o;
7398 }
7399
7400 /*
7401 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
7402
7403 Constructs, checks, and returns an op tree expressing a C<foreach>
7404 loop (iteration through a list of values).  This is a heavyweight loop,
7405 with structure that allows exiting the loop by C<last> and suchlike.
7406
7407 I<sv> optionally supplies the variable that will be aliased to each
7408 item in turn; if null, it defaults to C<$_> (either lexical or global).
7409 I<expr> supplies the list of values to iterate over.  I<block> supplies
7410 the main body of the loop, and I<cont> optionally supplies a C<continue>
7411 block that operates as a second half of the body.  All of these optree
7412 inputs are consumed by this function and become part of the constructed
7413 op tree.
7414
7415 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7416 op and, shifted up eight bits, the eight bits of C<op_private> for
7417 the C<leaveloop> op, except that (in both cases) some bits will be set
7418 automatically.
7419
7420 =cut
7421 */
7422
7423 OP *
7424 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
7425 {
7426     dVAR;
7427     LOOP *loop;
7428     OP *wop;
7429     PADOFFSET padoff = 0;
7430     I32 iterflags = 0;
7431     I32 iterpflags = 0;
7432
7433     PERL_ARGS_ASSERT_NEWFOROP;
7434
7435     if (sv) {
7436         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
7437             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
7438             CHANGE_TYPE(sv, OP_RV2GV);
7439
7440             /* The op_type check is needed to prevent a possible segfault
7441              * if the loop variable is undeclared and 'strict vars' is in
7442              * effect. This is illegal but is nonetheless parsed, so we
7443              * may reach this point with an OP_CONST where we're expecting
7444              * an OP_GV.
7445              */
7446             if (cUNOPx(sv)->op_first->op_type == OP_GV
7447              && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
7448                 iterpflags |= OPpITER_DEF;
7449         }
7450         else if (sv->op_type == OP_PADSV) { /* private variable */
7451             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
7452             padoff = sv->op_targ;
7453             sv->op_targ = 0;
7454             op_free(sv);
7455             sv = NULL;
7456             PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
7457         }
7458         else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
7459             NOOP;
7460         else
7461             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
7462         if (padoff) {
7463             PADNAME * const pn = PAD_COMPNAME(padoff);
7464             const char * const name = PadnamePV(pn);
7465
7466             if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
7467                 iterpflags |= OPpITER_DEF;
7468         }
7469     }
7470     else {
7471         const PADOFFSET offset = pad_findmy_pvs("$_", 0);
7472         if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7473             sv = newGVOP(OP_GV, 0, PL_defgv);
7474         }
7475         else {
7476             padoff = offset;
7477         }
7478         iterpflags |= OPpITER_DEF;
7479     }
7480
7481     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
7482         expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
7483         iterflags |= OPf_STACKED;
7484     }
7485     else if (expr->op_type == OP_NULL &&
7486              (expr->op_flags & OPf_KIDS) &&
7487              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
7488     {
7489         /* Basically turn for($x..$y) into the same as for($x,$y), but we
7490          * set the STACKED flag to indicate that these values are to be
7491          * treated as min/max values by 'pp_enteriter'.
7492          */
7493         const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
7494         LOGOP* const range = (LOGOP*) flip->op_first;
7495         OP* const left  = range->op_first;
7496         OP* const right = OpSIBLING(left);
7497         LISTOP* listop;
7498
7499         range->op_flags &= ~OPf_KIDS;
7500         /* detach range's children */
7501         op_sibling_splice((OP*)range, NULL, -1, NULL);
7502
7503         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
7504         listop->op_first->op_next = range->op_next;
7505         left->op_next = range->op_other;
7506         right->op_next = (OP*)listop;
7507         listop->op_next = listop->op_first;
7508
7509         op_free(expr);
7510         expr = (OP*)(listop);
7511         op_null(expr);
7512         iterflags |= OPf_STACKED;
7513     }
7514     else {
7515         expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
7516     }
7517
7518     loop = (LOOP*)list(op_convert_list(OP_ENTERITER, iterflags,
7519                                op_append_elem(OP_LIST, expr, scalar(sv))));
7520     assert(!loop->op_next);
7521     /* for my  $x () sets OPpLVAL_INTRO;
7522      * for our $x () sets OPpOUR_INTRO */
7523     loop->op_private = (U8)iterpflags;
7524     if (loop->op_slabbed
7525      && DIFF(loop, OpSLOT(loop)->opslot_next)
7526          < SIZE_TO_PSIZE(sizeof(LOOP)))
7527     {
7528         LOOP *tmp;
7529         NewOp(1234,tmp,1,LOOP);
7530         Copy(loop,tmp,1,LISTOP);
7531 #ifdef PERL_OP_PARENT
7532         assert(loop->op_last->op_sibling == (OP*)loop);
7533         loop->op_last->op_sibling = (OP*)tmp; /*point back to new parent */
7534 #endif
7535         S_op_destroy(aTHX_ (OP*)loop);
7536         loop = tmp;
7537     }
7538     else if (!loop->op_slabbed)
7539     {
7540         loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
7541 #ifdef PERL_OP_PARENT
7542         loop->op_last->op_sibling = (OP *)loop;
7543 #endif
7544     }
7545     loop->op_targ = padoff;
7546     wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
7547     return wop;
7548 }
7549
7550 /*
7551 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
7552
7553 Constructs, checks, and returns a loop-exiting op (such as C<goto>
7554 or C<last>).  I<type> is the opcode.  I<label> supplies the parameter
7555 determining the target of the op; it is consumed by this function and
7556 becomes part of the constructed op tree.
7557
7558 =cut
7559 */
7560
7561 OP*
7562 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
7563 {
7564     OP *o = NULL;
7565
7566     PERL_ARGS_ASSERT_NEWLOOPEX;
7567
7568     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
7569         || type == OP_CUSTOM);
7570
7571     if (type != OP_GOTO) {
7572         /* "last()" means "last" */
7573         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
7574             o = newOP(type, OPf_SPECIAL);
7575         }
7576     }
7577     else {
7578         /* Check whether it's going to be a goto &function */
7579         if (label->op_type == OP_ENTERSUB
7580                 && !(label->op_flags & OPf_STACKED))
7581             label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
7582     }
7583
7584     /* Check for a constant argument */
7585     if (label->op_type == OP_CONST) {
7586             SV * const sv = ((SVOP *)label)->op_sv;
7587             STRLEN l;
7588             const char *s = SvPV_const(sv,l);
7589             if (l == strlen(s)) {
7590                 o = newPVOP(type,
7591                             SvUTF8(((SVOP*)label)->op_sv),
7592                             savesharedpv(
7593                                 SvPV_nolen_const(((SVOP*)label)->op_sv)));
7594             }
7595     }
7596
7597     /* If we have already created an op, we do not need the label. */
7598     if (o)
7599                 op_free(label);
7600     else o = newUNOP(type, OPf_STACKED, label);
7601
7602     PL_hints |= HINT_BLOCK_SCOPE;
7603     return o;
7604 }
7605
7606 /* if the condition is a literal array or hash
7607    (or @{ ... } etc), make a reference to it.
7608  */
7609 STATIC OP *
7610 S_ref_array_or_hash(pTHX_ OP *cond)
7611 {
7612     if (cond
7613     && (cond->op_type == OP_RV2AV
7614     ||  cond->op_type == OP_PADAV
7615     ||  cond->op_type == OP_RV2HV
7616     ||  cond->op_type == OP_PADHV))
7617
7618         return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
7619
7620     else if(cond
7621     && (cond->op_type == OP_ASLICE
7622     ||  cond->op_type == OP_KVASLICE
7623     ||  cond->op_type == OP_HSLICE
7624     ||  cond->op_type == OP_KVHSLICE)) {
7625
7626         /* anonlist now needs a list from this op, was previously used in
7627          * scalar context */
7628         cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
7629         cond->op_flags |= OPf_WANT_LIST;
7630
7631         return newANONLIST(op_lvalue(cond, OP_ANONLIST));
7632     }
7633
7634     else
7635         return cond;
7636 }
7637
7638 /* These construct the optree fragments representing given()
7639    and when() blocks.
7640
7641    entergiven and enterwhen are LOGOPs; the op_other pointer
7642    points up to the associated leave op. We need this so we
7643    can put it in the context and make break/continue work.
7644    (Also, of course, pp_enterwhen will jump straight to
7645    op_other if the match fails.)
7646  */
7647
7648 STATIC OP *
7649 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
7650                    I32 enter_opcode, I32 leave_opcode,
7651                    PADOFFSET entertarg)
7652 {
7653     dVAR;
7654     LOGOP *enterop;
7655     OP *o;
7656
7657     PERL_ARGS_ASSERT_NEWGIVWHENOP;
7658
7659     enterop = S_alloc_LOGOP(aTHX_ enter_opcode, block, NULL);
7660     enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
7661     enterop->op_private = 0;
7662
7663     o = newUNOP(leave_opcode, 0, (OP *) enterop);
7664
7665     if (cond) {
7666         /* prepend cond if we have one */
7667         op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
7668
7669         o->op_next = LINKLIST(cond);
7670         cond->op_next = (OP *) enterop;
7671     }
7672     else {
7673         /* This is a default {} block */
7674         enterop->op_flags |= OPf_SPECIAL;
7675         o      ->op_flags |= OPf_SPECIAL;
7676
7677         o->op_next = (OP *) enterop;
7678     }
7679
7680     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
7681                                        entergiven and enterwhen both
7682                                        use ck_null() */
7683
7684     enterop->op_next = LINKLIST(block);
7685     block->op_next = enterop->op_other = o;
7686
7687     return o;
7688 }
7689
7690 /* Does this look like a boolean operation? For these purposes
7691    a boolean operation is:
7692      - a subroutine call [*]
7693      - a logical connective
7694      - a comparison operator
7695      - a filetest operator, with the exception of -s -M -A -C
7696      - defined(), exists() or eof()
7697      - /$re/ or $foo =~ /$re/
7698
7699    [*] possibly surprising
7700  */
7701 STATIC bool
7702 S_looks_like_bool(pTHX_ const OP *o)
7703 {
7704     PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
7705
7706     switch(o->op_type) {
7707         case OP_OR:
7708         case OP_DOR:
7709             return looks_like_bool(cLOGOPo->op_first);
7710
7711         case OP_AND:
7712         {
7713             OP* sibl = OpSIBLING(cLOGOPo->op_first);
7714             ASSUME(sibl);
7715             return (
7716                 looks_like_bool(cLOGOPo->op_first)
7717              && looks_like_bool(sibl));
7718         }
7719
7720         case OP_NULL:
7721         case OP_SCALAR:
7722             return (
7723                 o->op_flags & OPf_KIDS
7724             && looks_like_bool(cUNOPo->op_first));
7725
7726         case OP_ENTERSUB:
7727
7728         case OP_NOT:    case OP_XOR:
7729
7730         case OP_EQ:     case OP_NE:     case OP_LT:
7731         case OP_GT:     case OP_LE:     case OP_GE:
7732
7733         case OP_I_EQ:   case OP_I_NE:   case OP_I_LT:
7734         case OP_I_GT:   case OP_I_LE:   case OP_I_GE:
7735
7736         case OP_SEQ:    case OP_SNE:    case OP_SLT:
7737         case OP_SGT:    case OP_SLE:    case OP_SGE:
7738
7739         case OP_SMARTMATCH:
7740
7741         case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
7742         case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
7743         case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
7744         case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
7745         case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
7746         case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
7747         case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
7748         case OP_FTTEXT:   case OP_FTBINARY:
7749
7750         case OP_DEFINED: case OP_EXISTS:
7751         case OP_MATCH:   case OP_EOF:
7752
7753         case OP_FLOP:
7754
7755             return TRUE;
7756
7757         case OP_CONST:
7758             /* Detect comparisons that have been optimized away */
7759             if (cSVOPo->op_sv == &PL_sv_yes
7760             ||  cSVOPo->op_sv == &PL_sv_no)
7761
7762                 return TRUE;
7763             else
7764                 return FALSE;
7765
7766         /* FALLTHROUGH */
7767         default:
7768             return FALSE;
7769     }
7770 }
7771
7772 /*
7773 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
7774
7775 Constructs, checks, and returns an op tree expressing a C<given> block.
7776 I<cond> supplies the expression that will be locally assigned to a lexical
7777 variable, and I<block> supplies the body of the C<given> construct; they
7778 are consumed by this function and become part of the constructed op tree.
7779 I<defsv_off> is the pad offset of the scalar lexical variable that will
7780 be affected.  If it is 0, the global $_ will be used.
7781
7782 =cut
7783 */
7784
7785 OP *
7786 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
7787 {
7788     PERL_ARGS_ASSERT_NEWGIVENOP;
7789     return newGIVWHENOP(
7790         ref_array_or_hash(cond),
7791         block,
7792         OP_ENTERGIVEN, OP_LEAVEGIVEN,
7793         defsv_off);
7794 }
7795
7796 /*
7797 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
7798
7799 Constructs, checks, and returns an op tree expressing a C<when> block.
7800 I<cond> supplies the test expression, and I<block> supplies the block
7801 that will be executed if the test evaluates to true; they are consumed
7802 by this function and become part of the constructed op tree.  I<cond>
7803 will be interpreted DWIMically, often as a comparison against C<$_>,
7804 and may be null to generate a C<default> block.
7805
7806 =cut
7807 */
7808
7809 OP *
7810 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
7811 {
7812     const bool cond_llb = (!cond || looks_like_bool(cond));
7813     OP *cond_op;
7814
7815     PERL_ARGS_ASSERT_NEWWHENOP;
7816
7817     if (cond_llb)
7818         cond_op = cond;
7819     else {
7820         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
7821                 newDEFSVOP(),
7822                 scalar(ref_array_or_hash(cond)));
7823     }
7824
7825     return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
7826 }
7827
7828 /* must not conflict with SVf_UTF8 */
7829 #define CV_CKPROTO_CURSTASH     0x1
7830
7831 void
7832 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
7833                     const STRLEN len, const U32 flags)
7834 {
7835     SV *name = NULL, *msg;
7836     const char * cvp = SvROK(cv)
7837                         ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
7838                            ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
7839                            : ""
7840                         : CvPROTO(cv);
7841     STRLEN clen = CvPROTOLEN(cv), plen = len;
7842
7843     PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
7844
7845     if (p == NULL && cvp == NULL)
7846         return;
7847
7848     if (!ckWARN_d(WARN_PROTOTYPE))
7849         return;
7850
7851     if (p && cvp) {
7852         p = S_strip_spaces(aTHX_ p, &plen);
7853         cvp = S_strip_spaces(aTHX_ cvp, &clen);
7854         if ((flags & SVf_UTF8) == SvUTF8(cv)) {
7855             if (plen == clen && memEQ(cvp, p, plen))
7856                 return;
7857         } else {
7858             if (flags & SVf_UTF8) {
7859                 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
7860                     return;
7861             }
7862             else {
7863                 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
7864                     return;
7865             }
7866         }
7867     }
7868
7869     msg = sv_newmortal();
7870
7871     if (gv)
7872     {
7873         if (isGV(gv))
7874             gv_efullname3(name = sv_newmortal(), gv, NULL);
7875         else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
7876             name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
7877         else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
7878             name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
7879             sv_catpvs(name, "::");
7880             if (SvROK(gv)) {
7881                 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
7882                 assert (CvNAMED(SvRV_const(gv)));
7883                 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
7884             }
7885             else sv_catsv(name, (SV *)gv);
7886         }
7887         else name = (SV *)gv;
7888     }
7889     sv_setpvs(msg, "Prototype mismatch:");
7890     if (name)
7891         Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
7892     if (cvp)
7893         Perl_sv_catpvf(aTHX_ msg, " (%"UTF8f")",
7894             UTF8fARG(SvUTF8(cv),clen,cvp)
7895         );
7896     else
7897         sv_catpvs(msg, ": none");
7898     sv_catpvs(msg, " vs ");
7899     if (p)
7900         Perl_sv_catpvf(aTHX_ msg, "(%"UTF8f")", UTF8fARG(flags & SVf_UTF8,len,p));
7901     else
7902         sv_catpvs(msg, "none");
7903     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
7904 }
7905
7906 static void const_sv_xsub(pTHX_ CV* cv);
7907 static void const_av_xsub(pTHX_ CV* cv);
7908
7909 /*
7910
7911 =head1 Optree Manipulation Functions
7912
7913 =for apidoc cv_const_sv
7914
7915 If C<cv> is a constant sub eligible for inlining, returns the constant
7916 value returned by the sub.  Otherwise, returns NULL.
7917
7918 Constant subs can be created with C<newCONSTSUB> or as described in
7919 L<perlsub/"Constant Functions">.
7920
7921 =cut
7922 */
7923 SV *
7924 Perl_cv_const_sv(const CV *const cv)
7925 {
7926     SV *sv;
7927     if (!cv)
7928         return NULL;
7929     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
7930         return NULL;
7931     sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7932     if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
7933     return sv;
7934 }
7935
7936 SV *
7937 Perl_cv_const_sv_or_av(const CV * const cv)
7938 {
7939     if (!cv)
7940         return NULL;
7941     if (SvROK(cv)) return SvRV((SV *)cv);
7942     assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
7943     return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7944 }
7945
7946 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
7947  * Can be called in 2 ways:
7948  *
7949  * !allow_lex
7950  *      look for a single OP_CONST with attached value: return the value
7951  *
7952  * allow_lex && !CvCONST(cv);
7953  *
7954  *      examine the clone prototype, and if contains only a single
7955  *      OP_CONST, return the value; or if it contains a single PADSV ref-
7956  *      erencing an outer lexical, turn on CvCONST to indicate the CV is
7957  *      a candidate for "constizing" at clone time, and return NULL.
7958  */
7959
7960 static SV *
7961 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
7962 {
7963     SV *sv = NULL;
7964     bool padsv = FALSE;
7965
7966     assert(o);
7967     assert(cv);
7968
7969     for (; o; o = o->op_next) {
7970         const OPCODE type = o->op_type;
7971
7972         if (type == OP_NEXTSTATE || type == OP_LINESEQ
7973              || type == OP_NULL
7974              || type == OP_PUSHMARK)
7975                 continue;
7976         if (type == OP_DBSTATE)
7977                 continue;
7978         if (type == OP_LEAVESUB)
7979             break;
7980         if (sv)
7981             return NULL;
7982         if (type == OP_CONST && cSVOPo->op_sv)
7983             sv = cSVOPo->op_sv;
7984         else if (type == OP_UNDEF && !o->op_private) {
7985             sv = newSV(0);
7986             SAVEFREESV(sv);
7987         }
7988         else if (allow_lex && type == OP_PADSV) {
7989                 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
7990                 {
7991                     sv = &PL_sv_undef; /* an arbitrary non-null value */
7992                     padsv = TRUE;
7993                 }
7994                 else
7995                     return NULL;
7996         }
7997         else {
7998             return NULL;
7999         }
8000     }
8001     if (padsv) {
8002         CvCONST_on(cv);
8003         return NULL;
8004     }
8005     return sv;
8006 }
8007
8008 static bool
8009 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
8010                         PADNAME * const name, SV ** const const_svp)
8011 {
8012     assert (cv);
8013     assert (o || name);
8014     assert (const_svp);
8015     if ((!block
8016          )) {
8017         if (CvFLAGS(PL_compcv)) {
8018             /* might have had built-in attrs applied */
8019             const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
8020             if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
8021              && ckWARN(WARN_MISC))
8022             {
8023                 /* protect against fatal warnings leaking compcv */
8024                 SAVEFREESV(PL_compcv);
8025                 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
8026                 SvREFCNT_inc_simple_void_NN(PL_compcv);
8027             }
8028             CvFLAGS(cv) |=
8029                 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
8030                   & ~(CVf_LVALUE * pureperl));
8031         }
8032         return FALSE;
8033     }
8034
8035     /* redundant check for speed: */
8036     if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
8037         const line_t oldline = CopLINE(PL_curcop);
8038         SV *namesv = o
8039             ? cSVOPo->op_sv
8040             : sv_2mortal(newSVpvn_utf8(
8041                 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
8042               ));
8043         if (PL_parser && PL_parser->copline != NOLINE)
8044             /* This ensures that warnings are reported at the first
8045                line of a redefinition, not the last.  */
8046             CopLINE_set(PL_curcop, PL_parser->copline);
8047         /* protect against fatal warnings leaking compcv */
8048         SAVEFREESV(PL_compcv);
8049         report_redefined_cv(namesv, cv, const_svp);
8050         SvREFCNT_inc_simple_void_NN(PL_compcv);
8051         CopLINE_set(PL_curcop, oldline);
8052     }
8053     SAVEFREESV(cv);
8054     return TRUE;
8055 }
8056
8057 CV *
8058 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
8059 {
8060     CV **spot;
8061     SV **svspot;
8062     const char *ps;
8063     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
8064     U32 ps_utf8 = 0;
8065     CV *cv = NULL;
8066     CV *compcv = PL_compcv;
8067     SV *const_sv;
8068     PADNAME *name;
8069     PADOFFSET pax = o->op_targ;
8070     CV *outcv = CvOUTSIDE(PL_compcv);
8071     CV *clonee = NULL;
8072     HEK *hek = NULL;
8073     bool reusable = FALSE;
8074     OP *start = NULL;
8075 #ifdef PERL_DEBUG_READONLY_OPS
8076     OPSLAB *slab = NULL;
8077 #endif
8078
8079     PERL_ARGS_ASSERT_NEWMYSUB;
8080
8081     /* Find the pad slot for storing the new sub.
8082        We cannot use PL_comppad, as it is the pad owned by the new sub.  We
8083        need to look in CvOUTSIDE and find the pad belonging to the enclos-
8084        ing sub.  And then we need to dig deeper if this is a lexical from
8085        outside, as in:
8086            my sub foo; sub { sub foo { } }
8087      */
8088    redo:
8089     name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
8090     if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
8091         pax = PARENT_PAD_INDEX(name);
8092         outcv = CvOUTSIDE(outcv);
8093         assert(outcv);
8094         goto redo;
8095     }
8096     svspot =
8097         &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
8098                         [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
8099     spot = (CV **)svspot;
8100
8101     if (!(PL_parser && PL_parser->error_count))
8102         move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name));
8103
8104     if (proto) {
8105         assert(proto->op_type == OP_CONST);
8106         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
8107         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
8108     }
8109     else
8110         ps = NULL;
8111
8112     if (proto)
8113         SAVEFREEOP(proto);
8114     if (attrs)
8115         SAVEFREEOP(attrs);
8116
8117     if (PL_parser && PL_parser->error_count) {
8118         op_free(block);
8119         SvREFCNT_dec(PL_compcv);
8120         PL_compcv = 0;
8121         goto done;
8122     }
8123
8124     if (CvDEPTH(outcv) && CvCLONE(compcv)) {
8125         cv = *spot;
8126         svspot = (SV **)(spot = &clonee);
8127     }
8128     else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
8129         cv = *spot;
8130     else {
8131         assert (SvTYPE(*spot) == SVt_PVCV);
8132         if (CvNAMED(*spot))
8133             hek = CvNAME_HEK(*spot);
8134         else {
8135             dVAR;
8136             U32 hash;
8137             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
8138             CvNAME_HEK_set(*spot, hek =
8139                 share_hek(
8140                     PadnamePV(name)+1,
8141                     (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
8142                     hash
8143                 )
8144             );
8145             CvLEXICAL_on(*spot);
8146         }
8147         cv = PadnamePROTOCV(name);
8148         svspot = (SV **)(spot = &PadnamePROTOCV(name));
8149     }
8150
8151     if (block) {
8152         /* This makes sub {}; work as expected.  */
8153         if (block->op_type == OP_STUB) {
8154             const line_t l = PL_parser->copline;
8155             op_free(block);
8156             block = newSTATEOP(0, NULL, 0);
8157             PL_parser->copline = l;
8158         }
8159         block = CvLVALUE(compcv)
8160              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
8161                    ? newUNOP(OP_LEAVESUBLV, 0,
8162                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
8163                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
8164         start = LINKLIST(block);
8165         block->op_next = 0;
8166     }
8167
8168     if (!block || !ps || *ps || attrs
8169         || CvLVALUE(compcv)
8170         )
8171         const_sv = NULL;
8172     else
8173         const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
8174
8175     if (cv) {
8176         const bool exists = CvROOT(cv) || CvXSUB(cv);
8177
8178         /* if the subroutine doesn't exist and wasn't pre-declared
8179          * with a prototype, assume it will be AUTOLOADed,
8180          * skipping the prototype check
8181          */
8182         if (exists || SvPOK(cv))
8183             cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
8184                                  ps_utf8);
8185         /* already defined? */
8186         if (exists) {
8187             if (S_already_defined(aTHX_ cv,block,NULL,name,&const_sv))
8188                 cv = NULL;
8189             else {
8190                 if (attrs) goto attrs;
8191                 /* just a "sub foo;" when &foo is already defined */
8192                 SAVEFREESV(compcv);
8193                 goto done;
8194             }
8195         }
8196         else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
8197             cv = NULL;
8198             reusable = TRUE;
8199         }
8200     }
8201     if (const_sv) {
8202         SvREFCNT_inc_simple_void_NN(const_sv);
8203         SvFLAGS(const_sv) |= SVs_PADTMP;
8204         if (cv) {
8205             assert(!CvROOT(cv) && !CvCONST(cv));
8206             cv_forget_slab(cv);
8207         }
8208         else {
8209             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8210             CvFILE_set_from_cop(cv, PL_curcop);
8211             CvSTASH_set(cv, PL_curstash);
8212             *spot = cv;
8213         }
8214         sv_setpvs(MUTABLE_SV(cv), "");  /* prototype is "" */
8215         CvXSUBANY(cv).any_ptr = const_sv;
8216         CvXSUB(cv) = const_sv_xsub;
8217         CvCONST_on(cv);
8218         CvISXSUB_on(cv);
8219         PoisonPADLIST(cv);
8220         CvFLAGS(cv) |= CvMETHOD(compcv);
8221         op_free(block);
8222         SvREFCNT_dec(compcv);
8223         PL_compcv = NULL;
8224         goto setname;
8225     }
8226     /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
8227        determine whether this sub definition is in the same scope as its
8228        declaration.  If this sub definition is inside an inner named pack-
8229        age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
8230        the package sub.  So check PadnameOUTER(name) too.
8231      */
8232     if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
8233         assert(!CvWEAKOUTSIDE(compcv));
8234         SvREFCNT_dec(CvOUTSIDE(compcv));
8235         CvWEAKOUTSIDE_on(compcv);
8236     }
8237     /* XXX else do we have a circular reference? */
8238     if (cv) {   /* must reuse cv in case stub is referenced elsewhere */
8239         /* transfer PL_compcv to cv */
8240         if (block
8241         ) {
8242             cv_flags_t preserved_flags =
8243                 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
8244             PADLIST *const temp_padl = CvPADLIST(cv);
8245             CV *const temp_cv = CvOUTSIDE(cv);
8246             const cv_flags_t other_flags =
8247                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8248             OP * const cvstart = CvSTART(cv);
8249
8250             SvPOK_off(cv);
8251             CvFLAGS(cv) =
8252                 CvFLAGS(compcv) | preserved_flags;
8253             CvOUTSIDE(cv) = CvOUTSIDE(compcv);
8254             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
8255             CvPADLIST_set(cv, CvPADLIST(compcv));
8256             CvOUTSIDE(compcv) = temp_cv;
8257             CvPADLIST_set(compcv, temp_padl);
8258             CvSTART(cv) = CvSTART(compcv);
8259             CvSTART(compcv) = cvstart;
8260             CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8261             CvFLAGS(compcv) |= other_flags;
8262
8263             if (CvFILE(cv) && CvDYNFILE(cv)) {
8264                 Safefree(CvFILE(cv));
8265             }
8266
8267             /* inner references to compcv must be fixed up ... */
8268             pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
8269             if (PERLDB_INTER)/* Advice debugger on the new sub. */
8270               ++PL_sub_generation;
8271         }
8272         else {
8273             /* Might have had built-in attributes applied -- propagate them. */
8274             CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
8275         }
8276         /* ... before we throw it away */
8277         SvREFCNT_dec(compcv);
8278         PL_compcv = compcv = cv;
8279     }
8280     else {
8281         cv = compcv;
8282         *spot = cv;
8283     }
8284    setname:
8285     CvLEXICAL_on(cv);
8286     if (!CvNAME_HEK(cv)) {
8287         if (hek) (void)share_hek_hek(hek);
8288         else {
8289             dVAR;
8290             U32 hash;
8291             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
8292             hek = share_hek(PadnamePV(name)+1,
8293                       (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
8294                       hash);
8295         }
8296         CvNAME_HEK_set(cv, hek);
8297     }
8298     if (const_sv) goto clone;
8299
8300     CvFILE_set_from_cop(cv, PL_curcop);
8301     CvSTASH_set(cv, PL_curstash);
8302
8303     if (ps) {
8304         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8305         if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
8306     }
8307
8308     if (!block)
8309         goto attrs;
8310
8311     /* If we assign an optree to a PVCV, then we've defined a subroutine that
8312        the debugger could be able to set a breakpoint in, so signal to
8313        pp_entereval that it should not throw away any saved lines at scope
8314        exit.  */
8315
8316     PL_breakable_sub_gen++;
8317     CvROOT(cv) = block;
8318     CvROOT(cv)->op_private |= OPpREFCOUNTED;
8319     OpREFCNT_set(CvROOT(cv), 1);
8320     /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8321        itself has a refcount. */
8322     CvSLABBED_off(cv);
8323     OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8324 #ifdef PERL_DEBUG_READONLY_OPS
8325     slab = (OPSLAB *)CvSTART(cv);
8326 #endif
8327     CvSTART(cv) = start;
8328     CALL_PEEP(start);
8329     finalize_optree(CvROOT(cv));
8330     S_prune_chain_head(&CvSTART(cv));
8331
8332     /* now that optimizer has done its work, adjust pad values */
8333
8334     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8335
8336   attrs:
8337     if (attrs) {
8338         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8339         apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
8340     }
8341
8342     if (block) {
8343         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8344             SV * const tmpstr = sv_newmortal();
8345             GV * const db_postponed = gv_fetchpvs("DB::postponed",
8346                                                   GV_ADDMULTI, SVt_PVHV);
8347             HV *hv;
8348             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8349                                           CopFILE(PL_curcop),
8350                                           (long)PL_subline,
8351                                           (long)CopLINE(PL_curcop));
8352             if (HvNAME_HEK(PL_curstash)) {
8353                 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
8354                 sv_catpvs(tmpstr, "::");
8355             }
8356             else sv_setpvs(tmpstr, "__ANON__::");
8357             sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
8358                             PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
8359             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8360                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8361             hv = GvHVn(db_postponed);
8362             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8363                 CV * const pcv = GvCV(db_postponed);
8364                 if (pcv) {
8365                     dSP;
8366                     PUSHMARK(SP);
8367                     XPUSHs(tmpstr);
8368                     PUTBACK;
8369                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
8370                 }
8371             }
8372         }
8373     }
8374
8375   clone:
8376     if (clonee) {
8377         assert(CvDEPTH(outcv));
8378         spot = (CV **)
8379             &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
8380         if (reusable) cv_clone_into(clonee, *spot);
8381         else *spot = cv_clone(clonee);
8382         SvREFCNT_dec_NN(clonee);
8383         cv = *spot;
8384     }
8385     if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
8386         PADOFFSET depth = CvDEPTH(outcv);
8387         while (--depth) {
8388             SV *oldcv;
8389             svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
8390             oldcv = *svspot;
8391             *svspot = SvREFCNT_inc_simple_NN(cv);
8392             SvREFCNT_dec(oldcv);
8393         }
8394     }
8395
8396   done:
8397     if (PL_parser)
8398         PL_parser->copline = NOLINE;
8399     LEAVE_SCOPE(floor);
8400 #ifdef PERL_DEBUG_READONLY_OPS
8401     if (slab)
8402         Slab_to_ro(slab);
8403 #endif
8404     if (o) op_free(o);
8405     return cv;
8406 }
8407
8408 /* _x = extended */
8409 CV *
8410 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
8411                             OP *block, bool o_is_gv)
8412 {
8413     GV *gv;
8414     const char *ps;
8415     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
8416     U32 ps_utf8 = 0;
8417     CV *cv = NULL;
8418     SV *const_sv;
8419     const bool ec = PL_parser && PL_parser->error_count;
8420     /* If the subroutine has no body, no attributes, and no builtin attributes
8421        then it's just a sub declaration, and we may be able to get away with
8422        storing with a placeholder scalar in the symbol table, rather than a
8423        full CV.  If anything is present then it will take a full CV to
8424        store it.  */
8425     const I32 gv_fetch_flags
8426         = ec ? GV_NOADD_NOINIT :
8427         (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
8428         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
8429     STRLEN namlen = 0;
8430     const char * const name =
8431          o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
8432     bool has_name;
8433     bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
8434     bool evanescent = FALSE;
8435     OP *start = NULL;
8436 #ifdef PERL_DEBUG_READONLY_OPS
8437     OPSLAB *slab = NULL;
8438 #endif
8439
8440     if (o_is_gv) {
8441         gv = (GV*)o;
8442         o = NULL;
8443         has_name = TRUE;
8444     } else if (name) {
8445         /* Try to optimise and avoid creating a GV.  Instead, the CV’s name
8446            hek and CvSTASH pointer together can imply the GV.  If the name
8447            contains a package name, then GvSTASH(CvGV(cv)) may differ from
8448            CvSTASH, so forego the optimisation if we find any.
8449            Also, we may be called from load_module at run time, so
8450            PL_curstash (which sets CvSTASH) may not point to the stash the
8451            sub is stored in.  */
8452         const I32 flags =
8453            ec ? GV_NOADD_NOINIT
8454               :   PL_curstash != CopSTASH(PL_curcop)
8455                || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
8456                     ? gv_fetch_flags
8457                     : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
8458         gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
8459         has_name = TRUE;
8460     } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
8461         SV * const sv = sv_newmortal();
8462         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
8463                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
8464                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
8465         gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
8466         has_name = TRUE;
8467     } else if (PL_curstash) {
8468         gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
8469         has_name = FALSE;
8470     } else {
8471         gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
8472         has_name = FALSE;
8473     }
8474     if (!ec)
8475         move_proto_attr(&proto, &attrs,
8476                         isGV(gv) ? gv : (GV *)cSVOPo->op_sv);
8477
8478     if (proto) {
8479         assert(proto->op_type == OP_CONST);
8480         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
8481         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
8482     }
8483     else
8484         ps = NULL;
8485
8486     if (o)
8487         SAVEFREEOP(o);
8488     if (proto)
8489         SAVEFREEOP(proto);
8490     if (attrs)
8491         SAVEFREEOP(attrs);
8492
8493     if (ec) {
8494         op_free(block);
8495         if (name) SvREFCNT_dec(PL_compcv);
8496         else cv = PL_compcv;
8497         PL_compcv = 0;
8498         if (name && block) {
8499             const char *s = strrchr(name, ':');
8500             s = s ? s+1 : name;
8501             if (strEQ(s, "BEGIN")) {
8502                 if (PL_in_eval & EVAL_KEEPERR)
8503                     Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
8504                 else {
8505                     SV * const errsv = ERRSV;
8506                     /* force display of errors found but not reported */
8507                     sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
8508                     Perl_croak_nocontext("%"SVf, SVfARG(errsv));
8509                 }
8510             }
8511         }
8512         goto done;
8513     }
8514
8515     if (!block && SvTYPE(gv) != SVt_PVGV) {
8516       /* If we are not defining a new sub and the existing one is not a
8517          full GV + CV... */
8518       if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
8519         /* We are applying attributes to an existing sub, so we need it
8520            upgraded if it is a constant.  */
8521         if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
8522             gv_init_pvn(gv, PL_curstash, name, namlen,
8523                         SVf_UTF8 * name_is_utf8);
8524       }
8525       else {                    /* Maybe prototype now, and had at maximum
8526                                    a prototype or const/sub ref before.  */
8527         if (SvTYPE(gv) > SVt_NULL) {
8528             cv_ckproto_len_flags((const CV *)gv,
8529                                  o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8530                                  ps_len, ps_utf8);
8531         }
8532         if (!SvROK(gv)) {
8533           if (ps) {
8534             sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
8535             if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
8536           }
8537           else
8538             sv_setiv(MUTABLE_SV(gv), -1);
8539         }
8540
8541         SvREFCNT_dec(PL_compcv);
8542         cv = PL_compcv = NULL;
8543         goto done;
8544       }
8545     }
8546
8547     cv = (!name || (isGV(gv) && GvCVGEN(gv)))
8548         ? NULL
8549         : isGV(gv)
8550             ? GvCV(gv)
8551             : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
8552                 ? (CV *)SvRV(gv)
8553                 : NULL;
8554
8555     if (block) {
8556         /* This makes sub {}; work as expected.  */
8557         if (block->op_type == OP_STUB) {
8558             const line_t l = PL_parser->copline;
8559             op_free(block);
8560             block = newSTATEOP(0, NULL, 0);
8561             PL_parser->copline = l;
8562         }
8563         block = CvLVALUE(PL_compcv)
8564              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
8565                     && (!isGV(gv) || !GvASSUMECV(gv)))
8566                    ? newUNOP(OP_LEAVESUBLV, 0,
8567                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
8568                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
8569         start = LINKLIST(block);
8570         block->op_next = 0;
8571     }
8572
8573     if (!block || !ps || *ps || attrs
8574         || CvLVALUE(PL_compcv)
8575         )
8576         const_sv = NULL;
8577     else
8578         const_sv =
8579             S_op_const_sv(aTHX_ start, PL_compcv, cBOOL(CvCLONE(PL_compcv)));
8580
8581     if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
8582         assert (block);
8583         cv_ckproto_len_flags((const CV *)gv,
8584                              o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8585                              ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
8586         if (SvROK(gv)) {
8587             /* All the other code for sub redefinition warnings expects the
8588                clobbered sub to be a CV.  Instead of making all those code
8589                paths more complex, just inline the RV version here.  */
8590             const line_t oldline = CopLINE(PL_curcop);
8591             assert(IN_PERL_COMPILETIME);
8592             if (PL_parser && PL_parser->copline != NOLINE)
8593                 /* This ensures that warnings are reported at the first
8594                    line of a redefinition, not the last.  */
8595                 CopLINE_set(PL_curcop, PL_parser->copline);
8596             /* protect against fatal warnings leaking compcv */
8597             SAVEFREESV(PL_compcv);
8598
8599             if (ckWARN(WARN_REDEFINE)
8600              || (  ckWARN_d(WARN_REDEFINE)
8601                 && (  !const_sv || SvRV(gv) == const_sv
8602                    || sv_cmp(SvRV(gv), const_sv)  )))
8603                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8604                           "Constant subroutine %"SVf" redefined",
8605                           SVfARG(cSVOPo->op_sv));
8606
8607             SvREFCNT_inc_simple_void_NN(PL_compcv);
8608             CopLINE_set(PL_curcop, oldline);
8609             SvREFCNT_dec(SvRV(gv));
8610         }
8611     }
8612
8613     if (cv) {
8614         const bool exists = CvROOT(cv) || CvXSUB(cv);
8615
8616         /* if the subroutine doesn't exist and wasn't pre-declared
8617          * with a prototype, assume it will be AUTOLOADed,
8618          * skipping the prototype check
8619          */
8620         if (exists || SvPOK(cv))
8621             cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
8622         /* already defined (or promised)? */
8623         if (exists || (isGV(gv) && GvASSUMECV(gv))) {
8624             if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv))
8625                 cv = NULL;
8626             else {
8627                 if (attrs) goto attrs;
8628                 /* just a "sub foo;" when &foo is already defined */
8629                 SAVEFREESV(PL_compcv);
8630                 goto done;
8631             }
8632         }
8633     }
8634     if (const_sv) {
8635         SvREFCNT_inc_simple_void_NN(const_sv);
8636         SvFLAGS(const_sv) |= SVs_PADTMP;
8637         if (cv) {
8638             assert(!CvROOT(cv) && !CvCONST(cv));
8639             cv_forget_slab(cv);
8640             sv_setpvs(MUTABLE_SV(cv), "");  /* prototype is "" */
8641             CvXSUBANY(cv).any_ptr = const_sv;
8642             CvXSUB(cv) = const_sv_xsub;
8643             CvCONST_on(cv);
8644             CvISXSUB_on(cv);
8645             PoisonPADLIST(cv);
8646             CvFLAGS(cv) |= CvMETHOD(PL_compcv);
8647         }
8648         else {
8649             if (isGV(gv) || CvMETHOD(PL_compcv)) {
8650                 if (name && isGV(gv))
8651                     GvCV_set(gv, NULL);
8652                 cv = newCONSTSUB_flags(
8653                     NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
8654                     const_sv
8655                 );
8656                 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
8657             }
8658             else {
8659                 if (!SvROK(gv)) {
8660                     SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8661                     prepare_SV_for_RV((SV *)gv);
8662                     SvOK_off((SV *)gv);
8663                     SvROK_on(gv);
8664                 }
8665                 SvRV_set(gv, const_sv);
8666             }
8667         }
8668         op_free(block);
8669         SvREFCNT_dec(PL_compcv);
8670         PL_compcv = NULL;
8671         goto done;
8672     }
8673     if (cv) {                           /* must reuse cv if autoloaded */
8674         /* transfer PL_compcv to cv */
8675         if (block
8676         ) {
8677             cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
8678             PADLIST *const temp_av = CvPADLIST(cv);
8679             CV *const temp_cv = CvOUTSIDE(cv);
8680             const cv_flags_t other_flags =
8681                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8682             OP * const cvstart = CvSTART(cv);
8683
8684             if (isGV(gv)) {
8685                 CvGV_set(cv,gv);
8686                 assert(!CvCVGV_RC(cv));
8687                 assert(CvGV(cv) == gv);
8688             }
8689             else {
8690                 dVAR;
8691                 U32 hash;
8692                 PERL_HASH(hash, name, namlen);
8693                 CvNAME_HEK_set(cv,
8694                                share_hek(name,
8695                                          name_is_utf8
8696                                             ? -(SSize_t)namlen
8697                                             :  (SSize_t)namlen,
8698                                          hash));
8699             }
8700
8701             SvPOK_off(cv);
8702             CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
8703                                              | CvNAMED(cv);
8704             CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
8705             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
8706             CvPADLIST_set(cv,CvPADLIST(PL_compcv));
8707             CvOUTSIDE(PL_compcv) = temp_cv;
8708             CvPADLIST_set(PL_compcv, temp_av);
8709             CvSTART(cv) = CvSTART(PL_compcv);
8710             CvSTART(PL_compcv) = cvstart;
8711             CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8712             CvFLAGS(PL_compcv) |= other_flags;
8713
8714             if (CvFILE(cv) && CvDYNFILE(cv)) {
8715                 Safefree(CvFILE(cv));
8716     }
8717             CvFILE_set_from_cop(cv, PL_curcop);
8718             CvSTASH_set(cv, PL_curstash);
8719
8720             /* inner references to PL_compcv must be fixed up ... */
8721             pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
8722             if (PERLDB_INTER)/* Advice debugger on the new sub. */
8723               ++PL_sub_generation;
8724         }
8725         else {
8726             /* Might have had built-in attributes applied -- propagate them. */
8727             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
8728         }
8729         /* ... before we throw it away */
8730         SvREFCNT_dec(PL_compcv);
8731         PL_compcv = cv;
8732     }
8733     else {
8734         cv = PL_compcv;
8735         if (name && isGV(gv)) {
8736             GvCV_set(gv, cv);
8737             GvCVGEN(gv) = 0;
8738             if (HvENAME_HEK(GvSTASH(gv)))
8739                 /* sub Foo::bar { (shift)+1 } */
8740                 gv_method_changed(gv);
8741         }
8742         else if (name) {
8743             if (!SvROK(gv)) {
8744                 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8745                 prepare_SV_for_RV((SV *)gv);
8746                 SvOK_off((SV *)gv);
8747                 SvROK_on(gv);
8748             }
8749             SvRV_set(gv, (SV *)cv);
8750         }
8751     }
8752     if (!CvHASGV(cv)) {
8753         if (isGV(gv)) CvGV_set(cv, gv);
8754         else {
8755             dVAR;
8756             U32 hash;
8757             PERL_HASH(hash, name, namlen);
8758             CvNAME_HEK_set(cv, share_hek(name,
8759                                          name_is_utf8
8760                                             ? -(SSize_t)namlen
8761                                             :  (SSize_t)namlen,
8762                                          hash));
8763         }
8764         CvFILE_set_from_cop(cv, PL_curcop);
8765         CvSTASH_set(cv, PL_curstash);
8766     }
8767
8768     if (ps) {
8769         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8770         if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
8771     }
8772
8773     if (!block)
8774         goto attrs;
8775
8776     /* If we assign an optree to a PVCV, then we've defined a subroutine that
8777        the debugger could be able to set a breakpoint in, so signal to
8778        pp_entereval that it should not throw away any saved lines at scope
8779        exit.  */
8780
8781     PL_breakable_sub_gen++;
8782     CvROOT(cv) = block;
8783     CvROOT(cv)->op_private |= OPpREFCOUNTED;
8784     OpREFCNT_set(CvROOT(cv), 1);
8785     /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8786        itself has a refcount. */
8787     CvSLABBED_off(cv);
8788     OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8789 #ifdef PERL_DEBUG_READONLY_OPS
8790     slab = (OPSLAB *)CvSTART(cv);
8791 #endif
8792     CvSTART(cv) = start;
8793     CALL_PEEP(start);
8794     finalize_optree(CvROOT(cv));
8795     S_prune_chain_head(&CvSTART(cv));
8796
8797     /* now that optimizer has done its work, adjust pad values */
8798
8799     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8800
8801   attrs:
8802     if (attrs) {
8803         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8804         HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
8805                         ? GvSTASH(CvGV(cv))
8806                         : PL_curstash;
8807         if (!name) SAVEFREESV(cv);
8808         apply_attrs(stash, MUTABLE_SV(cv), attrs);
8809         if (!name) SvREFCNT_inc_simple_void_NN(cv);
8810     }
8811
8812     if (block && has_name) {
8813         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8814             SV * const tmpstr = cv_name(cv,NULL,0);
8815             GV * const db_postponed = gv_fetchpvs("DB::postponed",
8816                                                   GV_ADDMULTI, SVt_PVHV);
8817             HV *hv;
8818             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8819                                           CopFILE(PL_curcop),
8820                                           (long)PL_subline,
8821                                           (long)CopLINE(PL_curcop));
8822             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8823                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8824             hv = GvHVn(db_postponed);
8825             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8826                 CV * const pcv = GvCV(db_postponed);
8827                 if (pcv) {
8828                     dSP;
8829                     PUSHMARK(SP);
8830                     XPUSHs(tmpstr);
8831                     PUTBACK;
8832                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
8833                 }
8834             }
8835         }
8836
8837         if (name) {
8838             if (PL_parser && PL_parser->error_count)
8839                 clear_special_blocks(name, gv, cv);
8840             else
8841                 evanescent =
8842                     process_special_blocks(floor, name, gv, cv);
8843         }
8844     }
8845
8846   done:
8847     if (PL_parser)
8848         PL_parser->copline = NOLINE;
8849     LEAVE_SCOPE(floor);
8850     if (!evanescent) {
8851 #ifdef PERL_DEBUG_READONLY_OPS
8852       if (slab)
8853         Slab_to_ro(slab);
8854 #endif
8855       if (cv && name && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
8856         pad_add_weakref(cv);
8857     }
8858     return cv;
8859 }
8860
8861 STATIC void
8862 S_clear_special_blocks(pTHX_ const char *const fullname,
8863                        GV *const gv, CV *const cv) {
8864     const char *colon;
8865     const char *name;
8866
8867     PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
8868
8869     colon = strrchr(fullname,':');
8870     name = colon ? colon + 1 : fullname;
8871
8872     if ((*name == 'B' && strEQ(name, "BEGIN"))
8873         || (*name == 'E' && strEQ(name, "END"))
8874         || (*name == 'U' && strEQ(name, "UNITCHECK"))
8875         || (*name == 'C' && strEQ(name, "CHECK"))
8876         || (*name == 'I' && strEQ(name, "INIT"))) {
8877         if (!isGV(gv)) {
8878             (void)CvGV(cv);
8879             assert(isGV(gv));
8880         }
8881         GvCV_set(gv, NULL);
8882         SvREFCNT_dec_NN(MUTABLE_SV(cv));
8883     }
8884 }
8885
8886 /* Returns true if the sub has been freed.  */
8887 STATIC bool
8888 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
8889                          GV *const gv,
8890                          CV *const cv)
8891 {
8892     const char *const colon = strrchr(fullname,':');
8893     const char *const name = colon ? colon + 1 : fullname;
8894
8895     PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
8896
8897     if (*name == 'B') {
8898         if (strEQ(name, "BEGIN")) {
8899             const I32 oldscope = PL_scopestack_ix;
8900             dSP;
8901             (void)CvGV(cv);
8902             if (floor) LEAVE_SCOPE(floor);
8903             ENTER;
8904             PUSHSTACKi(PERLSI_REQUIRE);
8905             SAVECOPFILE(&PL_compiling);
8906             SAVECOPLINE(&PL_compiling);
8907             SAVEVPTR(PL_curcop);
8908
8909             DEBUG_x( dump_sub(gv) );
8910             Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
8911             GvCV_set(gv,0);             /* cv has been hijacked */
8912             call_list(oldscope, PL_beginav);
8913
8914             POPSTACK;
8915             LEAVE;
8916             return !PL_savebegin;
8917         }
8918         else
8919             return FALSE;
8920     } else {
8921         if (*name == 'E') {
8922             if strEQ(name, "END") {
8923                 DEBUG_x( dump_sub(gv) );
8924                 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
8925             } else
8926                 return FALSE;
8927         } else if (*name == 'U') {
8928             if (strEQ(name, "UNITCHECK")) {
8929                 /* It's never too late to run a unitcheck block */
8930                 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
8931             }
8932             else
8933                 return FALSE;
8934         } else if (*name == 'C') {
8935             if (strEQ(name, "CHECK")) {
8936                 if (PL_main_start)
8937                     /* diag_listed_as: Too late to run %s block */
8938                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8939                                    "Too late to run CHECK block");
8940                 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
8941             }
8942             else
8943                 return FALSE;
8944         } else if (*name == 'I') {
8945             if (strEQ(name, "INIT")) {
8946                 if (PL_main_start)
8947                     /* diag_listed_as: Too late to run %s block */
8948                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8949                                    "Too late to run INIT block");
8950                 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
8951             }
8952             else
8953                 return FALSE;
8954         } else
8955             return FALSE;
8956         DEBUG_x( dump_sub(gv) );
8957         (void)CvGV(cv);
8958         GvCV_set(gv,0);         /* cv has been hijacked */
8959         return FALSE;
8960     }
8961 }
8962
8963 /*
8964 =for apidoc newCONSTSUB
8965
8966 See L</newCONSTSUB_flags>.
8967
8968 =cut
8969 */
8970
8971 CV *
8972 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
8973 {
8974     return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
8975 }
8976
8977 /*
8978 =for apidoc newCONSTSUB_flags
8979
8980 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
8981 eligible for inlining at compile-time.
8982
8983 Currently, the only useful value for C<flags> is SVf_UTF8.
8984
8985 The newly created subroutine takes ownership of a reference to the passed in
8986 SV.
8987
8988 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
8989 which won't be called if used as a destructor, but will suppress the overhead
8990 of a call to C<AUTOLOAD>.  (This form, however, isn't eligible for inlining at
8991 compile time.)
8992
8993 =cut
8994 */
8995
8996 CV *
8997 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
8998                              U32 flags, SV *sv)
8999 {
9000     CV* cv;
9001     const char *const file = CopFILE(PL_curcop);
9002
9003     ENTER;
9004
9005     if (IN_PERL_RUNTIME) {
9006         /* at runtime, it's not safe to manipulate PL_curcop: it may be
9007          * an op shared between threads. Use a non-shared COP for our
9008          * dirty work */
9009          SAVEVPTR(PL_curcop);
9010          SAVECOMPILEWARNINGS();
9011          PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
9012          PL_curcop = &PL_compiling;
9013     }
9014     SAVECOPLINE(PL_curcop);
9015     CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
9016
9017     SAVEHINTS();
9018     PL_hints &= ~HINT_BLOCK_SCOPE;
9019
9020     if (stash) {
9021         SAVEGENERICSV(PL_curstash);
9022         PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
9023     }
9024
9025     /* Protect sv against leakage caused by fatal warnings. */
9026     if (sv) SAVEFREESV(sv);
9027
9028     /* file becomes the CvFILE. For an XS, it's usually static storage,
9029        and so doesn't get free()d.  (It's expected to be from the C pre-
9030        processor __FILE__ directive). But we need a dynamically allocated one,
9031        and we need it to get freed.  */
9032     cv = newXS_len_flags(name, len,
9033                          sv && SvTYPE(sv) == SVt_PVAV
9034                              ? const_av_xsub
9035                              : const_sv_xsub,
9036                          file ? file : "", "",
9037                          &sv, XS_DYNAMIC_FILENAME | flags);
9038     CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
9039     CvCONST_on(cv);
9040
9041     LEAVE;
9042
9043     return cv;
9044 }
9045
9046 /*
9047 =for apidoc U||newXS
9048
9049 Used by C<xsubpp> to hook up XSUBs as Perl subs.  I<filename> needs to be
9050 static storage, as it is used directly as CvFILE(), without a copy being made.
9051
9052 =cut
9053 */
9054
9055 CV *
9056 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
9057 {
9058     PERL_ARGS_ASSERT_NEWXS;
9059     return newXS_len_flags(
9060         name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
9061     );
9062 }
9063
9064 CV *
9065 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
9066                  const char *const filename, const char *const proto,
9067                  U32 flags)
9068 {
9069     PERL_ARGS_ASSERT_NEWXS_FLAGS;
9070     return newXS_len_flags(
9071        name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
9072     );
9073 }
9074
9075 CV *
9076 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
9077 {
9078     PERL_ARGS_ASSERT_NEWXS_DEFFILE;
9079     return newXS_len_flags(
9080         name, name ? strlen(name) : 0, subaddr, NULL, NULL, NULL, 0
9081     );
9082 }
9083
9084 CV *
9085 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
9086                            XSUBADDR_t subaddr, const char *const filename,
9087                            const char *const proto, SV **const_svp,
9088                            U32 flags)
9089 {
9090     CV *cv;
9091     bool interleave = FALSE;
9092
9093     PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
9094     if (!subaddr)
9095         Perl_croak_nocontext("panic: no address for '%s' in '%s'",
9096             name, filename ? filename : PL_xsubfilename);
9097     {
9098         GV * const gv = gv_fetchpvn(
9099                             name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
9100                             name ? len : PL_curstash ? sizeof("__ANON__") - 1:
9101                                 sizeof("__ANON__::__ANON__") - 1,
9102                             GV_ADDMULTI | flags, SVt_PVCV);
9103
9104         if ((cv = (name ? GvCV(gv) : NULL))) {
9105             if (GvCVGEN(gv)) {
9106                 /* just a cached method */
9107                 SvREFCNT_dec(cv);
9108                 cv = NULL;
9109             }
9110             else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
9111                 /* already defined (or promised) */
9112                 /* Redundant check that allows us to avoid creating an SV
9113                    most of the time: */
9114                 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
9115                     report_redefined_cv(newSVpvn_flags(
9116                                          name,len,(flags&SVf_UTF8)|SVs_TEMP
9117                                         ),
9118                                         cv, const_svp);
9119                 }
9120                 interleave = TRUE;
9121                 ENTER;
9122                 SAVEFREESV(cv);
9123                 cv = NULL;
9124             }
9125         }
9126
9127         if (cv)                         /* must reuse cv if autoloaded */
9128             cv_undef(cv);
9129         else {
9130             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9131             if (name) {
9132                 GvCV_set(gv,cv);
9133                 GvCVGEN(gv) = 0;
9134                 if (HvENAME_HEK(GvSTASH(gv)))
9135                     gv_method_changed(gv); /* newXS */
9136             }
9137         }
9138
9139         CvGV_set(cv, gv);
9140         if(filename) {
9141             (void)gv_fetchfile(filename);
9142             assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
9143             if (flags & XS_DYNAMIC_FILENAME) {
9144                 CvDYNFILE_on(cv);
9145                 CvFILE(cv) = savepv(filename);
9146             } else {
9147             /* NOTE: not copied, as it is expected to be an external constant string */
9148                 CvFILE(cv) = (char *)filename;
9149             }
9150         } else {
9151             assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
9152             CvFILE(cv) = (char*)PL_xsubfilename;
9153         }
9154         CvISXSUB_on(cv);
9155         CvXSUB(cv) = subaddr;
9156 #ifndef PERL_IMPLICIT_CONTEXT
9157         CvHSCXT(cv) = &PL_stack_sp;
9158 #else
9159         PoisonPADLIST(cv);
9160 #endif
9161
9162         if (name)
9163             process_special_blocks(0, name, gv, cv);
9164         else
9165             CvANON_on(cv);
9166     } /* <- not a conditional branch */
9167
9168
9169     sv_setpv(MUTABLE_SV(cv), proto);
9170     if (interleave) LEAVE;
9171     return cv;
9172 }
9173
9174 CV *
9175 Perl_newSTUB(pTHX_ GV *gv, bool fake)
9176 {
9177     CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9178     GV *cvgv;
9179     PERL_ARGS_ASSERT_NEWSTUB;
9180     assert(!GvCVu(gv));
9181     GvCV_set(gv, cv);
9182     GvCVGEN(gv) = 0;
9183     if (!fake && HvENAME_HEK(GvSTASH(gv)))
9184         gv_method_changed(gv);
9185     if (SvFAKE(gv)) {
9186         cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
9187         SvFAKE_off(cvgv);
9188     }
9189     else cvgv = gv;
9190     CvGV_set(cv, cvgv);
9191     CvFILE_set_from_cop(cv, PL_curcop);
9192     CvSTASH_set(cv, PL_curstash);
9193     GvMULTI_on(gv);
9194     return cv;
9195 }
9196
9197 void
9198 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
9199 {
9200     CV *cv;
9201
9202     GV *gv;
9203
9204     if (PL_parser && PL_parser->error_count) {
9205         op_free(block);
9206         goto finish;
9207     }
9208
9209     gv = o
9210         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
9211         : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
9212
9213     GvMULTI_on(gv);
9214     if ((cv = GvFORM(gv))) {
9215         if (ckWARN(WARN_REDEFINE)) {
9216             const line_t oldline = CopLINE(PL_curcop);
9217             if (PL_parser && PL_parser->copline != NOLINE)
9218                 CopLINE_set(PL_curcop, PL_parser->copline);
9219             if (o) {
9220                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9221                             "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
9222             } else {
9223                 /* diag_listed_as: Format %s redefined */
9224                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9225                             "Format STDOUT redefined");
9226             }
9227             CopLINE_set(PL_curcop, oldline);
9228         }
9229         SvREFCNT_dec(cv);
9230     }
9231     cv = PL_compcv;
9232     GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
9233     CvGV_set(cv, gv);
9234     CvFILE_set_from_cop(cv, PL_curcop);
9235
9236
9237     pad_tidy(padtidy_FORMAT);
9238     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
9239     CvROOT(cv)->op_private |= OPpREFCOUNTED;
9240     OpREFCNT_set(CvROOT(cv), 1);
9241     CvSTART(cv) = LINKLIST(CvROOT(cv));
9242     CvROOT(cv)->op_next = 0;
9243     CALL_PEEP(CvSTART(cv));
9244     finalize_optree(CvROOT(cv));
9245     S_prune_chain_head(&CvSTART(cv));
9246     cv_forget_slab(cv);
9247
9248   finish:
9249     op_free(o);
9250     if (PL_parser)
9251         PL_parser->copline = NOLINE;
9252     LEAVE_SCOPE(floor);
9253     PL_compiling.cop_seq = 0;
9254 }
9255
9256 OP *
9257 Perl_newANONLIST(pTHX_ OP *o)
9258 {
9259     return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
9260 }
9261
9262 OP *
9263 Perl_newANONHASH(pTHX_ OP *o)
9264 {
9265     return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
9266 }
9267
9268 OP *
9269 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
9270 {
9271     return newANONATTRSUB(floor, proto, NULL, block);
9272 }
9273
9274 OP *
9275 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
9276 {
9277     SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
9278     OP * anoncode =
9279         newSVOP(OP_ANONCODE, 0,
9280                 cv);
9281     if (CvANONCONST(cv))
9282         anoncode = newUNOP(OP_ANONCONST, 0,
9283                            op_convert_list(OP_ENTERSUB,
9284                                            OPf_STACKED|OPf_WANT_SCALAR,
9285                                            anoncode));
9286     return newUNOP(OP_REFGEN, 0, anoncode);
9287 }
9288
9289 OP *
9290 Perl_oopsAV(pTHX_ OP *o)
9291 {
9292     dVAR;
9293
9294     PERL_ARGS_ASSERT_OOPSAV;
9295
9296     switch (o->op_type) {
9297     case OP_PADSV:
9298     case OP_PADHV:
9299         CHANGE_TYPE(o, OP_PADAV);
9300         return ref(o, OP_RV2AV);
9301
9302     case OP_RV2SV:
9303     case OP_RV2HV:
9304         CHANGE_TYPE(o, OP_RV2AV);
9305         ref(o, OP_RV2AV);
9306         break;
9307
9308     default:
9309         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
9310         break;
9311     }
9312     return o;
9313 }
9314
9315 OP *
9316 Perl_oopsHV(pTHX_ OP *o)
9317 {
9318     dVAR;
9319
9320     PERL_ARGS_ASSERT_OOPSHV;
9321
9322     switch (o->op_type) {
9323     case OP_PADSV:
9324     case OP_PADAV:
9325         CHANGE_TYPE(o, OP_PADHV);
9326         return ref(o, OP_RV2HV);
9327
9328     case OP_RV2SV:
9329     case OP_RV2AV:
9330         CHANGE_TYPE(o, OP_RV2HV);
9331         ref(o, OP_RV2HV);
9332         break;
9333
9334     default:
9335         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
9336         break;
9337     }
9338     return o;
9339 }
9340
9341 OP *
9342 Perl_newAVREF(pTHX_ OP *o)
9343 {
9344     dVAR;
9345
9346     PERL_ARGS_ASSERT_NEWAVREF;
9347
9348     if (o->op_type == OP_PADANY) {
9349         CHANGE_TYPE(o, OP_PADAV);
9350         return o;
9351     }
9352     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
9353         Perl_croak(aTHX_ "Can't use an array as a reference");
9354     }
9355     return newUNOP(OP_RV2AV, 0, scalar(o));
9356 }
9357
9358 OP *
9359 Perl_newGVREF(pTHX_ I32 type, OP *o)
9360 {
9361     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
9362         return newUNOP(OP_NULL, 0, o);
9363     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
9364 }
9365
9366 OP *
9367 Perl_newHVREF(pTHX_ OP *o)
9368 {
9369     dVAR;
9370
9371     PERL_ARGS_ASSERT_NEWHVREF;
9372
9373     if (o->op_type == OP_PADANY) {
9374         CHANGE_TYPE(o, OP_PADHV);
9375         return o;
9376     }
9377     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
9378         Perl_croak(aTHX_ "Can't use a hash as a reference");
9379     }
9380     return newUNOP(OP_RV2HV, 0, scalar(o));
9381 }
9382
9383 OP *
9384 Perl_newCVREF(pTHX_ I32 flags, OP *o)
9385 {
9386     if (o->op_type == OP_PADANY) {
9387         dVAR;
9388         CHANGE_TYPE(o, OP_PADCV);
9389     }
9390     return newUNOP(OP_RV2CV, flags, scalar(o));
9391 }
9392
9393 OP *
9394 Perl_newSVREF(pTHX_ OP *o)
9395 {
9396     dVAR;
9397
9398     PERL_ARGS_ASSERT_NEWSVREF;
9399
9400     if (o->op_type == OP_PADANY) {
9401         CHANGE_TYPE(o, OP_PADSV);
9402         scalar(o);
9403         return o;
9404     }
9405     return newUNOP(OP_RV2SV, 0, scalar(o));
9406 }
9407
9408 /* Check routines. See the comments at the top of this file for details
9409  * on when these are called */
9410
9411 OP *
9412 Perl_ck_anoncode(pTHX_ OP *o)
9413 {
9414     PERL_ARGS_ASSERT_CK_ANONCODE;
9415
9416     cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
9417     cSVOPo->op_sv = NULL;
9418     return o;
9419 }
9420
9421 static void
9422 S_io_hints(pTHX_ OP *o)
9423 {
9424 #if O_BINARY != 0 || O_TEXT != 0
9425     HV * const table =
9426         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
9427     if (table) {
9428         SV **svp = hv_fetchs(table, "open_IN", FALSE);
9429         if (svp && *svp) {
9430             STRLEN len = 0;
9431             const char *d = SvPV_const(*svp, len);
9432             const I32 mode = mode_from_discipline(d, len);
9433             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9434 #  if O_BINARY != 0
9435             if (mode & O_BINARY)
9436                 o->op_private |= OPpOPEN_IN_RAW;
9437 #  endif
9438 #  if O_TEXT != 0
9439             if (mode & O_TEXT)
9440                 o->op_private |= OPpOPEN_IN_CRLF;
9441 #  endif
9442         }
9443
9444         svp = hv_fetchs(table, "open_OUT", FALSE);
9445         if (svp && *svp) {
9446             STRLEN len = 0;
9447             const char *d = SvPV_const(*svp, len);
9448             const I32 mode = mode_from_discipline(d, len);
9449             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9450 #  if O_BINARY != 0
9451             if (mode & O_BINARY)
9452                 o->op_private |= OPpOPEN_OUT_RAW;
9453 #  endif
9454 #  if O_TEXT != 0
9455             if (mode & O_TEXT)
9456                 o->op_private |= OPpOPEN_OUT_CRLF;
9457 #  endif
9458         }
9459     }
9460 #else
9461     PERL_UNUSED_CONTEXT;
9462     PERL_UNUSED_ARG(o);
9463 #endif
9464 }
9465
9466 OP *
9467 Perl_ck_backtick(pTHX_ OP *o)
9468 {
9469     GV *gv;
9470     OP *newop = NULL;
9471     OP *sibl;
9472     PERL_ARGS_ASSERT_CK_BACKTICK;
9473     /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
9474     if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
9475      && (gv = gv_override("readpipe",8)))
9476     {
9477         /* detach rest of siblings from o and its first child */
9478         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
9479         newop = S_new_entersubop(aTHX_ gv, sibl);
9480     }
9481     else if (!(o->op_flags & OPf_KIDS))
9482         newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
9483     if (newop) {
9484         op_free(o);
9485         return newop;
9486     }
9487     S_io_hints(aTHX_ o);
9488     return o;
9489 }
9490
9491 OP *
9492 Perl_ck_bitop(pTHX_ OP *o)
9493 {
9494     PERL_ARGS_ASSERT_CK_BITOP;
9495
9496     o->op_private = (U8)(PL_hints & HINT_INTEGER);
9497     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
9498             && (o->op_type == OP_BIT_OR
9499              || o->op_type == OP_BIT_AND
9500              || o->op_type == OP_BIT_XOR))
9501     {
9502         const OP * const left = cBINOPo->op_first;
9503         const OP * const right = OpSIBLING(left);
9504         if ((OP_IS_NUMCOMPARE(left->op_type) &&
9505                 (left->op_flags & OPf_PARENS) == 0) ||
9506             (OP_IS_NUMCOMPARE(right->op_type) &&
9507                 (right->op_flags & OPf_PARENS) == 0))
9508             Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
9509                            "Possible precedence problem on bitwise %c operator",
9510                            o->op_type == OP_BIT_OR ? '|'
9511                            : o->op_type == OP_BIT_AND ? '&' : '^'
9512                            );
9513     }
9514     return o;
9515 }
9516
9517 PERL_STATIC_INLINE bool
9518 is_dollar_bracket(pTHX_ const OP * const o)
9519 {
9520     const OP *kid;
9521     PERL_UNUSED_CONTEXT;
9522     return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
9523         && (kid = cUNOPx(o)->op_first)
9524         && kid->op_type == OP_GV
9525         && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
9526 }
9527
9528 OP *
9529 Perl_ck_cmp(pTHX_ OP *o)
9530 {
9531     PERL_ARGS_ASSERT_CK_CMP;
9532     if (ckWARN(WARN_SYNTAX)) {
9533         const OP *kid = cUNOPo->op_first;
9534         if (kid &&
9535             (
9536                 (   is_dollar_bracket(aTHX_ kid)
9537                  && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
9538                 )
9539              || (   kid->op_type == OP_CONST
9540                  && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
9541                 )
9542            )
9543         )
9544             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9545                         "$[ used in %s (did you mean $] ?)", OP_DESC(o));
9546     }
9547     return o;
9548 }
9549
9550 OP *
9551 Perl_ck_concat(pTHX_ OP *o)
9552 {
9553     const OP * const kid = cUNOPo->op_first;
9554
9555     PERL_ARGS_ASSERT_CK_CONCAT;
9556     PERL_UNUSED_CONTEXT;
9557
9558     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
9559             !(kUNOP->op_first->op_flags & OPf_MOD))
9560         o->op_flags |= OPf_STACKED;
9561     return o;
9562 }
9563
9564 OP *
9565 Perl_ck_spair(pTHX_ OP *o)
9566 {
9567     dVAR;
9568
9569     PERL_ARGS_ASSERT_CK_SPAIR;
9570
9571     if (o->op_flags & OPf_KIDS) {
9572         OP* newop;
9573         OP* kid;
9574         OP* kidkid;
9575         const OPCODE type = o->op_type;
9576         o = modkids(ck_fun(o), type);
9577         kid    = cUNOPo->op_first;
9578         kidkid = kUNOP->op_first;
9579         newop = OpSIBLING(kidkid);
9580         if (newop) {
9581             const OPCODE type = newop->op_type;
9582             if (OpHAS_SIBLING(newop))
9583                 return o;
9584             if (o->op_type == OP_REFGEN
9585              && (  type == OP_RV2CV
9586                 || (  !(newop->op_flags & OPf_PARENS)
9587                    && (  type == OP_RV2AV || type == OP_PADAV
9588                       || type == OP_RV2HV || type == OP_PADHV))))
9589                 NOOP; /* OK (allow srefgen for \@a and \%h) */
9590             else if (OP_GIMME(newop,0) != G_SCALAR)
9591                 return o;
9592         }
9593         /* excise first sibling */
9594         op_sibling_splice(kid, NULL, 1, NULL);
9595         op_free(kidkid);
9596     }
9597     /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
9598      * and OP_CHOMP into OP_SCHOMP */
9599     o->op_ppaddr = PL_ppaddr[++o->op_type];
9600     return ck_fun(o);
9601 }
9602
9603 OP *
9604 Perl_ck_delete(pTHX_ OP *o)
9605 {
9606     PERL_ARGS_ASSERT_CK_DELETE;
9607
9608     o = ck_fun(o);
9609     o->op_private = 0;
9610     if (o->op_flags & OPf_KIDS) {
9611         OP * const kid = cUNOPo->op_first;
9612         switch (kid->op_type) {
9613         case OP_ASLICE:
9614             o->op_flags |= OPf_SPECIAL;
9615             /* FALLTHROUGH */
9616         case OP_HSLICE:
9617             o->op_private |= OPpSLICE;
9618             break;
9619         case OP_AELEM:
9620             o->op_flags |= OPf_SPECIAL;
9621             /* FALLTHROUGH */
9622         case OP_HELEM:
9623             break;
9624         case OP_KVASLICE:
9625             Perl_croak(aTHX_ "delete argument is index/value array slice,"
9626                              " use array slice");
9627         case OP_KVHSLICE:
9628             Perl_croak(aTHX_ "delete argument is key/value hash slice, use"
9629                              " hash slice");
9630         default:
9631             Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
9632                              "element or slice");
9633         }
9634         if (kid->op_private & OPpLVAL_INTRO)
9635             o->op_private |= OPpLVAL_INTRO;
9636         op_null(kid);
9637     }
9638     return o;
9639 }
9640
9641 OP *
9642 Perl_ck_eof(pTHX_ OP *o)
9643 {
9644     PERL_ARGS_ASSERT_CK_EOF;
9645
9646     if (o->op_flags & OPf_KIDS) {
9647         OP *kid;
9648         if (cLISTOPo->op_first->op_type == OP_STUB) {
9649             OP * const newop
9650                 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
9651             op_free(o);
9652             o = newop;
9653         }
9654         o = ck_fun(o);
9655         kid = cLISTOPo->op_first;
9656         if (kid->op_type == OP_RV2GV)
9657             kid->op_private |= OPpALLOW_FAKE;
9658     }
9659     return o;
9660 }
9661
9662 OP *
9663 Perl_ck_eval(pTHX_ OP *o)
9664 {
9665     dVAR;
9666
9667     PERL_ARGS_ASSERT_CK_EVAL;
9668
9669     PL_hints |= HINT_BLOCK_SCOPE;
9670     if (o->op_flags & OPf_KIDS) {
9671         SVOP * const kid = (SVOP*)cUNOPo->op_first;
9672         assert(kid);
9673
9674         if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
9675             LOGOP *enter;
9676
9677             /* cut whole sibling chain free from o */
9678             op_sibling_splice(o, NULL, -1, NULL);
9679             op_free(o);
9680
9681             enter = S_alloc_LOGOP(aTHX_ OP_ENTERTRY, NULL, NULL);
9682
9683             /* establish postfix order */
9684             enter->op_next = (OP*)enter;
9685
9686             o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
9687             CHANGE_TYPE(o, OP_LEAVETRY);
9688             enter->op_other = o;
9689             return o;
9690         }
9691         else {
9692             scalar((OP*)kid);
9693             S_set_haseval(aTHX);
9694         }
9695     }
9696     else {
9697         const U8 priv = o->op_private;
9698         op_free(o);
9699         /* the newUNOP will recursively call ck_eval(), which will handle
9700          * all the stuff at the end of this function, like adding
9701          * OP_HINTSEVAL
9702          */
9703         return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
9704     }
9705     o->op_targ = (PADOFFSET)PL_hints;
9706     if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
9707     if ((PL_hints & HINT_LOCALIZE_HH) != 0
9708      && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
9709         /* Store a copy of %^H that pp_entereval can pick up. */
9710         OP *hhop = newSVOP(OP_HINTSEVAL, 0,
9711                            MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
9712         /* append hhop to only child  */
9713         op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
9714
9715         o->op_private |= OPpEVAL_HAS_HH;
9716     }
9717     if (!(o->op_private & OPpEVAL_BYTES)
9718          && FEATURE_UNIEVAL_IS_ENABLED)
9719             o->op_private |= OPpEVAL_UNICODE;
9720     return o;
9721 }
9722
9723 OP *
9724 Perl_ck_exec(pTHX_ OP *o)
9725 {
9726     PERL_ARGS_ASSERT_CK_EXEC;
9727
9728     if (o->op_flags & OPf_STACKED) {
9729         OP *kid;
9730         o = ck_fun(o);
9731         kid = OpSIBLING(cUNOPo->op_first);
9732         if (kid->op_type == OP_RV2GV)
9733             op_null(kid);
9734     }
9735     else
9736         o = listkids(o);
9737     return o;
9738 }
9739
9740 OP *
9741 Perl_ck_exists(pTHX_ OP *o)
9742 {
9743     PERL_ARGS_ASSERT_CK_EXISTS;
9744
9745     o = ck_fun(o);
9746     if (o->op_flags & OPf_KIDS) {
9747         OP * const kid = cUNOPo->op_first;
9748         if (kid->op_type == OP_ENTERSUB) {
9749             (void) ref(kid, o->op_type);
9750             if (kid->op_type != OP_RV2CV
9751                         && !(PL_parser && PL_parser->error_count))
9752                 Perl_croak(aTHX_
9753                           "exists argument is not a subroutine name");
9754             o->op_private |= OPpEXISTS_SUB;
9755         }
9756         else if (kid->op_type == OP_AELEM)
9757             o->op_flags |= OPf_SPECIAL;
9758         else if (kid->op_type != OP_HELEM)
9759             Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
9760                              "element or a subroutine");
9761         op_null(kid);
9762     }
9763     return o;
9764 }
9765
9766 OP *
9767 Perl_ck_rvconst(pTHX_ OP *o)
9768 {
9769     dVAR;
9770     SVOP * const kid = (SVOP*)cUNOPo->op_first;
9771
9772     PERL_ARGS_ASSERT_CK_RVCONST;
9773
9774     o->op_private |= (PL_hints & HINT_STRICT_REFS);
9775
9776     if (kid->op_type == OP_CONST) {
9777         int iscv;
9778         GV *gv;
9779         SV * const kidsv = kid->op_sv;
9780
9781         /* Is it a constant from cv_const_sv()? */
9782         if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
9783             return o;
9784         }
9785         if (SvTYPE(kidsv) == SVt_PVAV) return o;
9786         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
9787             const char *badthing;
9788             switch (o->op_type) {
9789             case OP_RV2SV:
9790                 badthing = "a SCALAR";
9791                 break;
9792             case OP_RV2AV:
9793                 badthing = "an ARRAY";
9794                 break;
9795             case OP_RV2HV:
9796                 badthing = "a HASH";
9797                 break;
9798             default:
9799                 badthing = NULL;
9800                 break;
9801             }
9802             if (badthing)
9803                 Perl_croak(aTHX_
9804                            "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
9805                            SVfARG(kidsv), badthing);
9806         }
9807         /*
9808          * This is a little tricky.  We only want to add the symbol if we
9809          * didn't add it in the lexer.  Otherwise we get duplicate strict
9810          * warnings.  But if we didn't add it in the lexer, we must at
9811          * least pretend like we wanted to add it even if it existed before,
9812          * or we get possible typo warnings.  OPpCONST_ENTERED says
9813          * whether the lexer already added THIS instance of this symbol.
9814          */
9815         iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
9816         gv = gv_fetchsv(kidsv,
9817                 o->op_type == OP_RV2CV
9818                         && o->op_private & OPpMAY_RETURN_CONSTANT
9819                     ? GV_NOEXPAND
9820                     : iscv | !(kid->op_private & OPpCONST_ENTERED),
9821                 iscv
9822                     ? SVt_PVCV
9823                     : o->op_type == OP_RV2SV
9824                         ? SVt_PV
9825                         : o->op_type == OP_RV2AV
9826                             ? SVt_PVAV
9827                             : o->op_type == OP_RV2HV
9828                                 ? SVt_PVHV
9829                                 : SVt_PVGV);
9830         if (gv) {
9831             if (!isGV(gv)) {
9832                 assert(iscv);
9833                 assert(SvROK(gv));
9834                 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
9835                   && SvTYPE(SvRV(gv)) != SVt_PVCV)
9836                     gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
9837             }
9838             CHANGE_TYPE(kid, OP_GV);
9839             SvREFCNT_dec(kid->op_sv);
9840 #ifdef USE_ITHREADS
9841             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
9842             STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
9843             kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
9844             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
9845             PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
9846 #else
9847             kid->op_sv = SvREFCNT_inc_simple_NN(gv);
9848 #endif
9849             kid->op_private = 0;
9850             /* FAKE globs in the symbol table cause weird bugs (#77810) */
9851             SvFAKE_off(gv);
9852         }
9853     }
9854     return o;
9855 }
9856
9857 OP *
9858 Perl_ck_ftst(pTHX_ OP *o)
9859 {
9860     dVAR;
9861     const I32 type = o->op_type;
9862
9863     PERL_ARGS_ASSERT_CK_FTST;
9864
9865     if (o->op_flags & OPf_REF) {
9866         NOOP;
9867     }
9868     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
9869         SVOP * const kid = (SVOP*)cUNOPo->op_first;
9870         const OPCODE kidtype = kid->op_type;
9871
9872         if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
9873          && !kid->op_folded) {
9874             OP * const newop = newGVOP(type, OPf_REF,
9875                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
9876             op_free(o);
9877             return newop;
9878         }
9879         if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
9880             o->op_private |= OPpFT_ACCESS;
9881         if (PL_check[kidtype] == Perl_ck_ftst
9882                 && kidtype != OP_STAT && kidtype != OP_LSTAT) {
9883             o->op_private |= OPpFT_STACKED;
9884             kid->op_private |= OPpFT_STACKING;
9885             if (kidtype == OP_FTTTY && (
9886                    !(kid->op_private & OPpFT_STACKED)
9887                 || kid->op_private & OPpFT_AFTER_t
9888                ))
9889                 o->op_private |= OPpFT_AFTER_t;
9890         }
9891     }
9892     else {
9893         op_free(o);
9894         if (type == OP_FTTTY)
9895             o = newGVOP(type, OPf_REF, PL_stdingv);
9896         else
9897             o = newUNOP(type, 0, newDEFSVOP());
9898     }
9899     return o;
9900 }
9901
9902 OP *
9903 Perl_ck_fun(pTHX_ OP *o)
9904 {
9905     const int type = o->op_type;
9906     I32 oa = PL_opargs[type] >> OASHIFT;
9907
9908     PERL_ARGS_ASSERT_CK_FUN;
9909
9910     if (o->op_flags & OPf_STACKED) {
9911         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
9912             oa &= ~OA_OPTIONAL;
9913         else
9914             return no_fh_allowed(o);
9915     }
9916
9917     if (o->op_flags & OPf_KIDS) {
9918         OP *prev_kid = NULL;
9919         OP *kid = cLISTOPo->op_first;
9920         I32 numargs = 0;
9921         bool seen_optional = FALSE;
9922
9923         if (kid->op_type == OP_PUSHMARK ||
9924             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
9925         {
9926             prev_kid = kid;
9927             kid = OpSIBLING(kid);
9928         }
9929         if (kid && kid->op_type == OP_COREARGS) {
9930             bool optional = FALSE;
9931             while (oa) {
9932                 numargs++;
9933                 if (oa & OA_OPTIONAL) optional = TRUE;
9934                 oa = oa >> 4;
9935             }
9936             if (optional) o->op_private |= numargs;
9937             return o;
9938         }
9939
9940         while (oa) {
9941             if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
9942                 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
9943                     kid = newDEFSVOP();
9944                     /* append kid to chain */
9945                     op_sibling_splice(o, prev_kid, 0, kid);
9946                 }
9947                 seen_optional = TRUE;
9948             }
9949             if (!kid) break;
9950
9951             numargs++;
9952             switch (oa & 7) {
9953             case OA_SCALAR:
9954                 /* list seen where single (scalar) arg expected? */
9955                 if (numargs == 1 && !(oa >> 4)
9956                     && kid->op_type == OP_LIST && type != OP_SCALAR)
9957                 {
9958                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
9959                 }
9960                 if (type != OP_DELETE) scalar(kid);
9961                 break;
9962             case OA_LIST:
9963                 if (oa < 16) {
9964                     kid = 0;
9965                     continue;
9966                 }
9967                 else
9968                     list(kid);
9969                 break;
9970             case OA_AVREF:
9971                 if ((type == OP_PUSH || type == OP_UNSHIFT)
9972                     && !OpHAS_SIBLING(kid))
9973                     Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
9974                                    "Useless use of %s with no values",
9975                                    PL_op_desc[type]);
9976
9977                 if (kid->op_type == OP_CONST
9978                       && (  !SvROK(cSVOPx_sv(kid))
9979                          || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV  )
9980                         )
9981                     bad_type_pv(numargs, "array", o, kid);
9982                 /* Defer checks to run-time if we have a scalar arg */
9983                 if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
9984                     op_lvalue(kid, type);
9985                 else {
9986                     scalar(kid);
9987                     /* diag_listed_as: push on reference is experimental */
9988                     Perl_ck_warner_d(aTHX_
9989                                      packWARN(WARN_EXPERIMENTAL__AUTODEREF),
9990                                     "%s on reference is experimental",
9991                                      PL_op_desc[type]);
9992                 }
9993                 break;
9994             case OA_HVREF:
9995                 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
9996                     bad_type_pv(numargs, "hash", o, kid);
9997                 op_lvalue(kid, type);
9998                 break;
9999             case OA_CVREF:
10000                 {
10001                     /* replace kid with newop in chain */
10002                     OP * const newop =
10003                         S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
10004                     newop->op_next = newop;
10005                     kid = newop;
10006                 }
10007                 break;
10008             case OA_FILEREF:
10009                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
10010                     if (kid->op_type == OP_CONST &&
10011                         (kid->op_private & OPpCONST_BARE))
10012                     {
10013                         OP * const newop = newGVOP(OP_GV, 0,
10014                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
10015                         /* replace kid with newop in chain */
10016                         op_sibling_splice(o, prev_kid, 1, newop);
10017                         op_free(kid);
10018                         kid = newop;
10019                     }
10020                     else if (kid->op_type == OP_READLINE) {
10021                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
10022                         bad_type_pv(numargs, "HANDLE", o, kid);
10023                     }
10024                     else {
10025                         I32 flags = OPf_SPECIAL;
10026                         I32 priv = 0;
10027                         PADOFFSET targ = 0;
10028
10029                         /* is this op a FH constructor? */
10030                         if (is_handle_constructor(o,numargs)) {
10031                             const char *name = NULL;
10032                             STRLEN len = 0;
10033                             U32 name_utf8 = 0;
10034                             bool want_dollar = TRUE;
10035
10036                             flags = 0;
10037                             /* Set a flag to tell rv2gv to vivify
10038                              * need to "prove" flag does not mean something
10039                              * else already - NI-S 1999/05/07
10040                              */
10041                             priv = OPpDEREF;
10042                             if (kid->op_type == OP_PADSV) {
10043                                 PADNAME * const pn
10044                                     = PAD_COMPNAME_SV(kid->op_targ);
10045                                 name = PadnamePV (pn);
10046                                 len  = PadnameLEN(pn);
10047                                 name_utf8 = PadnameUTF8(pn);
10048                             }
10049                             else if (kid->op_type == OP_RV2SV
10050                                      && kUNOP->op_first->op_type == OP_GV)
10051                             {
10052                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
10053                                 name = GvNAME(gv);
10054                                 len = GvNAMELEN(gv);
10055                                 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
10056                             }
10057                             else if (kid->op_type == OP_AELEM
10058                                      || kid->op_type == OP_HELEM)
10059                             {
10060                                  OP *firstop;
10061                                  OP *op = ((BINOP*)kid)->op_first;
10062                                  name = NULL;
10063                                  if (op) {
10064                                       SV *tmpstr = NULL;
10065                                       const char * const a =
10066                                            kid->op_type == OP_AELEM ?
10067                                            "[]" : "{}";
10068                                       if (((op->op_type == OP_RV2AV) ||
10069                                            (op->op_type == OP_RV2HV)) &&
10070                                           (firstop = ((UNOP*)op)->op_first) &&
10071                                           (firstop->op_type == OP_GV)) {
10072                                            /* packagevar $a[] or $h{} */
10073                                            GV * const gv = cGVOPx_gv(firstop);
10074                                            if (gv)
10075                                                 tmpstr =
10076                                                      Perl_newSVpvf(aTHX_
10077                                                                    "%s%c...%c",
10078                                                                    GvNAME(gv),
10079                                                                    a[0], a[1]);
10080                                       }
10081                                       else if (op->op_type == OP_PADAV
10082                                                || op->op_type == OP_PADHV) {
10083                                            /* lexicalvar $a[] or $h{} */
10084                                            const char * const padname =
10085                                                 PAD_COMPNAME_PV(op->op_targ);
10086                                            if (padname)
10087                                                 tmpstr =
10088                                                      Perl_newSVpvf(aTHX_
10089                                                                    "%s%c...%c",
10090                                                                    padname + 1,
10091                                                                    a[0], a[1]);
10092                                       }
10093                                       if (tmpstr) {
10094                                            name = SvPV_const(tmpstr, len);
10095                                            name_utf8 = SvUTF8(tmpstr);
10096                                            sv_2mortal(tmpstr);
10097                                       }
10098                                  }
10099                                  if (!name) {
10100                                       name = "__ANONIO__";
10101                                       len = 10;
10102                                       want_dollar = FALSE;
10103                                  }
10104                                  op_lvalue(kid, type);
10105                             }
10106                             if (name) {
10107                                 SV *namesv;
10108                                 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
10109                                 namesv = PAD_SVl(targ);
10110                                 if (want_dollar && *name != '$')
10111                                     sv_setpvs(namesv, "$");
10112                                 else
10113                                     sv_setpvs(namesv, "");
10114                                 sv_catpvn(namesv, name, len);
10115                                 if ( name_utf8 ) SvUTF8_on(namesv);
10116                             }
10117                         }
10118                         scalar(kid);
10119                         kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
10120                                     OP_RV2GV, flags);
10121                         kid->op_targ = targ;
10122                         kid->op_private |= priv;
10123                     }
10124                 }
10125                 scalar(kid);
10126                 break;
10127             case OA_SCALARREF:
10128                 if ((type == OP_UNDEF || type == OP_POS)
10129                     && numargs == 1 && !(oa >> 4)
10130                     && kid->op_type == OP_LIST)
10131                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
10132                 op_lvalue(scalar(kid), type);
10133                 break;
10134             }
10135             oa >>= 4;
10136             prev_kid = kid;
10137             kid = OpSIBLING(kid);
10138         }
10139         /* FIXME - should the numargs or-ing move after the too many
10140          * arguments check? */
10141         o->op_private |= numargs;
10142         if (kid)
10143             return too_many_arguments_pv(o,OP_DESC(o), 0);
10144         listkids(o);
10145     }
10146     else if (PL_opargs[type] & OA_DEFGV) {
10147         /* Ordering of these two is important to keep f_map.t passing.  */
10148         op_free(o);
10149         return newUNOP(type, 0, newDEFSVOP());
10150     }
10151
10152     if (oa) {
10153         while (oa & OA_OPTIONAL)
10154             oa >>= 4;
10155         if (oa && oa != OA_LIST)
10156             return too_few_arguments_pv(o,OP_DESC(o), 0);
10157     }
10158     return o;
10159 }
10160
10161 OP *
10162 Perl_ck_glob(pTHX_ OP *o)
10163 {
10164     GV *gv;
10165
10166     PERL_ARGS_ASSERT_CK_GLOB;
10167
10168     o = ck_fun(o);
10169     if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
10170         op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
10171
10172     if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
10173     {
10174         /* convert
10175          *     glob
10176          *       \ null - const(wildcard)
10177          * into
10178          *     null
10179          *       \ enter
10180          *            \ list
10181          *                 \ mark - glob - rv2cv
10182          *                             |        \ gv(CORE::GLOBAL::glob)
10183          *                             |
10184          *                              \ null - const(wildcard)
10185          */
10186         o->op_flags |= OPf_SPECIAL;
10187         o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
10188         o = S_new_entersubop(aTHX_ gv, o);
10189         o = newUNOP(OP_NULL, 0, o);
10190         o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
10191         return o;
10192     }
10193     else o->op_flags &= ~OPf_SPECIAL;
10194 #if !defined(PERL_EXTERNAL_GLOB)
10195     if (!PL_globhook) {
10196         ENTER;
10197         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
10198                                newSVpvs("File::Glob"), NULL, NULL, NULL);
10199         LEAVE;
10200     }
10201 #endif /* !PERL_EXTERNAL_GLOB */
10202     gv = (GV *)newSV(0);
10203     gv_init(gv, 0, "", 0, 0);
10204     gv_IOadd(gv);
10205     op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
10206     SvREFCNT_dec_NN(gv); /* newGVOP increased it */
10207     scalarkids(o);
10208     return o;
10209 }
10210
10211 OP *
10212 Perl_ck_grep(pTHX_ OP *o)
10213 {
10214     LOGOP *gwop;
10215     OP *kid;
10216     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
10217     PADOFFSET offset;
10218
10219     PERL_ARGS_ASSERT_CK_GREP;
10220
10221     /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
10222
10223     if (o->op_flags & OPf_STACKED) {
10224         kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
10225         if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
10226             return no_fh_allowed(o);
10227         o->op_flags &= ~OPf_STACKED;
10228     }
10229     kid = OpSIBLING(cLISTOPo->op_first);
10230     if (type == OP_MAPWHILE)
10231         list(kid);
10232     else
10233         scalar(kid);
10234     o = ck_fun(o);
10235     if (PL_parser && PL_parser->error_count)
10236         return o;
10237     kid = OpSIBLING(cLISTOPo->op_first);
10238     if (kid->op_type != OP_NULL)
10239         Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
10240     kid = kUNOP->op_first;
10241
10242     gwop = S_alloc_LOGOP(aTHX_ type, o, LINKLIST(kid));
10243     kid->op_next = (OP*)gwop;
10244     offset = pad_findmy_pvs("$_", 0);
10245     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
10246         o->op_private = gwop->op_private = 0;
10247         gwop->op_targ = pad_alloc(type, SVs_PADTMP);
10248     }
10249     else {
10250         o->op_private = gwop->op_private = OPpGREP_LEX;
10251         gwop->op_targ = o->op_targ = offset;
10252     }
10253
10254     kid = OpSIBLING(cLISTOPo->op_first);
10255     for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
10256         op_lvalue(kid, OP_GREPSTART);
10257
10258     return (OP*)gwop;
10259 }
10260
10261 OP *
10262 Perl_ck_index(pTHX_ OP *o)
10263 {
10264     PERL_ARGS_ASSERT_CK_INDEX;
10265
10266     if (o->op_flags & OPf_KIDS) {
10267         OP *kid = OpSIBLING(cLISTOPo->op_first);        /* get past pushmark */
10268         if (kid)
10269             kid = OpSIBLING(kid);                       /* get past "big" */
10270         if (kid && kid->op_type == OP_CONST) {
10271             const bool save_taint = TAINT_get;
10272             SV *sv = kSVOP->op_sv;
10273             if ((!SvPOK(sv) || SvNIOKp(sv)) && SvOK(sv) && !SvROK(sv)) {
10274                 sv = newSV(0);
10275                 sv_copypv(sv, kSVOP->op_sv);
10276                 SvREFCNT_dec_NN(kSVOP->op_sv);
10277                 kSVOP->op_sv = sv;
10278             }
10279             if (SvOK(sv)) fbm_compile(sv, 0);
10280             TAINT_set(save_taint);
10281 #ifdef NO_TAINT_SUPPORT
10282             PERL_UNUSED_VAR(save_taint);
10283 #endif
10284         }
10285     }
10286     return ck_fun(o);
10287 }
10288
10289 OP *
10290 Perl_ck_lfun(pTHX_ OP *o)
10291 {
10292     const OPCODE type = o->op_type;
10293
10294     PERL_ARGS_ASSERT_CK_LFUN;
10295
10296     return modkids(ck_fun(o), type);
10297 }
10298
10299 OP *
10300 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
10301 {
10302     PERL_ARGS_ASSERT_CK_DEFINED;
10303
10304     if ((o->op_flags & OPf_KIDS)) {
10305         switch (cUNOPo->op_first->op_type) {
10306         case OP_RV2AV:
10307         case OP_PADAV:
10308             Perl_croak(aTHX_ "Can't use 'defined(@array)'"
10309                              " (Maybe you should just omit the defined()?)");
10310         break;
10311         case OP_RV2HV:
10312         case OP_PADHV:
10313             Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
10314                              " (Maybe you should just omit the defined()?)");
10315             break;
10316         default:
10317             /* no warning */
10318             break;
10319         }
10320     }
10321     return ck_rfun(o);
10322 }
10323
10324 OP *
10325 Perl_ck_readline(pTHX_ OP *o)
10326 {
10327     PERL_ARGS_ASSERT_CK_READLINE;
10328
10329     if (o->op_flags & OPf_KIDS) {
10330          OP *kid = cLISTOPo->op_first;
10331          if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
10332     }
10333     else {
10334         OP * const newop
10335             = newUNOP(OP_READLINE, o->op_flags | OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
10336         op_free(o);
10337         return newop;
10338     }
10339     return o;
10340 }
10341
10342 OP *
10343 Perl_ck_rfun(pTHX_ OP *o)
10344 {
10345     const OPCODE type = o->op_type;
10346
10347     PERL_ARGS_ASSERT_CK_RFUN;
10348
10349     return refkids(ck_fun(o), type);
10350 }
10351
10352 OP *
10353 Perl_ck_listiob(pTHX_ OP *o)
10354 {
10355     OP *kid;
10356
10357     PERL_ARGS_ASSERT_CK_LISTIOB;
10358
10359     kid = cLISTOPo->op_first;
10360     if (!kid) {
10361         o = force_list(o, 1);
10362         kid = cLISTOPo->op_first;
10363     }
10364     if (kid->op_type == OP_PUSHMARK)
10365         kid = OpSIBLING(kid);
10366     if (kid && o->op_flags & OPf_STACKED)
10367         kid = OpSIBLING(kid);
10368     else if (kid && !OpHAS_SIBLING(kid)) {              /* print HANDLE; */
10369         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
10370          && !kid->op_folded) {
10371             o->op_flags |= OPf_STACKED; /* make it a filehandle */
10372             scalar(kid);
10373             /* replace old const op with new OP_RV2GV parent */
10374             kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
10375                                         OP_RV2GV, OPf_REF);
10376             kid = OpSIBLING(kid);
10377         }
10378     }
10379
10380     if (!kid)
10381         op_append_elem(o->op_type, o, newDEFSVOP());
10382
10383     if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
10384     return listkids(o);
10385 }
10386
10387 OP *
10388 Perl_ck_smartmatch(pTHX_ OP *o)
10389 {
10390     dVAR;
10391     PERL_ARGS_ASSERT_CK_SMARTMATCH;
10392     if (0 == (o->op_flags & OPf_SPECIAL)) {
10393         OP *first  = cBINOPo->op_first;
10394         OP *second = OpSIBLING(first);
10395
10396         /* Implicitly take a reference to an array or hash */
10397
10398         /* remove the original two siblings, then add back the
10399          * (possibly different) first and second sibs.
10400          */
10401         op_sibling_splice(o, NULL, 1, NULL);
10402         op_sibling_splice(o, NULL, 1, NULL);
10403         first  = ref_array_or_hash(first);
10404         second = ref_array_or_hash(second);
10405         op_sibling_splice(o, NULL, 0, second);
10406         op_sibling_splice(o, NULL, 0, first);
10407
10408         /* Implicitly take a reference to a regular expression */
10409         if (first->op_type == OP_MATCH) {
10410             CHANGE_TYPE(first, OP_QR);
10411         }
10412         if (second->op_type == OP_MATCH) {
10413             CHANGE_TYPE(second, OP_QR);
10414         }
10415     }
10416
10417     return o;
10418 }
10419
10420
10421 static OP *
10422 S_maybe_targlex(pTHX_ OP *o)
10423 {
10424     OP * const kid = cLISTOPo->op_first;
10425     /* has a disposable target? */
10426     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
10427         && !(kid->op_flags & OPf_STACKED)
10428         /* Cannot steal the second time! */
10429         && !(kid->op_private & OPpTARGET_MY)
10430         )
10431     {
10432         OP * const kkid = OpSIBLING(kid);
10433
10434         /* Can just relocate the target. */
10435         if (kkid && kkid->op_type == OP_PADSV
10436             && (!(kkid->op_private & OPpLVAL_INTRO)
10437                || kkid->op_private & OPpPAD_STATE))
10438         {
10439             kid->op_targ = kkid->op_targ;
10440             kkid->op_targ = 0;
10441             /* Now we do not need PADSV and SASSIGN.
10442              * Detach kid and free the rest. */
10443             op_sibling_splice(o, NULL, 1, NULL);
10444             op_free(o);
10445             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
10446             return kid;
10447         }
10448     }
10449     return o;
10450 }
10451
10452 OP *
10453 Perl_ck_sassign(pTHX_ OP *o)
10454 {
10455     dVAR;
10456     OP * const kid = cLISTOPo->op_first;
10457
10458     PERL_ARGS_ASSERT_CK_SASSIGN;
10459
10460     if (OpHAS_SIBLING(kid)) {
10461         OP *kkid = OpSIBLING(kid);
10462         /* For state variable assignment with attributes, kkid is a list op
10463            whose op_last is a padsv. */
10464         if ((kkid->op_type == OP_PADSV ||
10465              (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
10466               (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
10467              )
10468             )
10469                 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
10470                     == (OPpLVAL_INTRO|OPpPAD_STATE)) {
10471             const PADOFFSET target = kkid->op_targ;
10472             OP *const other = newOP(OP_PADSV,
10473                                     kkid->op_flags
10474                                     | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
10475             OP *const first = newOP(OP_NULL, 0);
10476             OP *const nullop =
10477                 newCONDOP(0, first, S_maybe_targlex(aTHX_ o), other);
10478             OP *const condop = first->op_next;
10479
10480             CHANGE_TYPE(condop, OP_ONCE);
10481             other->op_targ = target;
10482             nullop->op_flags |= OPf_WANT_SCALAR;
10483
10484             /* Store the initializedness of state vars in a separate
10485                pad entry.  */
10486             condop->op_targ =
10487               pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
10488             /* hijacking PADSTALE for uninitialized state variables */
10489             SvPADSTALE_on(PAD_SVl(condop->op_targ));
10490
10491             return nullop;
10492         }
10493     }
10494     return S_maybe_targlex(aTHX_ o);
10495 }
10496
10497 OP *
10498 Perl_ck_match(pTHX_ OP *o)
10499 {
10500     PERL_ARGS_ASSERT_CK_MATCH;
10501
10502     if (o->op_type != OP_QR && PL_compcv) {
10503         const PADOFFSET offset = pad_findmy_pvs("$_", 0);
10504         if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
10505             o->op_targ = offset;
10506             o->op_private |= OPpTARGET_MY;
10507         }
10508     }
10509     if (o->op_type == OP_MATCH || o->op_type == OP_QR)
10510         o->op_private |= OPpRUNTIME;
10511     return o;
10512 }
10513
10514 OP *
10515 Perl_ck_method(pTHX_ OP *o)
10516 {
10517     SV *sv, *methsv, *rclass;
10518     const char* method;
10519     char* compatptr;
10520     int utf8;
10521     STRLEN len, nsplit = 0, i;
10522     OP* new_op;
10523     OP * const kid = cUNOPo->op_first;
10524
10525     PERL_ARGS_ASSERT_CK_METHOD;
10526     if (kid->op_type != OP_CONST) return o;
10527
10528     sv = kSVOP->op_sv;
10529
10530     /* replace ' with :: */
10531     while ((compatptr = strchr(SvPVX(sv), '\''))) {
10532         *compatptr = ':';
10533         sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
10534     }
10535
10536     method = SvPVX_const(sv);
10537     len = SvCUR(sv);
10538     utf8 = SvUTF8(sv) ? -1 : 1;
10539
10540     for (i = len - 1; i > 0; --i) if (method[i] == ':') {
10541         nsplit = i+1;
10542         break;
10543     }
10544
10545     methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
10546
10547     if (!nsplit) { /* $proto->method() */
10548         op_free(o);
10549         return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
10550     }
10551
10552     if (nsplit == 7 && memEQ(method, "SUPER::", nsplit)) { /* $proto->SUPER::method() */
10553         op_free(o);
10554         return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
10555     }
10556
10557     /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
10558     if (nsplit >= 9 && strnEQ(method+nsplit-9, "::SUPER::", 9)) {
10559         rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
10560         new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
10561     } else {
10562         rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
10563         new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
10564     }
10565 #ifdef USE_ITHREADS
10566     op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
10567 #else
10568     cMETHOPx(new_op)->op_rclass_sv = rclass;
10569 #endif
10570     op_free(o);
10571     return new_op;
10572 }
10573
10574 OP *
10575 Perl_ck_null(pTHX_ OP *o)
10576 {
10577     PERL_ARGS_ASSERT_CK_NULL;
10578     PERL_UNUSED_CONTEXT;
10579     return o;
10580 }
10581
10582 OP *
10583 Perl_ck_open(pTHX_ OP *o)
10584 {
10585     PERL_ARGS_ASSERT_CK_OPEN;
10586
10587     S_io_hints(aTHX_ o);
10588     {
10589          /* In case of three-arg dup open remove strictness
10590           * from the last arg if it is a bareword. */
10591          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
10592          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
10593          OP *oa;
10594          const char *mode;
10595
10596          if ((last->op_type == OP_CONST) &&             /* The bareword. */
10597              (last->op_private & OPpCONST_BARE) &&
10598              (last->op_private & OPpCONST_STRICT) &&
10599              (oa = OpSIBLING(first)) &&         /* The fh. */
10600              (oa = OpSIBLING(oa)) &&                    /* The mode. */
10601              (oa->op_type == OP_CONST) &&
10602              SvPOK(((SVOP*)oa)->op_sv) &&
10603              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
10604              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
10605              (last == OpSIBLING(oa)))                   /* The bareword. */
10606               last->op_private &= ~OPpCONST_STRICT;
10607     }
10608     return ck_fun(o);
10609 }
10610
10611 OP *
10612 Perl_ck_prototype(pTHX_ OP *o)
10613 {
10614     PERL_ARGS_ASSERT_CK_PROTOTYPE;
10615     if (!(o->op_flags & OPf_KIDS)) {
10616         op_free(o);
10617         return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
10618     }
10619     return o;
10620 }
10621
10622 OP *
10623 Perl_ck_refassign(pTHX_ OP *o)
10624 {
10625     OP * const right = cLISTOPo->op_first;
10626     OP * const left = OpSIBLING(right);
10627     OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
10628     bool stacked = 0;
10629
10630     PERL_ARGS_ASSERT_CK_REFASSIGN;
10631     assert (left);
10632     assert (left->op_type == OP_SREFGEN);
10633
10634     o->op_private = varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE);
10635
10636     switch (varop->op_type) {
10637     case OP_PADAV:
10638         o->op_private |= OPpLVREF_AV;
10639         goto settarg;
10640     case OP_PADHV:
10641         o->op_private |= OPpLVREF_HV;
10642     case OP_PADSV:
10643       settarg:
10644         o->op_targ = varop->op_targ;
10645         varop->op_targ = 0;
10646         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
10647         break;
10648     case OP_RV2AV:
10649         o->op_private |= OPpLVREF_AV;
10650         goto checkgv;
10651     case OP_RV2HV:
10652         o->op_private |= OPpLVREF_HV;
10653     case OP_RV2SV:
10654       checkgv:
10655         if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
10656       detach_and_stack:
10657         /* Point varop to its GV kid, detached.  */
10658         varop = op_sibling_splice(varop, NULL, -1, NULL);
10659         stacked = TRUE;
10660         break;
10661     case OP_RV2CV: {
10662         OP * const kidparent =
10663             cUNOPx(cUNOPx(varop)->op_first)->op_first->op_sibling;
10664         OP * const kid = cUNOPx(kidparent)->op_first;
10665         o->op_private |= OPpLVREF_CV;
10666         if (kid->op_type == OP_GV) {
10667             varop = kidparent;
10668             goto detach_and_stack;
10669         }
10670         if (kid->op_type != OP_PADCV)   goto bad;
10671         o->op_targ = kid->op_targ;
10672         kid->op_targ = 0;
10673         break;
10674     }
10675     case OP_AELEM:
10676     case OP_HELEM:
10677         o->op_private |= OPpLVREF_ELEM;
10678         op_null(varop);
10679         stacked = TRUE;
10680         /* Detach varop.  */
10681         op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
10682         break;
10683     default:
10684       bad:
10685         /* diag_listed_as: Can't modify reference to %s in %s assignment */
10686         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
10687                                 "assignment",
10688                                  OP_DESC(varop)));
10689         return o;
10690     }
10691     if (!FEATURE_REFALIASING_IS_ENABLED)
10692         Perl_croak(aTHX_
10693                   "Experimental aliasing via reference not enabled");
10694     Perl_ck_warner_d(aTHX_
10695                      packWARN(WARN_EXPERIMENTAL__REFALIASING),
10696                     "Aliasing via reference is experimental");
10697     if (stacked) {
10698         o->op_flags |= OPf_STACKED;
10699         op_sibling_splice(o, right, 1, varop);
10700     }
10701     else {
10702         o->op_flags &=~ OPf_STACKED;
10703         op_sibling_splice(o, right, 1, NULL);
10704     }
10705     op_free(left);
10706     return o;
10707 }
10708
10709 OP *
10710 Perl_ck_repeat(pTHX_ OP *o)
10711 {
10712     PERL_ARGS_ASSERT_CK_REPEAT;
10713
10714     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
10715         OP* kids;
10716         o->op_private |= OPpREPEAT_DOLIST;
10717         kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
10718         kids = force_list(kids, 1); /* promote it to a list */
10719         op_sibling_splice(o, NULL, 0, kids); /* and add back */
10720     }
10721     else
10722         scalar(o);
10723     return o;
10724 }
10725
10726 OP *
10727 Perl_ck_require(pTHX_ OP *o)
10728 {
10729     GV* gv;
10730
10731     PERL_ARGS_ASSERT_CK_REQUIRE;
10732
10733     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
10734         SVOP * const kid = (SVOP*)cUNOPo->op_first;
10735         HEK *hek;
10736         U32 hash;
10737         char *s;
10738         STRLEN len;
10739         if (kid->op_type == OP_CONST) {
10740           SV * const sv = kid->op_sv;
10741           U32 const was_readonly = SvREADONLY(sv);
10742           if (kid->op_private & OPpCONST_BARE) {
10743             dVAR;
10744             const char *end;
10745
10746             if (was_readonly) {
10747                     SvREADONLY_off(sv);
10748             }
10749             if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
10750
10751             s = SvPVX(sv);
10752             len = SvCUR(sv);
10753             end = s + len;
10754             for (; s < end; s++) {
10755                 if (*s == ':' && s[1] == ':') {
10756                     *s = '/';
10757                     Move(s+2, s+1, end - s - 1, char);
10758                     --end;
10759                 }
10760             }
10761             SvEND_set(sv, end);
10762             sv_catpvs(sv, ".pm");
10763             PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
10764             hek = share_hek(SvPVX(sv),
10765                             (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
10766                             hash);
10767             sv_sethek(sv, hek);
10768             unshare_hek(hek);
10769             SvFLAGS(sv) |= was_readonly;
10770           }
10771           else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)) {
10772             s = SvPV(sv, len);
10773             if (SvREFCNT(sv) > 1) {
10774                 kid->op_sv = newSVpvn_share(
10775                     s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
10776                 SvREFCNT_dec_NN(sv);
10777             }
10778             else {
10779                 dVAR;
10780                 if (was_readonly) SvREADONLY_off(sv);
10781                 PERL_HASH(hash, s, len);
10782                 hek = share_hek(s,
10783                                 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
10784                                 hash);
10785                 sv_sethek(sv, hek);
10786                 unshare_hek(hek);
10787                 SvFLAGS(sv) |= was_readonly;
10788             }
10789           }
10790         }
10791     }
10792
10793     if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
10794         /* handle override, if any */
10795      && (gv = gv_override("require", 7))) {
10796         OP *kid, *newop;
10797         if (o->op_flags & OPf_KIDS) {
10798             kid = cUNOPo->op_first;
10799             op_sibling_splice(o, NULL, -1, NULL);
10800         }
10801         else {
10802             kid = newDEFSVOP();
10803         }
10804         op_free(o);
10805         newop = S_new_entersubop(aTHX_ gv, kid);
10806         return newop;
10807     }
10808
10809     return ck_fun(o);
10810 }
10811
10812 OP *
10813 Perl_ck_return(pTHX_ OP *o)
10814 {
10815     OP *kid;
10816
10817     PERL_ARGS_ASSERT_CK_RETURN;
10818
10819     kid = OpSIBLING(cLISTOPo->op_first);
10820     if (CvLVALUE(PL_compcv)) {
10821         for (; kid; kid = OpSIBLING(kid))
10822             op_lvalue(kid, OP_LEAVESUBLV);
10823     }
10824
10825     return o;
10826 }
10827
10828 OP *
10829 Perl_ck_select(pTHX_ OP *o)
10830 {
10831     dVAR;
10832     OP* kid;
10833
10834     PERL_ARGS_ASSERT_CK_SELECT;
10835
10836     if (o->op_flags & OPf_KIDS) {
10837         kid = OpSIBLING(cLISTOPo->op_first);     /* get past pushmark */
10838         if (kid && OpHAS_SIBLING(kid)) {
10839             CHANGE_TYPE(o, OP_SSELECT);
10840             o = ck_fun(o);
10841             return fold_constants(op_integerize(op_std_init(o)));
10842         }
10843     }
10844     o = ck_fun(o);
10845     kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
10846     if (kid && kid->op_type == OP_RV2GV)
10847         kid->op_private &= ~HINT_STRICT_REFS;
10848     return o;
10849 }
10850
10851 OP *
10852 Perl_ck_shift(pTHX_ OP *o)
10853 {
10854     const I32 type = o->op_type;
10855
10856     PERL_ARGS_ASSERT_CK_SHIFT;
10857
10858     if (!(o->op_flags & OPf_KIDS)) {
10859         OP *argop;
10860
10861         if (!CvUNIQUE(PL_compcv)) {
10862             o->op_flags |= OPf_SPECIAL;
10863             return o;
10864         }
10865
10866         argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
10867         op_free(o);
10868         return newUNOP(type, 0, scalar(argop));
10869     }
10870     return scalar(ck_fun(o));
10871 }
10872
10873 OP *
10874 Perl_ck_sort(pTHX_ OP *o)
10875 {
10876     OP *firstkid;
10877     OP *kid;
10878     HV * const hinthv =
10879         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
10880     U8 stacked;
10881
10882     PERL_ARGS_ASSERT_CK_SORT;
10883
10884     if (hinthv) {
10885             SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
10886             if (svp) {
10887                 const I32 sorthints = (I32)SvIV(*svp);
10888                 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
10889                     o->op_private |= OPpSORT_QSORT;
10890                 if ((sorthints & HINT_SORT_STABLE) != 0)
10891                     o->op_private |= OPpSORT_STABLE;
10892             }
10893     }
10894
10895     if (o->op_flags & OPf_STACKED)
10896         simplify_sort(o);
10897     firstkid = OpSIBLING(cLISTOPo->op_first);           /* get past pushmark */
10898
10899     if ((stacked = o->op_flags & OPf_STACKED)) {        /* may have been cleared */
10900         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
10901
10902         /* if the first arg is a code block, process it and mark sort as
10903          * OPf_SPECIAL */
10904         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
10905             LINKLIST(kid);
10906             if (kid->op_type == OP_LEAVE)
10907                     op_null(kid);                       /* wipe out leave */
10908             /* Prevent execution from escaping out of the sort block. */
10909             kid->op_next = 0;
10910
10911             /* provide scalar context for comparison function/block */
10912             kid = scalar(firstkid);
10913             kid->op_next = kid;
10914             o->op_flags |= OPf_SPECIAL;
10915         }
10916         else if (kid->op_type == OP_CONST
10917               && kid->op_private & OPpCONST_BARE) {
10918             char tmpbuf[256];
10919             STRLEN len;
10920             PADOFFSET off;
10921             const char * const name = SvPV(kSVOP_sv, len);
10922             *tmpbuf = '&';
10923             assert (len < 256);
10924             Copy(name, tmpbuf+1, len, char);
10925             off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv));
10926             if (off != NOT_IN_PAD) {
10927                 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
10928                     SV * const fq =
10929                         newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
10930                     sv_catpvs(fq, "::");
10931                     sv_catsv(fq, kSVOP_sv);
10932                     SvREFCNT_dec_NN(kSVOP_sv);
10933                     kSVOP->op_sv = fq;
10934                 }
10935                 else {
10936                     OP * const padop = newOP(OP_PADCV, 0);
10937                     padop->op_targ = off;
10938                     cUNOPx(firstkid)->op_first = padop;
10939 #ifdef PERL_OP_PARENT
10940                     padop->op_sibling = firstkid;
10941 #endif
10942                     op_free(kid);
10943                 }
10944             }
10945         }
10946
10947         firstkid = OpSIBLING(firstkid);
10948     }
10949
10950     for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
10951         /* provide list context for arguments */
10952         list(kid);
10953         if (stacked)
10954             op_lvalue(kid, OP_GREPSTART);
10955     }
10956
10957     return o;
10958 }
10959
10960 /* for sort { X } ..., where X is one of
10961  *   $a <=> $b, $b <= $a, $a cmp $b, $b cmp $a
10962  * elide the second child of the sort (the one containing X),
10963  * and set these flags as appropriate
10964         OPpSORT_NUMERIC;
10965         OPpSORT_INTEGER;
10966         OPpSORT_DESCEND;
10967  * Also, check and warn on lexical $a, $b.
10968  */
10969
10970 STATIC void
10971 S_simplify_sort(pTHX_ OP *o)
10972 {
10973     OP *kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
10974     OP *k;
10975     int descending;
10976     GV *gv;
10977     const char *gvname;
10978     bool have_scopeop;
10979
10980     PERL_ARGS_ASSERT_SIMPLIFY_SORT;
10981
10982     kid = kUNOP->op_first;                              /* get past null */
10983     if (!(have_scopeop = kid->op_type == OP_SCOPE)
10984      && kid->op_type != OP_LEAVE)
10985         return;
10986     kid = kLISTOP->op_last;                             /* get past scope */
10987     switch(kid->op_type) {
10988         case OP_NCMP:
10989         case OP_I_NCMP:
10990         case OP_SCMP:
10991             if (!have_scopeop) goto padkids;
10992             break;
10993         default:
10994             return;
10995     }
10996     k = kid;                                            /* remember this node*/
10997     if (kBINOP->op_first->op_type != OP_RV2SV
10998      || kBINOP->op_last ->op_type != OP_RV2SV)
10999     {
11000         /*
11001            Warn about my($a) or my($b) in a sort block, *if* $a or $b is
11002            then used in a comparison.  This catches most, but not
11003            all cases.  For instance, it catches
11004                sort { my($a); $a <=> $b }
11005            but not
11006                sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
11007            (although why you'd do that is anyone's guess).
11008         */
11009
11010        padkids:
11011         if (!ckWARN(WARN_SYNTAX)) return;
11012         kid = kBINOP->op_first;
11013         do {
11014             if (kid->op_type == OP_PADSV) {
11015                 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
11016                 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
11017                  && (  PadnamePV(name)[1] == 'a'
11018                     || PadnamePV(name)[1] == 'b'  ))
11019                     /* diag_listed_as: "my %s" used in sort comparison */
11020                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11021                                      "\"%s %s\" used in sort comparison",
11022                                       PadnameIsSTATE(name)
11023                                         ? "state"
11024                                         : "my",
11025                                       PadnamePV(name));
11026             }
11027         } while ((kid = OpSIBLING(kid)));
11028         return;
11029     }
11030     kid = kBINOP->op_first;                             /* get past cmp */
11031     if (kUNOP->op_first->op_type != OP_GV)
11032         return;
11033     kid = kUNOP->op_first;                              /* get past rv2sv */
11034     gv = kGVOP_gv;
11035     if (GvSTASH(gv) != PL_curstash)
11036         return;
11037     gvname = GvNAME(gv);
11038     if (*gvname == 'a' && gvname[1] == '\0')
11039         descending = 0;
11040     else if (*gvname == 'b' && gvname[1] == '\0')
11041         descending = 1;
11042     else
11043         return;
11044
11045     kid = k;                                            /* back to cmp */
11046     /* already checked above that it is rv2sv */
11047     kid = kBINOP->op_last;                              /* down to 2nd arg */
11048     if (kUNOP->op_first->op_type != OP_GV)
11049         return;
11050     kid = kUNOP->op_first;                              /* get past rv2sv */
11051     gv = kGVOP_gv;
11052     if (GvSTASH(gv) != PL_curstash)
11053         return;
11054     gvname = GvNAME(gv);
11055     if ( descending
11056          ? !(*gvname == 'a' && gvname[1] == '\0')
11057          : !(*gvname == 'b' && gvname[1] == '\0'))
11058         return;
11059     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
11060     if (descending)
11061         o->op_private |= OPpSORT_DESCEND;
11062     if (k->op_type == OP_NCMP)
11063         o->op_private |= OPpSORT_NUMERIC;
11064     if (k->op_type == OP_I_NCMP)
11065         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
11066     kid = OpSIBLING(cLISTOPo->op_first);
11067     /* cut out and delete old block (second sibling) */
11068     op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
11069     op_free(kid);
11070 }
11071
11072 OP *
11073 Perl_ck_split(pTHX_ OP *o)
11074 {
11075     dVAR;
11076     OP *kid;
11077
11078     PERL_ARGS_ASSERT_CK_SPLIT;
11079
11080     if (o->op_flags & OPf_STACKED)
11081         return no_fh_allowed(o);
11082
11083     kid = cLISTOPo->op_first;
11084     if (kid->op_type != OP_NULL)
11085         Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
11086     /* delete leading NULL node, then add a CONST if no other nodes */
11087     op_sibling_splice(o, NULL, 1,
11088         OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
11089     op_free(kid);
11090     kid = cLISTOPo->op_first;
11091
11092     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
11093         /* remove kid, and replace with new optree */
11094         op_sibling_splice(o, NULL, 1, NULL);
11095         /* OPf_SPECIAL is used to trigger split " " behavior */
11096         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, NULL, 0, 0);
11097         op_sibling_splice(o, NULL, 0, kid);
11098     }
11099     CHANGE_TYPE(kid, OP_PUSHRE);
11100     scalar(kid);
11101     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
11102       Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
11103                      "Use of /g modifier is meaningless in split");
11104     }
11105
11106     if (!OpHAS_SIBLING(kid))
11107         op_append_elem(OP_SPLIT, o, newDEFSVOP());
11108
11109     kid = OpSIBLING(kid);
11110     assert(kid);
11111     scalar(kid);
11112
11113     if (!OpHAS_SIBLING(kid))
11114     {
11115         op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
11116         o->op_private |= OPpSPLIT_IMPLIM;
11117     }
11118     assert(OpHAS_SIBLING(kid));
11119
11120     kid = OpSIBLING(kid);
11121     scalar(kid);
11122
11123     if (OpHAS_SIBLING(kid))
11124         return too_many_arguments_pv(o,OP_DESC(o), 0);
11125
11126     return o;
11127 }
11128
11129 OP *
11130 Perl_ck_stringify(pTHX_ OP *o)
11131 {
11132     OP * const kid = OpSIBLING(cUNOPo->op_first);
11133     PERL_ARGS_ASSERT_CK_STRINGIFY;
11134     if (kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
11135      || kid->op_type == OP_LC   || kid->op_type == OP_LCFIRST
11136      || kid->op_type == OP_UC   || kid->op_type == OP_UCFIRST)
11137     {
11138         assert(!OpHAS_SIBLING(kid));
11139         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
11140         op_free(o);
11141         return kid;
11142     }
11143     return ck_fun(o);
11144 }
11145
11146 OP *
11147 Perl_ck_join(pTHX_ OP *o)
11148 {
11149     OP * const kid = OpSIBLING(cLISTOPo->op_first);
11150
11151     PERL_ARGS_ASSERT_CK_JOIN;
11152
11153     if (kid && kid->op_type == OP_MATCH) {
11154         if (ckWARN(WARN_SYNTAX)) {
11155             const REGEXP *re = PM_GETRE(kPMOP);
11156             const SV *msg = re
11157                     ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
11158                                             SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
11159                     : newSVpvs_flags( "STRING", SVs_TEMP );
11160             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11161                         "/%"SVf"/ should probably be written as \"%"SVf"\"",
11162                         SVfARG(msg), SVfARG(msg));
11163         }
11164     }
11165     if (kid
11166      && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
11167         || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
11168         || (  kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
11169            && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
11170     {
11171         const OP * const bairn = OpSIBLING(kid); /* the list */
11172         if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
11173          && OP_GIMME(bairn,0) == G_SCALAR)
11174         {
11175             OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
11176                                      op_sibling_splice(o, kid, 1, NULL));
11177             op_free(o);
11178             return ret;
11179         }
11180     }
11181
11182     return ck_fun(o);
11183 }
11184
11185 /*
11186 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
11187
11188 Examines an op, which is expected to identify a subroutine at runtime,
11189 and attempts to determine at compile time which subroutine it identifies.
11190 This is normally used during Perl compilation to determine whether
11191 a prototype can be applied to a function call.  I<cvop> is the op
11192 being considered, normally an C<rv2cv> op.  A pointer to the identified
11193 subroutine is returned, if it could be determined statically, and a null
11194 pointer is returned if it was not possible to determine statically.
11195
11196 Currently, the subroutine can be identified statically if the RV that the
11197 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
11198 A C<gv> op is suitable if the GV's CV slot is populated.  A C<const> op is
11199 suitable if the constant value must be an RV pointing to a CV.  Details of
11200 this process may change in future versions of Perl.  If the C<rv2cv> op
11201 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
11202 the subroutine statically: this flag is used to suppress compile-time
11203 magic on a subroutine call, forcing it to use default runtime behaviour.
11204
11205 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
11206 of a GV reference is modified.  If a GV was examined and its CV slot was
11207 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
11208 If the op is not optimised away, and the CV slot is later populated with
11209 a subroutine having a prototype, that flag eventually triggers the warning
11210 "called too early to check prototype".
11211
11212 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
11213 of returning a pointer to the subroutine it returns a pointer to the
11214 GV giving the most appropriate name for the subroutine in this context.
11215 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
11216 (C<CvANON>) subroutine that is referenced through a GV it will be the
11217 referencing GV.  The resulting C<GV*> is cast to C<CV*> to be returned.
11218 A null pointer is returned as usual if there is no statically-determinable
11219 subroutine.
11220
11221 =cut
11222 */
11223
11224 /* shared by toke.c:yylex */
11225 CV *
11226 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
11227 {
11228     PADNAME *name = PAD_COMPNAME(off);
11229     CV *compcv = PL_compcv;
11230     while (PadnameOUTER(name)) {
11231         assert(PARENT_PAD_INDEX(name));
11232         compcv = CvOUTSIDE(PL_compcv);
11233         name = PadlistNAMESARRAY(CvPADLIST(compcv))
11234                 [off = PARENT_PAD_INDEX(name)];
11235     }
11236     assert(!PadnameIsOUR(name));
11237     if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
11238         return PadnamePROTOCV(name);
11239     }
11240     return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
11241 }
11242
11243 CV *
11244 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
11245 {
11246     OP *rvop;
11247     CV *cv;
11248     GV *gv;
11249     PERL_ARGS_ASSERT_RV2CV_OP_CV;
11250     if (flags & ~RV2CVOPCV_FLAG_MASK)
11251         Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
11252     if (cvop->op_type != OP_RV2CV)
11253         return NULL;
11254     if (cvop->op_private & OPpENTERSUB_AMPER)
11255         return NULL;
11256     if (!(cvop->op_flags & OPf_KIDS))
11257         return NULL;
11258     rvop = cUNOPx(cvop)->op_first;
11259     switch (rvop->op_type) {
11260         case OP_GV: {
11261             gv = cGVOPx_gv(rvop);
11262             if (!isGV(gv)) {
11263                 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
11264                     cv = MUTABLE_CV(SvRV(gv));
11265                     gv = NULL;
11266                     break;
11267                 }
11268                 if (flags & RV2CVOPCV_RETURN_STUB)
11269                     return (CV *)gv;
11270                 else return NULL;
11271             }
11272             cv = GvCVu(gv);
11273             if (!cv) {
11274                 if (flags & RV2CVOPCV_MARK_EARLY)
11275                     rvop->op_private |= OPpEARLY_CV;
11276                 return NULL;
11277             }
11278         } break;
11279         case OP_CONST: {
11280             SV *rv = cSVOPx_sv(rvop);
11281             if (!SvROK(rv))
11282                 return NULL;
11283             cv = (CV*)SvRV(rv);
11284             gv = NULL;
11285         } break;
11286         case OP_PADCV: {
11287             cv = find_lexical_cv(rvop->op_targ);
11288             gv = NULL;
11289         } break;
11290         default: {
11291             return NULL;
11292         } NOT_REACHED; /* NOTREACHED */
11293     }
11294     if (SvTYPE((SV*)cv) != SVt_PVCV)
11295         return NULL;
11296     if (flags & (RV2CVOPCV_RETURN_NAME_GV|RV2CVOPCV_MAYBE_NAME_GV)) {
11297         if ((!CvANON(cv) || !gv) && !CvLEXICAL(cv)
11298          && ((flags & RV2CVOPCV_RETURN_NAME_GV) || !CvNAMED(cv)))
11299             gv = CvGV(cv);
11300         return (CV*)gv;
11301     } else {
11302         return cv;
11303     }
11304 }
11305
11306 /*
11307 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
11308
11309 Performs the default fixup of the arguments part of an C<entersub>
11310 op tree.  This consists of applying list context to each of the
11311 argument ops.  This is the standard treatment used on a call marked
11312 with C<&>, or a method call, or a call through a subroutine reference,
11313 or any other call where the callee can't be identified at compile time,
11314 or a call where the callee has no prototype.
11315
11316 =cut
11317 */
11318
11319 OP *
11320 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
11321 {
11322     OP *aop;
11323     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
11324     aop = cUNOPx(entersubop)->op_first;
11325     if (!OpHAS_SIBLING(aop))
11326         aop = cUNOPx(aop)->op_first;
11327     for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
11328         list(aop);
11329         op_lvalue(aop, OP_ENTERSUB);
11330     }
11331     return entersubop;
11332 }
11333
11334 /*
11335 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
11336
11337 Performs the fixup of the arguments part of an C<entersub> op tree
11338 based on a subroutine prototype.  This makes various modifications to
11339 the argument ops, from applying context up to inserting C<refgen> ops,
11340 and checking the number and syntactic types of arguments, as directed by
11341 the prototype.  This is the standard treatment used on a subroutine call,
11342 not marked with C<&>, where the callee can be identified at compile time
11343 and has a prototype.
11344
11345 I<protosv> supplies the subroutine prototype to be applied to the call.
11346 It may be a normal defined scalar, of which the string value will be used.
11347 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11348 that has been cast to C<SV*>) which has a prototype.  The prototype
11349 supplied, in whichever form, does not need to match the actual callee
11350 referenced by the op tree.
11351
11352 If the argument ops disagree with the prototype, for example by having
11353 an unacceptable number of arguments, a valid op tree is returned anyway.
11354 The error is reflected in the parser state, normally resulting in a single
11355 exception at the top level of parsing which covers all the compilation
11356 errors that occurred.  In the error message, the callee is referred to
11357 by the name defined by the I<namegv> parameter.
11358
11359 =cut
11360 */
11361
11362 OP *
11363 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11364 {
11365     STRLEN proto_len;
11366     const char *proto, *proto_end;
11367     OP *aop, *prev, *cvop, *parent;
11368     int optional = 0;
11369     I32 arg = 0;
11370     I32 contextclass = 0;
11371     const char *e = NULL;
11372     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
11373     if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
11374         Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
11375                    "flags=%lx", (unsigned long) SvFLAGS(protosv));
11376     if (SvTYPE(protosv) == SVt_PVCV)
11377          proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
11378     else proto = SvPV(protosv, proto_len);
11379     proto = S_strip_spaces(aTHX_ proto, &proto_len);
11380     proto_end = proto + proto_len;
11381     parent = entersubop;
11382     aop = cUNOPx(entersubop)->op_first;
11383     if (!OpHAS_SIBLING(aop)) {
11384         parent = aop;
11385         aop = cUNOPx(aop)->op_first;
11386     }
11387     prev = aop;
11388     aop = OpSIBLING(aop);
11389     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11390     while (aop != cvop) {
11391         OP* o3 = aop;
11392
11393         if (proto >= proto_end)
11394         {
11395             SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11396             yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf,
11397                                         SVfARG(namesv)), SvUTF8(namesv));
11398             return entersubop;
11399         }
11400
11401         switch (*proto) {
11402             case ';':
11403                 optional = 1;
11404                 proto++;
11405                 continue;
11406             case '_':
11407                 /* _ must be at the end */
11408                 if (proto[1] && !strchr(";@%", proto[1]))
11409                     goto oops;
11410                 /* FALLTHROUGH */
11411             case '$':
11412                 proto++;
11413                 arg++;
11414                 scalar(aop);
11415                 break;
11416             case '%':
11417             case '@':
11418                 list(aop);
11419                 arg++;
11420                 break;
11421             case '&':
11422                 proto++;
11423                 arg++;
11424                 if (o3->op_type != OP_SREFGEN
11425                  || (  cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
11426                         != OP_ANONCODE
11427                     && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
11428                         != OP_RV2CV))
11429                     bad_type_gv(arg, namegv, o3,
11430                             arg == 1 ? "block or sub {}" : "sub {}");
11431                 break;
11432             case '*':
11433                 /* '*' allows any scalar type, including bareword */
11434                 proto++;
11435                 arg++;
11436                 if (o3->op_type == OP_RV2GV)
11437                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
11438                 else if (o3->op_type == OP_CONST)
11439                     o3->op_private &= ~OPpCONST_STRICT;
11440                 scalar(aop);
11441                 break;
11442             case '+':
11443                 proto++;
11444                 arg++;
11445                 if (o3->op_type == OP_RV2AV ||
11446                     o3->op_type == OP_PADAV ||
11447                     o3->op_type == OP_RV2HV ||
11448                     o3->op_type == OP_PADHV
11449                 ) {
11450                     goto wrapref;
11451                 }
11452                 scalar(aop);
11453                 break;
11454             case '[': case ']':
11455                 goto oops;
11456
11457             case '\\':
11458                 proto++;
11459                 arg++;
11460             again:
11461                 switch (*proto++) {
11462                     case '[':
11463                         if (contextclass++ == 0) {
11464                             e = strchr(proto, ']');
11465                             if (!e || e == proto)
11466                                 goto oops;
11467                         }
11468                         else
11469                             goto oops;
11470                         goto again;
11471
11472                     case ']':
11473                         if (contextclass) {
11474                             const char *p = proto;
11475                             const char *const end = proto;
11476                             contextclass = 0;
11477                             while (*--p != '[')
11478                                 /* \[$] accepts any scalar lvalue */
11479                                 if (*p == '$'
11480                                  && Perl_op_lvalue_flags(aTHX_
11481                                      scalar(o3),
11482                                      OP_READ, /* not entersub */
11483                                      OP_LVALUE_NO_CROAK
11484                                     )) goto wrapref;
11485                             bad_type_gv(arg, namegv, o3,
11486                                     Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
11487                         } else
11488                             goto oops;
11489                         break;
11490                     case '*':
11491                         if (o3->op_type == OP_RV2GV)
11492                             goto wrapref;
11493                         if (!contextclass)
11494                             bad_type_gv(arg, namegv, o3, "symbol");
11495                         break;
11496                     case '&':
11497                         if (o3->op_type == OP_ENTERSUB
11498                          && !(o3->op_flags & OPf_STACKED))
11499                             goto wrapref;
11500                         if (!contextclass)
11501                             bad_type_gv(arg, namegv, o3, "subroutine");
11502                         break;
11503                     case '$':
11504                         if (o3->op_type == OP_RV2SV ||
11505                                 o3->op_type == OP_PADSV ||
11506                                 o3->op_type == OP_HELEM ||
11507                                 o3->op_type == OP_AELEM)
11508                             goto wrapref;
11509                         if (!contextclass) {
11510                             /* \$ accepts any scalar lvalue */
11511                             if (Perl_op_lvalue_flags(aTHX_
11512                                     scalar(o3),
11513                                     OP_READ,  /* not entersub */
11514                                     OP_LVALUE_NO_CROAK
11515                                )) goto wrapref;
11516                             bad_type_gv(arg, namegv, o3, "scalar");
11517                         }
11518                         break;
11519                     case '@':
11520                         if (o3->op_type == OP_RV2AV ||
11521                                 o3->op_type == OP_PADAV)
11522                         {
11523                             o3->op_flags &=~ OPf_PARENS;
11524                             goto wrapref;
11525                         }
11526                         if (!contextclass)
11527                             bad_type_gv(arg, namegv, o3, "array");
11528                         break;
11529                     case '%':
11530                         if (o3->op_type == OP_RV2HV ||
11531                                 o3->op_type == OP_PADHV)
11532                         {
11533                             o3->op_flags &=~ OPf_PARENS;
11534                             goto wrapref;
11535                         }
11536                         if (!contextclass)
11537                             bad_type_gv(arg, namegv, o3, "hash");
11538                         break;
11539                     wrapref:
11540                             aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
11541                                                 OP_REFGEN, 0);
11542                         if (contextclass && e) {
11543                             proto = e + 1;
11544                             contextclass = 0;
11545                         }
11546                         break;
11547                     default: goto oops;
11548                 }
11549                 if (contextclass)
11550                     goto again;
11551                 break;
11552             case ' ':
11553                 proto++;
11554                 continue;
11555             default:
11556             oops: {
11557                 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
11558                                   SVfARG(cv_name((CV *)namegv, NULL, 0)),
11559                                   SVfARG(protosv));
11560             }
11561         }
11562
11563         op_lvalue(aop, OP_ENTERSUB);
11564         prev = aop;
11565         aop = OpSIBLING(aop);
11566     }
11567     if (aop == cvop && *proto == '_') {
11568         /* generate an access to $_ */
11569         op_sibling_splice(parent, prev, 0, newDEFSVOP());
11570     }
11571     if (!optional && proto_end > proto &&
11572         (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
11573     {
11574         SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11575         yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf,
11576                                     SVfARG(namesv)), SvUTF8(namesv));
11577     }
11578     return entersubop;
11579 }
11580
11581 /*
11582 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
11583
11584 Performs the fixup of the arguments part of an C<entersub> op tree either
11585 based on a subroutine prototype or using default list-context processing.
11586 This is the standard treatment used on a subroutine call, not marked
11587 with C<&>, where the callee can be identified at compile time.
11588
11589 I<protosv> supplies the subroutine prototype to be applied to the call,
11590 or indicates that there is no prototype.  It may be a normal scalar,
11591 in which case if it is defined then the string value will be used
11592 as a prototype, and if it is undefined then there is no prototype.
11593 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11594 that has been cast to C<SV*>), of which the prototype will be used if it
11595 has one.  The prototype (or lack thereof) supplied, in whichever form,
11596 does not need to match the actual callee referenced by the op tree.
11597
11598 If the argument ops disagree with the prototype, for example by having
11599 an unacceptable number of arguments, a valid op tree is returned anyway.
11600 The error is reflected in the parser state, normally resulting in a single
11601 exception at the top level of parsing which covers all the compilation
11602 errors that occurred.  In the error message, the callee is referred to
11603 by the name defined by the I<namegv> parameter.
11604
11605 =cut
11606 */
11607
11608 OP *
11609 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
11610         GV *namegv, SV *protosv)
11611 {
11612     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
11613     if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
11614         return ck_entersub_args_proto(entersubop, namegv, protosv);
11615     else
11616         return ck_entersub_args_list(entersubop);
11617 }
11618
11619 OP *
11620 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11621 {
11622     int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
11623     OP *aop = cUNOPx(entersubop)->op_first;
11624
11625     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
11626
11627     if (!opnum) {
11628         OP *cvop;
11629         if (!OpHAS_SIBLING(aop))
11630             aop = cUNOPx(aop)->op_first;
11631         aop = OpSIBLING(aop);
11632         for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11633         if (aop != cvop)
11634             (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
11635
11636         op_free(entersubop);
11637         switch(GvNAME(namegv)[2]) {
11638         case 'F': return newSVOP(OP_CONST, 0,
11639                                         newSVpv(CopFILE(PL_curcop),0));
11640         case 'L': return newSVOP(
11641                            OP_CONST, 0,
11642                            Perl_newSVpvf(aTHX_
11643                              "%"IVdf, (IV)CopLINE(PL_curcop)
11644                            )
11645                          );
11646         case 'P': return newSVOP(OP_CONST, 0,
11647                                    (PL_curstash
11648                                      ? newSVhek(HvNAME_HEK(PL_curstash))
11649                                      : &PL_sv_undef
11650                                    )
11651                                 );
11652         }
11653         NOT_REACHED;
11654     }
11655     else {
11656         OP *prev, *cvop, *first, *parent;
11657         U32 flags = 0;
11658
11659         parent = entersubop;
11660         if (!OpHAS_SIBLING(aop)) {
11661             parent = aop;
11662             aop = cUNOPx(aop)->op_first;
11663         }
11664
11665         first = prev = aop;
11666         aop = OpSIBLING(aop);
11667         /* find last sibling */
11668         for (cvop = aop;
11669              OpHAS_SIBLING(cvop);
11670              prev = cvop, cvop = OpSIBLING(cvop))
11671             ;
11672         if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
11673             /* Usually, OPf_SPECIAL on an op with no args means that it had
11674              * parens, but these have their own meaning for that flag: */
11675             && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
11676             && opnum != OP_DELETE && opnum != OP_EXISTS)
11677                 flags |= OPf_SPECIAL;
11678         /* excise cvop from end of sibling chain */
11679         op_sibling_splice(parent, prev, 1, NULL);
11680         op_free(cvop);
11681         if (aop == cvop) aop = NULL;
11682
11683         /* detach remaining siblings from the first sibling, then
11684          * dispose of original optree */
11685
11686         if (aop)
11687             op_sibling_splice(parent, first, -1, NULL);
11688         op_free(entersubop);
11689
11690         if (opnum == OP_ENTEREVAL
11691          && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
11692             flags |= OPpEVAL_BYTES <<8;
11693
11694         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
11695         case OA_UNOP:
11696         case OA_BASEOP_OR_UNOP:
11697         case OA_FILESTATOP:
11698             return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
11699         case OA_BASEOP:
11700             if (aop) {
11701                     (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
11702                 op_free(aop);
11703             }
11704             return opnum == OP_RUNCV
11705                 ? newPVOP(OP_RUNCV,0,NULL)
11706                 : newOP(opnum,0);
11707         default:
11708             return op_convert_list(opnum,0,aop);
11709         }
11710     }
11711     NOT_REACHED;
11712     return entersubop;
11713 }
11714
11715 /*
11716 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
11717
11718 Retrieves the function that will be used to fix up a call to I<cv>.
11719 Specifically, the function is applied to an C<entersub> op tree for a
11720 subroutine call, not marked with C<&>, where the callee can be identified
11721 at compile time as I<cv>.
11722
11723 The C-level function pointer is returned in I<*ckfun_p>, and an SV
11724 argument for it is returned in I<*ckobj_p>.  The function is intended
11725 to be called in this manner:
11726
11727     entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
11728
11729 In this call, I<entersubop> is a pointer to the C<entersub> op,
11730 which may be replaced by the check function, and I<namegv> is a GV
11731 supplying the name that should be used by the check function to refer
11732 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11733 It is permitted to apply the check function in non-standard situations,
11734 such as to a call to a different subroutine or to a method call.
11735
11736 By default, the function is
11737 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
11738 and the SV parameter is I<cv> itself.  This implements standard
11739 prototype processing.  It can be changed, for a particular subroutine,
11740 by L</cv_set_call_checker>.
11741
11742 =cut
11743 */
11744
11745 static void
11746 S_cv_get_call_checker(CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p,
11747                       U8 *flagsp)
11748 {
11749     MAGIC *callmg;
11750     callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
11751     if (callmg) {
11752         *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
11753         *ckobj_p = callmg->mg_obj;
11754         if (flagsp) *flagsp = callmg->mg_flags;
11755     } else {
11756         *ckfun_p = Perl_ck_entersub_args_proto_or_list;
11757         *ckobj_p = (SV*)cv;
11758         if (flagsp) *flagsp = 0;
11759     }
11760 }
11761
11762 void
11763 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
11764 {
11765     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
11766     PERL_UNUSED_CONTEXT;
11767     S_cv_get_call_checker(cv, ckfun_p, ckobj_p, NULL);
11768 }
11769
11770 /*
11771 =for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 flags
11772
11773 Sets the function that will be used to fix up a call to I<cv>.
11774 Specifically, the function is applied to an C<entersub> op tree for a
11775 subroutine call, not marked with C<&>, where the callee can be identified
11776 at compile time as I<cv>.
11777
11778 The C-level function pointer is supplied in I<ckfun>, and an SV argument
11779 for it is supplied in I<ckobj>.  The function should be defined like this:
11780
11781     STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
11782
11783 It is intended to be called in this manner:
11784
11785     entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
11786
11787 In this call, I<entersubop> is a pointer to the C<entersub> op,
11788 which may be replaced by the check function, and I<namegv> supplies
11789 the name that should be used by the check function to refer
11790 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11791 It is permitted to apply the check function in non-standard situations,
11792 such as to a call to a different subroutine or to a method call.
11793
11794 I<namegv> may not actually be a GV.  For efficiency, perl may pass a
11795 CV or other SV instead.  Whatever is passed can be used as the first
11796 argument to L</cv_name>.  You can force perl to pass a GV by including
11797 C<CALL_CHECKER_REQUIRE_GV> in the I<flags>.
11798
11799 The current setting for a particular CV can be retrieved by
11800 L</cv_get_call_checker>.
11801
11802 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
11803
11804 The original form of L</cv_set_call_checker_flags>, which passes it the
11805 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.
11806
11807 =cut
11808 */
11809
11810 void
11811 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
11812 {
11813     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
11814     cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
11815 }
11816
11817 void
11818 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
11819                                      SV *ckobj, U32 flags)
11820 {
11821     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
11822     if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
11823         if (SvMAGICAL((SV*)cv))
11824             mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
11825     } else {
11826         MAGIC *callmg;
11827         sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
11828         callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
11829         assert(callmg);
11830         if (callmg->mg_flags & MGf_REFCOUNTED) {
11831             SvREFCNT_dec(callmg->mg_obj);
11832             callmg->mg_flags &= ~MGf_REFCOUNTED;
11833         }
11834         callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
11835         callmg->mg_obj = ckobj;
11836         if (ckobj != (SV*)cv) {
11837             SvREFCNT_inc_simple_void_NN(ckobj);
11838             callmg->mg_flags |= MGf_REFCOUNTED;
11839         }
11840         callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
11841                          | (U8)(flags & MGf_REQUIRE_GV) | MGf_COPY;
11842     }
11843 }
11844
11845 static void
11846 S_entersub_alloc_targ(pTHX_ OP * const o)
11847 {
11848     o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
11849     o->op_private |= OPpENTERSUB_HASTARG;
11850 }
11851
11852 OP *
11853 Perl_ck_subr(pTHX_ OP *o)
11854 {
11855     OP *aop, *cvop;
11856     CV *cv;
11857     GV *namegv;
11858     SV **const_class = NULL;
11859
11860     PERL_ARGS_ASSERT_CK_SUBR;
11861
11862     aop = cUNOPx(o)->op_first;
11863     if (!OpHAS_SIBLING(aop))
11864         aop = cUNOPx(aop)->op_first;
11865     aop = OpSIBLING(aop);
11866     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11867     cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
11868     namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
11869
11870     o->op_private &= ~1;
11871     o->op_private |= (PL_hints & HINT_STRICT_REFS);
11872     if (PERLDB_SUB && PL_curstash != PL_debstash)
11873         o->op_private |= OPpENTERSUB_DB;
11874     switch (cvop->op_type) {
11875         case OP_RV2CV:
11876             o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
11877             op_null(cvop);
11878             break;
11879         case OP_METHOD:
11880         case OP_METHOD_NAMED:
11881         case OP_METHOD_SUPER:
11882         case OP_METHOD_REDIR:
11883         case OP_METHOD_REDIR_SUPER:
11884             if (aop->op_type == OP_CONST) {
11885                 aop->op_private &= ~OPpCONST_STRICT;
11886                 const_class = &cSVOPx(aop)->op_sv;
11887             }
11888             else if (aop->op_type == OP_LIST) {
11889                 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
11890                 if (sib && sib->op_type == OP_CONST) {
11891                     sib->op_private &= ~OPpCONST_STRICT;
11892                     const_class = &cSVOPx(sib)->op_sv;
11893                 }
11894             }
11895             /* make class name a shared cow string to speedup method calls */
11896             /* constant string might be replaced with object, f.e. bigint */
11897             if (const_class && !SvROK(*const_class)) {
11898                 STRLEN len;
11899                 const char* str = SvPV(*const_class, len);
11900                 if (len) {
11901                     SV* const shared = newSVpvn_share(
11902                         str, SvUTF8(*const_class)
11903                                     ? -(SSize_t)len : (SSize_t)len,
11904                         0
11905                     );
11906                     SvREFCNT_dec(*const_class);
11907                     *const_class = shared;
11908                 }
11909             }
11910             break;
11911     }
11912
11913     if (!cv) {
11914         S_entersub_alloc_targ(aTHX_ o);
11915         return ck_entersub_args_list(o);
11916     } else {
11917         Perl_call_checker ckfun;
11918         SV *ckobj;
11919         U8 flags;
11920         S_cv_get_call_checker(cv, &ckfun, &ckobj, &flags);
11921         if (CvISXSUB(cv) || !CvROOT(cv))
11922             S_entersub_alloc_targ(aTHX_ o);
11923         if (!namegv) {
11924             /* The original call checker API guarantees that a GV will be
11925                be provided with the right name.  So, if the old API was
11926                used (or the REQUIRE_GV flag was passed), we have to reify
11927                the CV’s GV, unless this is an anonymous sub.  This is not
11928                ideal for lexical subs, as its stringification will include
11929                the package.  But it is the best we can do.  */
11930             if (flags & MGf_REQUIRE_GV) {
11931                 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
11932                     namegv = CvGV(cv);
11933             }
11934             else namegv = MUTABLE_GV(cv);
11935             /* After a syntax error in a lexical sub, the cv that
11936                rv2cv_op_cv returns may be a nameless stub. */
11937             if (!namegv) return ck_entersub_args_list(o);
11938
11939         }
11940         return ckfun(aTHX_ o, namegv, ckobj);
11941     }
11942 }
11943
11944 OP *
11945 Perl_ck_svconst(pTHX_ OP *o)
11946 {
11947     SV * const sv = cSVOPo->op_sv;
11948     PERL_ARGS_ASSERT_CK_SVCONST;
11949     PERL_UNUSED_CONTEXT;
11950 #ifdef PERL_OLD_COPY_ON_WRITE
11951     if (SvIsCOW(sv)) sv_force_normal(sv);
11952 #elif defined(PERL_NEW_COPY_ON_WRITE)
11953     /* Since the read-only flag may be used to protect a string buffer, we
11954        cannot do copy-on-write with existing read-only scalars that are not
11955        already copy-on-write scalars.  To allow $_ = "hello" to do COW with
11956        that constant, mark the constant as COWable here, if it is not
11957        already read-only. */
11958     if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
11959         SvIsCOW_on(sv);
11960         CowREFCNT(sv) = 0;
11961 # ifdef PERL_DEBUG_READONLY_COW
11962         sv_buf_to_ro(sv);
11963 # endif
11964     }
11965 #endif
11966     SvREADONLY_on(sv);
11967     return o;
11968 }
11969
11970 OP *
11971 Perl_ck_trunc(pTHX_ OP *o)
11972 {
11973     PERL_ARGS_ASSERT_CK_TRUNC;
11974
11975     if (o->op_flags & OPf_KIDS) {
11976         SVOP *kid = (SVOP*)cUNOPo->op_first;
11977
11978         if (kid->op_type == OP_NULL)
11979             kid = (SVOP*)OpSIBLING(kid);
11980         if (kid && kid->op_type == OP_CONST &&
11981             (kid->op_private & OPpCONST_BARE) &&
11982             !kid->op_folded)
11983         {
11984             o->op_flags |= OPf_SPECIAL;
11985             kid->op_private &= ~OPpCONST_STRICT;
11986         }
11987     }
11988     return ck_fun(o);
11989 }
11990
11991 OP *
11992 Perl_ck_substr(pTHX_ OP *o)
11993 {
11994     PERL_ARGS_ASSERT_CK_SUBSTR;
11995
11996     o = ck_fun(o);
11997     if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
11998         OP *kid = cLISTOPo->op_first;
11999
12000         if (kid->op_type == OP_NULL)
12001             kid = OpSIBLING(kid);
12002         if (kid)
12003             kid->op_flags |= OPf_MOD;
12004
12005     }
12006     return o;
12007 }
12008
12009 OP *
12010 Perl_ck_tell(pTHX_ OP *o)
12011 {
12012     PERL_ARGS_ASSERT_CK_TELL;
12013     o = ck_fun(o);
12014     if (o->op_flags & OPf_KIDS) {
12015      OP *kid = cLISTOPo->op_first;
12016      if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
12017      if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
12018     }
12019     return o;
12020 }
12021
12022 OP *
12023 Perl_ck_each(pTHX_ OP *o)
12024 {
12025     dVAR;
12026     OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
12027     const unsigned orig_type  = o->op_type;
12028     const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
12029                               : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
12030     const unsigned ref_type   = orig_type == OP_EACH ? OP_REACH
12031                               : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
12032
12033     PERL_ARGS_ASSERT_CK_EACH;
12034
12035     if (kid) {
12036         switch (kid->op_type) {
12037             case OP_PADHV:
12038             case OP_RV2HV:
12039                 break;
12040             case OP_PADAV:
12041             case OP_RV2AV:
12042                 CHANGE_TYPE(o, array_type);
12043                 break;
12044             case OP_CONST:
12045                 if (kid->op_private == OPpCONST_BARE
12046                  || !SvROK(cSVOPx_sv(kid))
12047                  || (  SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
12048                     && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV  )
12049                    )
12050                     /* we let ck_fun handle it */
12051                     break;
12052             default:
12053                 CHANGE_TYPE(o, ref_type);
12054                 scalar(kid);
12055         }
12056     }
12057     /* if treating as a reference, defer additional checks to runtime */
12058     if (o->op_type == ref_type) {
12059         /* diag_listed_as: keys on reference is experimental */
12060         Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__AUTODEREF),
12061                               "%s is experimental", PL_op_desc[ref_type]);
12062         return o;
12063     }
12064     return ck_fun(o);
12065 }
12066
12067 OP *
12068 Perl_ck_length(pTHX_ OP *o)
12069 {
12070     PERL_ARGS_ASSERT_CK_LENGTH;
12071
12072     o = ck_fun(o);
12073
12074     if (ckWARN(WARN_SYNTAX)) {
12075         const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
12076
12077         if (kid) {
12078             SV *name = NULL;
12079             const bool hash = kid->op_type == OP_PADHV
12080                            || kid->op_type == OP_RV2HV;
12081             switch (kid->op_type) {
12082                 case OP_PADHV:
12083                 case OP_PADAV:
12084                 case OP_RV2HV:
12085                 case OP_RV2AV:
12086                     name = S_op_varname(aTHX_ kid);
12087                     break;
12088                 default:
12089                     return o;
12090             }
12091             if (name)
12092                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12093                     "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
12094                     ")\"?)",
12095                     SVfARG(name), hash ? "keys " : "", SVfARG(name)
12096                 );
12097             else if (hash)
12098      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
12099                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12100                     "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
12101             else
12102      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
12103                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12104                     "length() used on @array (did you mean \"scalar(@array)\"?)");
12105         }
12106     }
12107
12108     return o;
12109 }
12110
12111 /* Check for in place reverse and sort assignments like "@a = reverse @a"
12112    and modify the optree to make them work inplace */
12113
12114 STATIC void
12115 S_inplace_aassign(pTHX_ OP *o) {
12116
12117     OP *modop, *modop_pushmark;
12118     OP *oright;
12119     OP *oleft, *oleft_pushmark;
12120
12121     PERL_ARGS_ASSERT_INPLACE_AASSIGN;
12122
12123     assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
12124
12125     assert(cUNOPo->op_first->op_type == OP_NULL);
12126     modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
12127     assert(modop_pushmark->op_type == OP_PUSHMARK);
12128     modop = OpSIBLING(modop_pushmark);
12129
12130     if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
12131         return;
12132
12133     /* no other operation except sort/reverse */
12134     if (OpHAS_SIBLING(modop))
12135         return;
12136
12137     assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
12138     if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
12139
12140     if (modop->op_flags & OPf_STACKED) {
12141         /* skip sort subroutine/block */
12142         assert(oright->op_type == OP_NULL);
12143         oright = OpSIBLING(oright);
12144     }
12145
12146     assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
12147     oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
12148     assert(oleft_pushmark->op_type == OP_PUSHMARK);
12149     oleft = OpSIBLING(oleft_pushmark);
12150
12151     /* Check the lhs is an array */
12152     if (!oleft ||
12153         (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
12154         || OpHAS_SIBLING(oleft)
12155         || (oleft->op_private & OPpLVAL_INTRO)
12156     )
12157         return;
12158
12159     /* Only one thing on the rhs */
12160     if (OpHAS_SIBLING(oright))
12161         return;
12162
12163     /* check the array is the same on both sides */
12164     if (oleft->op_type == OP_RV2AV) {
12165         if (oright->op_type != OP_RV2AV
12166             || !cUNOPx(oright)->op_first
12167             || cUNOPx(oright)->op_first->op_type != OP_GV
12168             || cUNOPx(oleft )->op_first->op_type != OP_GV
12169             || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
12170                cGVOPx_gv(cUNOPx(oright)->op_first)
12171         )
12172             return;
12173     }
12174     else if (oright->op_type != OP_PADAV
12175         || oright->op_targ != oleft->op_targ
12176     )
12177         return;
12178
12179     /* This actually is an inplace assignment */
12180
12181     modop->op_private |= OPpSORT_INPLACE;
12182
12183     /* transfer MODishness etc from LHS arg to RHS arg */
12184     oright->op_flags = oleft->op_flags;
12185
12186     /* remove the aassign op and the lhs */
12187     op_null(o);
12188     op_null(oleft_pushmark);
12189     if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
12190         op_null(cUNOPx(oleft)->op_first);
12191     op_null(oleft);
12192 }
12193
12194
12195
12196 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
12197  * that potentially represent a series of one or more aggregate derefs
12198  * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
12199  * the whole chain to a single OP_MULTIDEREF op (maybe with a few
12200  * additional ops left in too).
12201  *
12202  * The caller will have already verified that the first few ops in the
12203  * chain following 'start' indicate a multideref candidate, and will have
12204  * set 'orig_o' to the point further on in the chain where the first index
12205  * expression (if any) begins.  'orig_action' specifies what type of
12206  * beginning has already been determined by the ops between start..orig_o
12207  * (e.g.  $lex_ary[], $pkg_ary->{}, expr->[], etc).
12208  *
12209  * 'hints' contains any hints flags that need adding (currently just
12210  * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
12211  */
12212
12213 void
12214 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
12215 {
12216     dVAR;
12217     int pass;
12218     UNOP_AUX_item *arg_buf = NULL;
12219     bool reset_start_targ  = FALSE; /* start->op_targ needs zeroing */
12220     int index_skip         = -1;    /* don't output index arg on this action */
12221
12222     /* similar to regex compiling, do two passes; the first pass
12223      * determines whether the op chain is convertible and calculates the
12224      * buffer size; the second pass populates the buffer and makes any
12225      * changes necessary to ops (such as moving consts to the pad on
12226      * threaded builds)
12227      */
12228     for (pass = 0; pass < 2; pass++) {
12229         OP *o                = orig_o;
12230         UV action            = orig_action;
12231         OP *first_elem_op    = NULL;  /* first seen aelem/helem */
12232         OP *top_op           = NULL;  /* highest [ah]elem/exists/del/rv2[ah]v */
12233         int action_count     = 0;     /* number of actions seen so far */
12234         int action_ix        = 0;     /* action_count % (actions per IV) */
12235         bool next_is_hash    = FALSE; /* is the next lookup to be a hash? */
12236         bool is_last         = FALSE; /* no more derefs to follow */
12237         bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
12238         UNOP_AUX_item *arg     = arg_buf;
12239         UNOP_AUX_item *action_ptr = arg_buf;
12240
12241         if (pass)
12242             action_ptr->uv = 0;
12243         arg++;
12244
12245         switch (action) {
12246         case MDEREF_HV_gvsv_vivify_rv2hv_helem:
12247         case MDEREF_HV_gvhv_helem:
12248             next_is_hash = TRUE;
12249             /* FALLTHROUGH */
12250         case MDEREF_AV_gvsv_vivify_rv2av_aelem:
12251         case MDEREF_AV_gvav_aelem:
12252             if (pass) {
12253 #ifdef USE_ITHREADS
12254                 arg->pad_offset = cPADOPx(start)->op_padix;
12255                 /* stop it being swiped when nulled */
12256                 cPADOPx(start)->op_padix = 0;
12257 #else
12258                 arg->sv = cSVOPx(start)->op_sv;
12259                 cSVOPx(start)->op_sv = NULL;
12260 #endif
12261             }
12262             arg++;
12263             break;
12264
12265         case MDEREF_HV_padhv_helem:
12266         case MDEREF_HV_padsv_vivify_rv2hv_helem:
12267             next_is_hash = TRUE;
12268             /* FALLTHROUGH */
12269         case MDEREF_AV_padav_aelem:
12270         case MDEREF_AV_padsv_vivify_rv2av_aelem:
12271             if (pass) {
12272                 arg->pad_offset = start->op_targ;
12273                 /* we skip setting op_targ = 0 for now, since the intact
12274                  * OP_PADXV is needed by S_check_hash_fields_and_hekify */
12275                 reset_start_targ = TRUE;
12276             }
12277             arg++;
12278             break;
12279
12280         case MDEREF_HV_pop_rv2hv_helem:
12281             next_is_hash = TRUE;
12282             /* FALLTHROUGH */
12283         case MDEREF_AV_pop_rv2av_aelem:
12284             break;
12285
12286         default:
12287             NOT_REACHED;
12288             return;
12289         }
12290
12291         while (!is_last) {
12292             /* look for another (rv2av/hv; get index;
12293              * aelem/helem/exists/delele) sequence */
12294
12295             OP *kid;
12296             bool is_deref;
12297             bool ok;
12298             UV index_type = MDEREF_INDEX_none;
12299
12300             if (action_count) {
12301                 /* if this is not the first lookup, consume the rv2av/hv  */
12302
12303                 /* for N levels of aggregate lookup, we normally expect
12304                  * that the first N-1 [ah]elem ops will be flagged as
12305                  * /DEREF (so they autovivifiy if necessary), and the last
12306                  * lookup op not to be.
12307                  * For other things (like @{$h{k1}{k2}}) extra scope or
12308                  * leave ops can appear, so abandon the effort in that
12309                  * case */
12310                 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
12311                     return;
12312
12313                 /* rv2av or rv2hv sKR/1 */
12314
12315                 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12316                                             |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12317                 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
12318                     return;
12319
12320                 /* at this point, we wouldn't expect any of these
12321                  * possible private flags:
12322                  * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
12323                  * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
12324                  */
12325                 ASSUME(!(o->op_private &
12326                     ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
12327
12328                 hints = (o->op_private & OPpHINT_STRICT_REFS);
12329
12330                 /* make sure the type of the previous /DEREF matches the
12331                  * type of the next lookup */
12332                 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
12333                 top_op = o;
12334
12335                 action = next_is_hash
12336                             ? MDEREF_HV_vivify_rv2hv_helem
12337                             : MDEREF_AV_vivify_rv2av_aelem;
12338                 o = o->op_next;
12339             }
12340
12341             /* if this is the second pass, and we're at the depth where
12342              * previously we encountered a non-simple index expression,
12343              * stop processing the index at this point */
12344             if (action_count != index_skip) {
12345
12346                 /* look for one or more simple ops that return an array
12347                  * index or hash key */
12348
12349                 switch (o->op_type) {
12350                 case OP_PADSV:
12351                     /* it may be a lexical var index */
12352                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
12353                                             |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12354                     ASSUME(!(o->op_private &
12355                             ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
12356
12357                     if (   OP_GIMME(o,0) == G_SCALAR
12358                         && !(o->op_flags & (OPf_REF|OPf_MOD))
12359                         && o->op_private == 0)
12360                     {
12361                         if (pass)
12362                             arg->pad_offset = o->op_targ;
12363                         arg++;
12364                         index_type = MDEREF_INDEX_padsv;
12365                         o = o->op_next;
12366                     }
12367                     break;
12368
12369                 case OP_CONST:
12370                     if (next_is_hash) {
12371                         /* it's a constant hash index */
12372                         if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
12373                             /* "use constant foo => FOO; $h{+foo}" for
12374                              * some weird FOO, can leave you with constants
12375                              * that aren't simple strings. It's not worth
12376                              * the extra hassle for those edge cases */
12377                             break;
12378
12379                         if (pass) {
12380                             UNOP *rop = NULL;
12381                             OP * helem_op = o->op_next;
12382
12383                             ASSUME(   helem_op->op_type == OP_HELEM
12384                                    || helem_op->op_type == OP_NULL);
12385                             if (helem_op->op_type == OP_HELEM) {
12386                                 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
12387                                 if (   helem_op->op_private & OPpLVAL_INTRO
12388                                     || rop->op_type != OP_RV2HV
12389                                 )
12390                                     rop = NULL;
12391                             }
12392                             S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo);
12393
12394 #ifdef USE_ITHREADS
12395                             /* Relocate sv to the pad for thread safety */
12396                             op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
12397                             arg->pad_offset = o->op_targ;
12398                             o->op_targ = 0;
12399 #else
12400                             arg->sv = cSVOPx_sv(o);
12401 #endif
12402                         }
12403                     }
12404                     else {
12405                         /* it's a constant array index */
12406                         IV iv;
12407                         SV *ix_sv = cSVOPo->op_sv;
12408                         if (!SvIOK(ix_sv))
12409                             break;
12410                         iv = SvIV(ix_sv);
12411
12412                         if (   action_count == 0
12413                             && iv >= -128
12414                             && iv <= 127
12415                             && (   action == MDEREF_AV_padav_aelem
12416                                 || action == MDEREF_AV_gvav_aelem)
12417                         )
12418                             maybe_aelemfast = TRUE;
12419
12420                         if (pass) {
12421                             arg->iv = iv;
12422                             SvREFCNT_dec_NN(cSVOPo->op_sv);
12423                         }
12424                     }
12425                     if (pass)
12426                         /* we've taken ownership of the SV */
12427                         cSVOPo->op_sv = NULL;
12428                     arg++;
12429                     index_type = MDEREF_INDEX_const;
12430                     o = o->op_next;
12431                     break;
12432
12433                 case OP_GV:
12434                     /* it may be a package var index */
12435
12436                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_SPECIAL)));
12437                     ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
12438                     if (  (o->op_flags &~ OPf_SPECIAL) != OPf_WANT_SCALAR
12439                         || o->op_private != 0
12440                     )
12441                         break;
12442
12443                     kid = o->op_next;
12444                     if (kid->op_type != OP_RV2SV)
12445                         break;
12446
12447                     ASSUME(!(kid->op_flags &
12448                             ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
12449                              |OPf_SPECIAL|OPf_PARENS)));
12450                     ASSUME(!(kid->op_private &
12451                                     ~(OPpARG1_MASK
12452                                      |OPpHINT_STRICT_REFS|OPpOUR_INTRO
12453                                      |OPpDEREF|OPpLVAL_INTRO)));
12454                     if(   (kid->op_flags &~ OPf_PARENS)
12455                             != (OPf_WANT_SCALAR|OPf_KIDS)
12456                        || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
12457                     )
12458                         break;
12459
12460                     if (pass) {
12461 #ifdef USE_ITHREADS
12462                         arg->pad_offset = cPADOPx(o)->op_padix;
12463                         /* stop it being swiped when nulled */
12464                         cPADOPx(o)->op_padix = 0;
12465 #else
12466                         arg->sv = cSVOPx(o)->op_sv;
12467                         cSVOPo->op_sv = NULL;
12468 #endif
12469                     }
12470                     arg++;
12471                     index_type = MDEREF_INDEX_gvsv;
12472                     o = kid->op_next;
12473                     break;
12474
12475                 } /* switch */
12476             } /* action_count != index_skip */
12477
12478             action |= index_type;
12479
12480
12481             /* at this point we have either:
12482              *   * detected what looks like a simple index expression,
12483              *     and expect the next op to be an [ah]elem, or
12484              *     an nulled  [ah]elem followed by a delete or exists;
12485              *  * found a more complex expression, so something other
12486              *    than the above follows.
12487              */
12488
12489             /* possibly an optimised away [ah]elem (where op_next is
12490              * exists or delete) */
12491             if (o->op_type == OP_NULL)
12492                 o = o->op_next;
12493
12494             /* at this point we're looking for an OP_AELEM, OP_HELEM,
12495              * OP_EXISTS or OP_DELETE */
12496
12497             /* if something like arybase (a.k.a $[ ) is in scope,
12498              * abandon optimisation attempt */
12499             if (  (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
12500                && PL_check[o->op_type] != Perl_ck_null)
12501                 return;
12502
12503             if (   o->op_type != OP_AELEM
12504                 || (o->op_private &
12505                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
12506                 )
12507                 maybe_aelemfast = FALSE;
12508
12509             /* look for aelem/helem/exists/delete. If it's not the last elem
12510              * lookup, it *must* have OPpDEREF_AV/HV, but not many other
12511              * flags; if it's the last, then it mustn't have
12512              * OPpDEREF_AV/HV, but may have lots of other flags, like
12513              * OPpLVAL_INTRO etc
12514              */
12515
12516             if (   index_type == MDEREF_INDEX_none
12517                 || (   o->op_type != OP_AELEM  && o->op_type != OP_HELEM
12518                     && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
12519             )
12520                 ok = FALSE;
12521             else {
12522                 /* we have aelem/helem/exists/delete with valid simple index */
12523
12524                 is_deref =    (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
12525                            && (   (o->op_private & OPpDEREF) == OPpDEREF_AV
12526                                || (o->op_private & OPpDEREF) == OPpDEREF_HV);
12527
12528                 if (is_deref) {
12529                     ASSUME(!(o->op_flags &
12530                                  ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
12531                     ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
12532
12533                     ok =    (o->op_flags &~ OPf_PARENS)
12534                                == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
12535                          && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
12536                 }
12537                 else if (o->op_type == OP_EXISTS) {
12538                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12539                                 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12540                     ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
12541                     ok =  !(o->op_private & ~OPpARG1_MASK);
12542                 }
12543                 else if (o->op_type == OP_DELETE) {
12544                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12545                                 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12546                     ASSUME(!(o->op_private &
12547                                     ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
12548                     /* don't handle slices or 'local delete'; the latter
12549                      * is fairly rare, and has a complex runtime */
12550                     ok =  !(o->op_private & ~OPpARG1_MASK);
12551                     if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
12552                         /* skip handling run-tome error */
12553                         ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
12554                 }
12555                 else {
12556                     ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
12557                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
12558                                             |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
12559                     ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
12560                                     |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
12561                     ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
12562                 }
12563             }
12564
12565             if (ok) {
12566                 if (!first_elem_op)
12567                     first_elem_op = o;
12568                 top_op = o;
12569                 if (is_deref) {
12570                     next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
12571                     o = o->op_next;
12572                 }
12573                 else {
12574                     is_last = TRUE;
12575                     action |= MDEREF_FLAG_last;
12576                 }
12577             }
12578             else {
12579                 /* at this point we have something that started
12580                  * promisingly enough (with rv2av or whatever), but failed
12581                  * to find a simple index followed by an
12582                  * aelem/helem/exists/delete. If this is the first action,
12583                  * give up; but if we've already seen at least one
12584                  * aelem/helem, then keep them and add a new action with
12585                  * MDEREF_INDEX_none, which causes it to do the vivify
12586                  * from the end of the previous lookup, and do the deref,
12587                  * but stop at that point. So $a[0][expr] will do one
12588                  * av_fetch, vivify and deref, then continue executing at
12589                  * expr */
12590                 if (!action_count)
12591                     return;
12592                 is_last = TRUE;
12593                 index_skip = action_count;
12594                 action |= MDEREF_FLAG_last;
12595             }
12596
12597             if (pass)
12598                 action_ptr->uv |= (action << (action_ix * MDEREF_SHIFT));
12599             action_ix++;
12600             action_count++;
12601             /* if there's no space for the next action, create a new slot
12602              * for it *before* we start adding args for that action */
12603             if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
12604                 action_ptr = arg;
12605                 if (pass)
12606                     arg->uv = 0;
12607                 arg++;
12608                 action_ix = 0;
12609             }
12610         } /* while !is_last */
12611
12612         /* success! */
12613
12614         if (pass) {
12615             OP *mderef;
12616             OP *p;
12617
12618             mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
12619             if (index_skip == -1) {
12620                 mderef->op_flags = o->op_flags
12621                         & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
12622                 if (o->op_type == OP_EXISTS)
12623                     mderef->op_private = OPpMULTIDEREF_EXISTS;
12624                 else if (o->op_type == OP_DELETE)
12625                     mderef->op_private = OPpMULTIDEREF_DELETE;
12626                 else
12627                     mderef->op_private = o->op_private
12628                         & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
12629             }
12630             /* accumulate strictness from every level (although I don't think
12631              * they can actually vary) */
12632             mderef->op_private |= hints;
12633
12634             /* integrate the new multideref op into the optree and the
12635              * op_next chain.
12636              *
12637              * In general an op like aelem or helem has two child
12638              * sub-trees: the aggregate expression (a_expr) and the
12639              * index expression (i_expr):
12640              *
12641              *     aelem
12642              *       |
12643              *     a_expr - i_expr
12644              *
12645              * The a_expr returns an AV or HV, while the i-expr returns an
12646              * index. In general a multideref replaces most or all of a
12647              * multi-level tree, e.g.
12648              *
12649              *     exists
12650              *       |
12651              *     ex-aelem
12652              *       |
12653              *     rv2av  - i_expr1
12654              *       |
12655              *     helem
12656              *       |
12657              *     rv2hv  - i_expr2
12658              *       |
12659              *     aelem
12660              *       |
12661              *     a_expr - i_expr3
12662              *
12663              * With multideref, all the i_exprs will be simple vars or
12664              * constants, except that i_expr1 may be arbitrary in the case
12665              * of MDEREF_INDEX_none.
12666              *
12667              * The bottom-most a_expr will be either:
12668              *   1) a simple var (so padXv or gv+rv2Xv);
12669              *   2) a simple scalar var dereferenced (e.g. $r->[0]):
12670              *      so a simple var with an extra rv2Xv;
12671              *   3) or an arbitrary expression.
12672              *
12673              * 'start', the first op in the execution chain, will point to
12674              *   1),2): the padXv or gv op;
12675              *   3):    the rv2Xv which forms the last op in the a_expr
12676              *          execution chain, and the top-most op in the a_expr
12677              *          subtree.
12678              *
12679              * For all cases, the 'start' node is no longer required,
12680              * but we can't free it since one or more external nodes
12681              * may point to it. E.g. consider
12682              *     $h{foo} = $a ? $b : $c
12683              * Here, both the op_next and op_other branches of the
12684              * cond_expr point to the gv[*h] of the hash expression, so
12685              * we can't free the 'start' op.
12686              *
12687              * For expr->[...], we need to save the subtree containing the
12688              * expression; for the other cases, we just need to save the
12689              * start node.
12690              * So in all cases, we null the start op and keep it around by
12691              * making it the child of the multideref op; for the expr->
12692              * case, the expr will be a subtree of the start node.
12693              *
12694              * So in the simple 1,2 case the  optree above changes to
12695              *
12696              *     ex-exists
12697              *       |
12698              *     multideref
12699              *       |
12700              *     ex-gv (or ex-padxv)
12701              *
12702              *  with the op_next chain being
12703              *
12704              *  -> ex-gv -> multideref -> op-following-ex-exists ->
12705              *
12706              *  In the 3 case, we have
12707              *
12708              *     ex-exists
12709              *       |
12710              *     multideref
12711              *       |
12712              *     ex-rv2xv
12713              *       |
12714              *    rest-of-a_expr
12715              *      subtree
12716              *
12717              *  and
12718              *
12719              *  -> rest-of-a_expr subtree ->
12720              *    ex-rv2xv -> multideref -> op-following-ex-exists ->
12721              *
12722              *
12723              * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
12724              * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
12725              * multideref attached as the child, e.g.
12726              *
12727              *     exists
12728              *       |
12729              *     ex-aelem
12730              *       |
12731              *     ex-rv2av  - i_expr1
12732              *       |
12733              *     multideref
12734              *       |
12735              *     ex-whatever
12736              *
12737              */
12738
12739             /* if we free this op, don't free the pad entry */
12740             if (reset_start_targ)
12741                 start->op_targ = 0;
12742
12743
12744             /* Cut the bit we need to save out of the tree and attach to
12745              * the multideref op, then free the rest of the tree */
12746
12747             /* find parent of node to be detached (for use by splice) */
12748             p = first_elem_op;
12749             if (   orig_action == MDEREF_AV_pop_rv2av_aelem
12750                 || orig_action == MDEREF_HV_pop_rv2hv_helem)
12751             {
12752                 /* there is an arbitrary expression preceding us, e.g.
12753                  * expr->[..]? so we need to save the 'expr' subtree */
12754                 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
12755                     p = cUNOPx(p)->op_first;
12756                 ASSUME(   start->op_type == OP_RV2AV
12757                        || start->op_type == OP_RV2HV);
12758             }
12759             else {
12760                 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
12761                  * above for exists/delete. */
12762                 while (   (p->op_flags & OPf_KIDS)
12763                        && cUNOPx(p)->op_first != start
12764                 )
12765                     p = cUNOPx(p)->op_first;
12766             }
12767             ASSUME(cUNOPx(p)->op_first == start);
12768
12769             /* detach from main tree, and re-attach under the multideref */
12770             op_sibling_splice(mderef, NULL, 0,
12771                     op_sibling_splice(p, NULL, 1, NULL));
12772             op_null(start);
12773
12774             start->op_next = mderef;
12775
12776             mderef->op_next = index_skip == -1 ? o->op_next : o;
12777
12778             /* excise and free the original tree, and replace with
12779              * the multideref op */
12780             op_free(op_sibling_splice(top_op, NULL, -1, mderef));
12781             op_null(top_op);
12782         }
12783         else {
12784             Size_t size = arg - arg_buf;
12785
12786             if (maybe_aelemfast && action_count == 1)
12787                 return;
12788
12789             arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
12790                                 sizeof(UNOP_AUX_item) * (size + 1));
12791             /* for dumping etc: store the length in a hidden first slot;
12792              * we set the op_aux pointer to the second slot */
12793             arg_buf->uv = size;
12794             arg_buf++;
12795         }
12796     } /* for (pass = ...) */
12797 }
12798
12799
12800
12801 /* mechanism for deferring recursion in rpeep() */
12802
12803 #define MAX_DEFERRED 4
12804
12805 #define DEFER(o) \
12806   STMT_START { \
12807     if (defer_ix == (MAX_DEFERRED-1)) { \
12808         OP **defer = defer_queue[defer_base]; \
12809         CALL_RPEEP(*defer); \
12810         S_prune_chain_head(defer); \
12811         defer_base = (defer_base + 1) % MAX_DEFERRED; \
12812         defer_ix--; \
12813     } \
12814     defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
12815   } STMT_END
12816
12817 #define IS_AND_OP(o)   (o->op_type == OP_AND)
12818 #define IS_OR_OP(o)    (o->op_type == OP_OR)
12819
12820
12821 /* A peephole optimizer.  We visit the ops in the order they're to execute.
12822  * See the comments at the top of this file for more details about when
12823  * peep() is called */
12824
12825 void
12826 Perl_rpeep(pTHX_ OP *o)
12827 {
12828     dVAR;
12829     OP* oldop = NULL;
12830     OP* oldoldop = NULL;
12831     OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
12832     int defer_base = 0;
12833     int defer_ix = -1;
12834     OP *fop;
12835     OP *sop;
12836
12837     if (!o || o->op_opt)
12838         return;
12839     ENTER;
12840     SAVEOP();
12841     SAVEVPTR(PL_curcop);
12842     for (;; o = o->op_next) {
12843         if (o && o->op_opt)
12844             o = NULL;
12845         if (!o) {
12846             while (defer_ix >= 0) {
12847                 OP **defer =
12848                         defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
12849                 CALL_RPEEP(*defer);
12850                 S_prune_chain_head(defer);
12851             }
12852             break;
12853         }
12854
12855       redo:
12856         /* By default, this op has now been optimised. A couple of cases below
12857            clear this again.  */
12858         o->op_opt = 1;
12859         PL_op = o;
12860
12861         /* look for a series of 1 or more aggregate derefs, e.g.
12862          *   $a[1]{foo}[$i]{$k}
12863          * and replace with a single OP_MULTIDEREF op.
12864          * Each index must be either a const, or a simple variable,
12865          *
12866          * First, look for likely combinations of starting ops,
12867          * corresponding to (global and lexical variants of)
12868          *     $a[...]   $h{...}
12869          *     $r->[...] $r->{...}
12870          *     (preceding expression)->[...]
12871          *     (preceding expression)->{...}
12872          * and if so, call maybe_multideref() to do a full inspection
12873          * of the op chain and if appropriate, replace with an
12874          * OP_MULTIDEREF
12875          */
12876         {
12877             UV action;
12878             OP *o2 = o;
12879             U8 hints = 0;
12880
12881             switch (o2->op_type) {
12882             case OP_GV:
12883                 /* $pkg[..]   :   gv[*pkg]
12884                  * $pkg->[...]:   gv[*pkg]; rv2sv sKM/DREFAV */
12885
12886                 /* Fail if there are new op flag combinations that we're
12887                  * not aware of, rather than:
12888                  *  * silently failing to optimise, or
12889                  *  * silently optimising the flag away.
12890                  * If this ASSUME starts failing, examine what new flag
12891                  * has been added to the op, and decide whether the
12892                  * optimisation should still occur with that flag, then
12893                  * update the code accordingly. This applies to all the
12894                  * other ASSUMEs in the block of code too.
12895                  */
12896                 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_SPECIAL)));
12897                 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
12898
12899                 o2 = o2->op_next;
12900
12901                 if (o2->op_type == OP_RV2AV) {
12902                     action = MDEREF_AV_gvav_aelem;
12903                     goto do_deref;
12904                 }
12905
12906                 if (o2->op_type == OP_RV2HV) {
12907                     action = MDEREF_HV_gvhv_helem;
12908                     goto do_deref;
12909                 }
12910
12911                 if (o2->op_type != OP_RV2SV)
12912                     break;
12913
12914                 /* at this point we've seen gv,rv2sv, so the only valid
12915                  * construct left is $pkg->[] or $pkg->{} */
12916
12917                 ASSUME(!(o2->op_flags & OPf_STACKED));
12918                 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
12919                             != (OPf_WANT_SCALAR|OPf_MOD))
12920                     break;
12921
12922                 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
12923                                     |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
12924                 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
12925                     break;
12926                 if (   (o2->op_private & OPpDEREF) != OPpDEREF_AV
12927                     && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
12928                     break;
12929
12930                 o2 = o2->op_next;
12931                 if (o2->op_type == OP_RV2AV) {
12932                     action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
12933                     goto do_deref;
12934                 }
12935                 if (o2->op_type == OP_RV2HV) {
12936                     action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
12937                     goto do_deref;
12938                 }
12939                 break;
12940
12941             case OP_PADSV:
12942                 /* $lex->[...]: padsv[$lex] sM/DREFAV */
12943
12944                 ASSUME(!(o2->op_flags &
12945                     ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
12946                 if ((o2->op_flags &
12947                         (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
12948                      != (OPf_WANT_SCALAR|OPf_MOD))
12949                     break;
12950
12951                 ASSUME(!(o2->op_private &
12952                                 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
12953                 /* skip if state or intro, or not a deref */
12954                 if (      o2->op_private != OPpDEREF_AV
12955                        && o2->op_private != OPpDEREF_HV)
12956                     break;
12957
12958                 o2 = o2->op_next;
12959                 if (o2->op_type == OP_RV2AV) {
12960                     action = MDEREF_AV_padsv_vivify_rv2av_aelem;
12961                     goto do_deref;
12962                 }
12963                 if (o2->op_type == OP_RV2HV) {
12964                     action = MDEREF_HV_padsv_vivify_rv2hv_helem;
12965                     goto do_deref;
12966                 }
12967                 break;
12968
12969             case OP_PADAV:
12970             case OP_PADHV:
12971                 /*    $lex[..]:  padav[@lex:1,2] sR *
12972                  * or $lex{..}:  padhv[%lex:1,2] sR */
12973                 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
12974                                             OPf_REF|OPf_SPECIAL)));
12975                 if ((o2->op_flags &
12976                         (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
12977                      != (OPf_WANT_SCALAR|OPf_REF))
12978                     break;
12979                 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
12980                     break;
12981                 /* OPf_PARENS isn't currently used in this case;
12982                  * if that changes, let us know! */
12983                 ASSUME(!(o2->op_flags & OPf_PARENS));
12984
12985                 /* at this point, we wouldn't expect any of the remaining
12986                  * possible private flags:
12987                  * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
12988                  * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
12989                  *
12990                  * OPpSLICEWARNING shouldn't affect runtime
12991                  */
12992                 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
12993
12994                 action = o2->op_type == OP_PADAV
12995                             ? MDEREF_AV_padav_aelem
12996                             : MDEREF_HV_padhv_helem;
12997                 o2 = o2->op_next;
12998                 S_maybe_multideref(aTHX_ o, o2, action, 0);
12999                 break;
13000
13001
13002             case OP_RV2AV:
13003             case OP_RV2HV:
13004                 action = o2->op_type == OP_RV2AV
13005                             ? MDEREF_AV_pop_rv2av_aelem
13006                             : MDEREF_HV_pop_rv2hv_helem;
13007                 /* FALLTHROUGH */
13008             do_deref:
13009                 /* (expr)->[...]:  rv2av sKR/1;
13010                  * (expr)->{...}:  rv2hv sKR/1; */
13011
13012                 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
13013
13014                 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
13015                                 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
13016                 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
13017                     break;
13018
13019                 /* at this point, we wouldn't expect any of these
13020                  * possible private flags:
13021                  * OPpMAYBE_LVSUB, OPpLVAL_INTRO
13022                  * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
13023                  */
13024                 ASSUME(!(o2->op_private &
13025                     ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
13026                      |OPpOUR_INTRO)));
13027                 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
13028
13029                 o2 = o2->op_next;
13030
13031                 S_maybe_multideref(aTHX_ o, o2, action, hints);
13032                 break;
13033
13034             default:
13035                 break;
13036             }
13037         }
13038
13039
13040         switch (o->op_type) {
13041         case OP_DBSTATE:
13042             PL_curcop = ((COP*)o);              /* for warnings */
13043             break;
13044         case OP_NEXTSTATE:
13045             PL_curcop = ((COP*)o);              /* for warnings */
13046
13047             /* Optimise a "return ..." at the end of a sub to just be "...".
13048              * This saves 2 ops. Before:
13049              * 1  <;> nextstate(main 1 -e:1) v ->2
13050              * 4  <@> return K ->5
13051              * 2    <0> pushmark s ->3
13052              * -    <1> ex-rv2sv sK/1 ->4
13053              * 3      <#> gvsv[*cat] s ->4
13054              *
13055              * After:
13056              * -  <@> return K ->-
13057              * -    <0> pushmark s ->2
13058              * -    <1> ex-rv2sv sK/1 ->-
13059              * 2      <$> gvsv(*cat) s ->3
13060              */
13061             {
13062                 OP *next = o->op_next;
13063                 OP *sibling = OpSIBLING(o);
13064                 if (   OP_TYPE_IS(next, OP_PUSHMARK)
13065                     && OP_TYPE_IS(sibling, OP_RETURN)
13066                     && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
13067                     && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
13068                        ||OP_TYPE_IS(sibling->op_next->op_next,
13069                                     OP_LEAVESUBLV))
13070                     && cUNOPx(sibling)->op_first == next
13071                     && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
13072                     && next->op_next
13073                 ) {
13074                     /* Look through the PUSHMARK's siblings for one that
13075                      * points to the RETURN */
13076                     OP *top = OpSIBLING(next);
13077                     while (top && top->op_next) {
13078                         if (top->op_next == sibling) {
13079                             top->op_next = sibling->op_next;
13080                             o->op_next = next->op_next;
13081                             break;
13082                         }
13083                         top = OpSIBLING(top);
13084                     }
13085                 }
13086             }
13087
13088             /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
13089              *
13090              * This latter form is then suitable for conversion into padrange
13091              * later on. Convert:
13092              *
13093              *   nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
13094              *
13095              * into:
13096              *
13097              *   nextstate1 ->     listop     -> nextstate3
13098              *                 /            \
13099              *         pushmark -> padop1 -> padop2
13100              */
13101             if (o->op_next && (
13102                     o->op_next->op_type == OP_PADSV
13103                  || o->op_next->op_type == OP_PADAV
13104                  || o->op_next->op_type == OP_PADHV
13105                 )
13106                 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
13107                 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
13108                 && o->op_next->op_next->op_next && (
13109                     o->op_next->op_next->op_next->op_type == OP_PADSV
13110                  || o->op_next->op_next->op_next->op_type == OP_PADAV
13111                  || o->op_next->op_next->op_next->op_type == OP_PADHV
13112                 )
13113                 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
13114                 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
13115                 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
13116                 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
13117             ) {
13118                 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
13119
13120                 pad1 =    o->op_next;
13121                 ns2  = pad1->op_next;
13122                 pad2 =  ns2->op_next;
13123                 ns3  = pad2->op_next;
13124
13125                 /* we assume here that the op_next chain is the same as
13126                  * the op_sibling chain */
13127                 assert(OpSIBLING(o)    == pad1);
13128                 assert(OpSIBLING(pad1) == ns2);
13129                 assert(OpSIBLING(ns2)  == pad2);
13130                 assert(OpSIBLING(pad2) == ns3);
13131
13132                 /* create new listop, with children consisting of:
13133                  * a new pushmark, pad1, pad2. */
13134                 OpSIBLING_set(pad2, NULL);
13135                 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
13136                 newop->op_flags |= OPf_PARENS;
13137                 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
13138                 newpm = cUNOPx(newop)->op_first; /* pushmark */
13139
13140                 /* Kill nextstate2 between padop1/padop2 */
13141                 op_free(ns2);
13142
13143                 o    ->op_next = newpm;
13144                 newpm->op_next = pad1;
13145                 pad1 ->op_next = pad2;
13146                 pad2 ->op_next = newop; /* listop */
13147                 newop->op_next = ns3;
13148
13149                 OpSIBLING_set(o, newop);
13150                 OpSIBLING_set(newop, ns3);
13151                 newop->op_lastsib = 0;
13152
13153                 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
13154
13155                 /* Ensure pushmark has this flag if padops do */
13156                 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
13157                     o->op_next->op_flags |= OPf_MOD;
13158                 }
13159
13160                 break;
13161             }
13162
13163             /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
13164                to carry two labels. For now, take the easier option, and skip
13165                this optimisation if the first NEXTSTATE has a label.  */
13166             if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
13167                 OP *nextop = o->op_next;
13168                 while (nextop && nextop->op_type == OP_NULL)
13169                     nextop = nextop->op_next;
13170
13171                 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
13172                     op_null(o);
13173                     if (oldop)
13174                         oldop->op_next = nextop;
13175                     /* Skip (old)oldop assignment since the current oldop's
13176                        op_next already points to the next op.  */
13177                     continue;
13178                 }
13179             }
13180             break;
13181
13182         case OP_CONCAT:
13183             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
13184                 if (o->op_next->op_private & OPpTARGET_MY) {
13185                     if (o->op_flags & OPf_STACKED) /* chained concats */
13186                         break; /* ignore_optimization */
13187                     else {
13188                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
13189                         o->op_targ = o->op_next->op_targ;
13190                         o->op_next->op_targ = 0;
13191                         o->op_private |= OPpTARGET_MY;
13192                     }
13193                 }
13194                 op_null(o->op_next);
13195             }
13196             break;
13197         case OP_STUB:
13198             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
13199                 break; /* Scalar stub must produce undef.  List stub is noop */
13200             }
13201             goto nothin;
13202         case OP_NULL:
13203             if (o->op_targ == OP_NEXTSTATE
13204                 || o->op_targ == OP_DBSTATE)
13205             {
13206                 PL_curcop = ((COP*)o);
13207             }
13208             /* XXX: We avoid setting op_seq here to prevent later calls
13209                to rpeep() from mistakenly concluding that optimisation
13210                has already occurred. This doesn't fix the real problem,
13211                though (See 20010220.007). AMS 20010719 */
13212             /* op_seq functionality is now replaced by op_opt */
13213             o->op_opt = 0;
13214             /* FALLTHROUGH */
13215         case OP_SCALAR:
13216         case OP_LINESEQ:
13217         case OP_SCOPE:
13218         nothin:
13219             if (oldop) {
13220                 oldop->op_next = o->op_next;
13221                 o->op_opt = 0;
13222                 continue;
13223             }
13224             break;
13225
13226         case OP_PUSHMARK:
13227
13228             /* Given
13229                  5 repeat/DOLIST
13230                  3   ex-list
13231                  1     pushmark
13232                  2     scalar or const
13233                  4   const[0]
13234                convert repeat into a stub with no kids.
13235              */
13236             if (o->op_next->op_type == OP_CONST
13237              || (  o->op_next->op_type == OP_PADSV
13238                 && !(o->op_next->op_private & OPpLVAL_INTRO))
13239              || (  o->op_next->op_type == OP_GV
13240                 && o->op_next->op_next->op_type == OP_RV2SV
13241                 && !(o->op_next->op_next->op_private
13242                         & (OPpLVAL_INTRO|OPpOUR_INTRO))))
13243             {
13244                 const OP *kid = o->op_next->op_next;
13245                 if (o->op_next->op_type == OP_GV)
13246                    kid = kid->op_next;
13247                 /* kid is now the ex-list.  */
13248                 if (kid->op_type == OP_NULL
13249                  && (kid = kid->op_next)->op_type == OP_CONST
13250                     /* kid is now the repeat count.  */
13251                  && kid->op_next->op_type == OP_REPEAT
13252                  && kid->op_next->op_private & OPpREPEAT_DOLIST
13253                  && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
13254                  && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0)
13255                 {
13256                     o = kid->op_next; /* repeat */
13257                     assert(oldop);
13258                     oldop->op_next = o;
13259                     op_free(cBINOPo->op_first);
13260                     op_free(cBINOPo->op_last );
13261                     o->op_flags &=~ OPf_KIDS;
13262                     /* stub is a baseop; repeat is a binop */
13263                     STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
13264                     CHANGE_TYPE(o, OP_STUB);
13265                     o->op_private = 0;
13266                     break;
13267                 }
13268             }
13269
13270             /* Convert a series of PAD ops for my vars plus support into a
13271              * single padrange op. Basically
13272              *
13273              *    pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
13274              *
13275              * becomes, depending on circumstances, one of
13276              *
13277              *    padrange  ----------------------------------> (list) -> rest
13278              *    padrange  --------------------------------------------> rest
13279              *
13280              * where all the pad indexes are sequential and of the same type
13281              * (INTRO or not).
13282              * We convert the pushmark into a padrange op, then skip
13283              * any other pad ops, and possibly some trailing ops.
13284              * Note that we don't null() the skipped ops, to make it
13285              * easier for Deparse to undo this optimisation (and none of
13286              * the skipped ops are holding any resourses). It also makes
13287              * it easier for find_uninit_var(), as it can just ignore
13288              * padrange, and examine the original pad ops.
13289              */
13290         {
13291             OP *p;
13292             OP *followop = NULL; /* the op that will follow the padrange op */
13293             U8 count = 0;
13294             U8 intro = 0;
13295             PADOFFSET base = 0; /* init only to stop compiler whining */
13296             bool gvoid = 0;     /* init only to stop compiler whining */
13297             bool defav = 0;  /* seen (...) = @_ */
13298             bool reuse = 0;  /* reuse an existing padrange op */
13299
13300             /* look for a pushmark -> gv[_] -> rv2av */
13301
13302             {
13303                 OP *rv2av, *q;
13304                 p = o->op_next;
13305                 if (   p->op_type == OP_GV
13306                     && cGVOPx_gv(p) == PL_defgv
13307                     && (rv2av = p->op_next)
13308                     && rv2av->op_type == OP_RV2AV
13309                     && !(rv2av->op_flags & OPf_REF)
13310                     && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
13311                     && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
13312                 ) {
13313                     q = rv2av->op_next;
13314                     if (q->op_type == OP_NULL)
13315                         q = q->op_next;
13316                     if (q->op_type == OP_PUSHMARK) {
13317                         defav = 1;
13318                         p = q;
13319                     }
13320                 }
13321             }
13322             if (!defav) {
13323                 p = o;
13324             }
13325
13326             /* scan for PAD ops */
13327
13328             for (p = p->op_next; p; p = p->op_next) {
13329                 if (p->op_type == OP_NULL)
13330                     continue;
13331
13332                 if ((     p->op_type != OP_PADSV
13333                        && p->op_type != OP_PADAV
13334                        && p->op_type != OP_PADHV
13335                     )
13336                       /* any private flag other than INTRO? e.g. STATE */
13337                    || (p->op_private & ~OPpLVAL_INTRO)
13338                 )
13339                     break;
13340
13341                 /* let $a[N] potentially be optimised into AELEMFAST_LEX
13342                  * instead */
13343                 if (   p->op_type == OP_PADAV
13344                     && p->op_next
13345                     && p->op_next->op_type == OP_CONST
13346                     && p->op_next->op_next
13347                     && p->op_next->op_next->op_type == OP_AELEM
13348                 )
13349                     break;
13350
13351                 /* for 1st padop, note what type it is and the range
13352                  * start; for the others, check that it's the same type
13353                  * and that the targs are contiguous */
13354                 if (count == 0) {
13355                     intro = (p->op_private & OPpLVAL_INTRO);
13356                     base = p->op_targ;
13357                     gvoid = OP_GIMME(p,0) == G_VOID;
13358                 }
13359                 else {
13360                     if ((p->op_private & OPpLVAL_INTRO) != intro)
13361                         break;
13362                     /* Note that you'd normally  expect targs to be
13363                      * contiguous in my($a,$b,$c), but that's not the case
13364                      * when external modules start doing things, e.g.
13365                      i* Function::Parameters */
13366                     if (p->op_targ != base + count)
13367                         break;
13368                     assert(p->op_targ == base + count);
13369                     /* Either all the padops or none of the padops should
13370                        be in void context.  Since we only do the optimisa-
13371                        tion for av/hv when the aggregate itself is pushed
13372                        on to the stack (one item), there is no need to dis-
13373                        tinguish list from scalar context.  */
13374                     if (gvoid != (OP_GIMME(p,0) == G_VOID))
13375                         break;
13376                 }
13377
13378                 /* for AV, HV, only when we're not flattening */
13379                 if (   p->op_type != OP_PADSV
13380                     && !gvoid
13381                     && !(p->op_flags & OPf_REF)
13382                 )
13383                     break;
13384
13385                 if (count >= OPpPADRANGE_COUNTMASK)
13386                     break;
13387
13388                 /* there's a biggest base we can fit into a
13389                  * SAVEt_CLEARPADRANGE in pp_padrange */
13390                 if (intro && base >
13391                         (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)))
13392                     break;
13393
13394                 /* Success! We've got another valid pad op to optimise away */
13395                 count++;
13396                 followop = p->op_next;
13397             }
13398
13399             if (count < 1 || (count == 1 && !defav))
13400                 break;
13401
13402             /* pp_padrange in specifically compile-time void context
13403              * skips pushing a mark and lexicals; in all other contexts
13404              * (including unknown till runtime) it pushes a mark and the
13405              * lexicals. We must be very careful then, that the ops we
13406              * optimise away would have exactly the same effect as the
13407              * padrange.
13408              * In particular in void context, we can only optimise to
13409              * a padrange if see see the complete sequence
13410              *     pushmark, pad*v, ...., list
13411              * which has the net effect of of leaving the markstack as it
13412              * was.  Not pushing on to the stack (whereas padsv does touch
13413              * the stack) makes no difference in void context.
13414              */
13415             assert(followop);
13416             if (gvoid) {
13417                 if (followop->op_type == OP_LIST
13418                         && OP_GIMME(followop,0) == G_VOID
13419                    )
13420                 {
13421                     followop = followop->op_next; /* skip OP_LIST */
13422
13423                     /* consolidate two successive my(...);'s */
13424
13425                     if (   oldoldop
13426                         && oldoldop->op_type == OP_PADRANGE
13427                         && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
13428                         && (oldoldop->op_private & OPpLVAL_INTRO) == intro
13429                         && !(oldoldop->op_flags & OPf_SPECIAL)
13430                     ) {
13431                         U8 old_count;
13432                         assert(oldoldop->op_next == oldop);
13433                         assert(   oldop->op_type == OP_NEXTSTATE
13434                                || oldop->op_type == OP_DBSTATE);
13435                         assert(oldop->op_next == o);
13436
13437                         old_count
13438                             = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
13439
13440                        /* Do not assume pad offsets for $c and $d are con-
13441                           tiguous in
13442                             my ($a,$b,$c);
13443                             my ($d,$e,$f);
13444                         */
13445                         if (  oldoldop->op_targ + old_count == base
13446                            && old_count < OPpPADRANGE_COUNTMASK - count) {
13447                             base = oldoldop->op_targ;
13448                             count += old_count;
13449                             reuse = 1;
13450                         }
13451                     }
13452
13453                     /* if there's any immediately following singleton
13454                      * my var's; then swallow them and the associated
13455                      * nextstates; i.e.
13456                      *    my ($a,$b); my $c; my $d;
13457                      * is treated as
13458                      *    my ($a,$b,$c,$d);
13459                      */
13460
13461                     while (    ((p = followop->op_next))
13462                             && (  p->op_type == OP_PADSV
13463                                || p->op_type == OP_PADAV
13464                                || p->op_type == OP_PADHV)
13465                             && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
13466                             && (p->op_private & OPpLVAL_INTRO) == intro
13467                             && !(p->op_private & ~OPpLVAL_INTRO)
13468                             && p->op_next
13469                             && (   p->op_next->op_type == OP_NEXTSTATE
13470                                 || p->op_next->op_type == OP_DBSTATE)
13471                             && count < OPpPADRANGE_COUNTMASK
13472                             && base + count == p->op_targ
13473                     ) {
13474                         count++;
13475                         followop = p->op_next;
13476                     }
13477                 }
13478                 else
13479                     break;
13480             }
13481
13482             if (reuse) {
13483                 assert(oldoldop->op_type == OP_PADRANGE);
13484                 oldoldop->op_next = followop;
13485                 oldoldop->op_private = (intro | count);
13486                 o = oldoldop;
13487                 oldop = NULL;
13488                 oldoldop = NULL;
13489             }
13490             else {
13491                 /* Convert the pushmark into a padrange.
13492                  * To make Deparse easier, we guarantee that a padrange was
13493                  * *always* formerly a pushmark */
13494                 assert(o->op_type == OP_PUSHMARK);
13495                 o->op_next = followop;
13496                 CHANGE_TYPE(o, OP_PADRANGE);
13497                 o->op_targ = base;
13498                 /* bit 7: INTRO; bit 6..0: count */
13499                 o->op_private = (intro | count);
13500                 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
13501                               | gvoid * OPf_WANT_VOID
13502                               | (defav ? OPf_SPECIAL : 0));
13503             }
13504             break;
13505         }
13506
13507         case OP_PADAV:
13508         case OP_PADSV:
13509         case OP_PADHV:
13510         /* Skip over state($x) in void context.  */
13511         if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
13512          && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
13513         {
13514             oldop->op_next = o->op_next;
13515             goto redo_nextstate;
13516         }
13517         if (o->op_type != OP_PADAV)
13518             break;
13519         /* FALLTHROUGH */
13520         case OP_GV:
13521             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
13522                 OP* const pop = (o->op_type == OP_PADAV) ?
13523                             o->op_next : o->op_next->op_next;
13524                 IV i;
13525                 if (pop && pop->op_type == OP_CONST &&
13526                     ((PL_op = pop->op_next)) &&
13527                     pop->op_next->op_type == OP_AELEM &&
13528                     !(pop->op_next->op_private &
13529                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
13530                     (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
13531                 {
13532                     GV *gv;
13533                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
13534                         no_bareword_allowed(pop);
13535                     if (o->op_type == OP_GV)
13536                         op_null(o->op_next);
13537                     op_null(pop->op_next);
13538                     op_null(pop);
13539                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
13540                     o->op_next = pop->op_next->op_next;
13541                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
13542                     o->op_private = (U8)i;
13543                     if (o->op_type == OP_GV) {
13544                         gv = cGVOPo_gv;
13545                         GvAVn(gv);
13546                         o->op_type = OP_AELEMFAST;
13547                     }
13548                     else
13549                         o->op_type = OP_AELEMFAST_LEX;
13550                 }
13551                 if (o->op_type != OP_GV)
13552                     break;
13553             }
13554
13555             /* Remove $foo from the op_next chain in void context.  */
13556             if (oldop
13557              && (  o->op_next->op_type == OP_RV2SV
13558                 || o->op_next->op_type == OP_RV2AV
13559                 || o->op_next->op_type == OP_RV2HV  )
13560              && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
13561              && !(o->op_next->op_private & OPpLVAL_INTRO))
13562             {
13563                 oldop->op_next = o->op_next->op_next;
13564                 /* Reprocess the previous op if it is a nextstate, to
13565                    allow double-nextstate optimisation.  */
13566               redo_nextstate:
13567                 if (oldop->op_type == OP_NEXTSTATE) {
13568                     oldop->op_opt = 0;
13569                     o = oldop;
13570                     oldop = oldoldop;
13571                     oldoldop = NULL;
13572                     goto redo;
13573                 }
13574                 o = oldop;
13575             }
13576             else if (o->op_next->op_type == OP_RV2SV) {
13577                 if (!(o->op_next->op_private & OPpDEREF)) {
13578                     op_null(o->op_next);
13579                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
13580                                                                | OPpOUR_INTRO);
13581                     o->op_next = o->op_next->op_next;
13582                     CHANGE_TYPE(o, OP_GVSV);
13583                 }
13584             }
13585             else if (o->op_next->op_type == OP_READLINE
13586                     && o->op_next->op_next->op_type == OP_CONCAT
13587                     && (o->op_next->op_next->op_flags & OPf_STACKED))
13588             {
13589                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
13590                 CHANGE_TYPE(o, OP_RCATLINE);
13591                 o->op_flags |= OPf_STACKED;
13592                 op_null(o->op_next->op_next);
13593                 op_null(o->op_next);
13594             }
13595
13596             break;
13597
13598 #define HV_OR_SCALARHV(op)                                   \
13599     (  (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \
13600        ? (op)                                                  \
13601        : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \
13602        && (  cUNOPx(op)->op_first->op_type == OP_PADHV          \
13603           || cUNOPx(op)->op_first->op_type == OP_RV2HV)          \
13604          ? cUNOPx(op)->op_first                                   \
13605          : NULL)
13606
13607         case OP_NOT:
13608             if ((fop = HV_OR_SCALARHV(cUNOP->op_first)))
13609                 fop->op_private |= OPpTRUEBOOL;
13610             break;
13611
13612         case OP_AND:
13613         case OP_OR:
13614         case OP_DOR:
13615             fop = cLOGOP->op_first;
13616             sop = OpSIBLING(fop);
13617             while (cLOGOP->op_other->op_type == OP_NULL)
13618                 cLOGOP->op_other = cLOGOP->op_other->op_next;
13619             while (o->op_next && (   o->op_type == o->op_next->op_type
13620                                   || o->op_next->op_type == OP_NULL))
13621                 o->op_next = o->op_next->op_next;
13622
13623             /* if we're an OR and our next is a AND in void context, we'll
13624                follow it's op_other on short circuit, same for reverse.
13625                We can't do this with OP_DOR since if it's true, its return
13626                value is the underlying value which must be evaluated
13627                by the next op */
13628             if (o->op_next &&
13629                 (
13630                     (IS_AND_OP(o) && IS_OR_OP(o->op_next))
13631                  || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
13632                 )
13633                 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
13634             ) {
13635                 o->op_next = ((LOGOP*)o->op_next)->op_other;
13636             }
13637             DEFER(cLOGOP->op_other);
13638
13639             o->op_opt = 1;
13640             fop = HV_OR_SCALARHV(fop);
13641             if (sop) sop = HV_OR_SCALARHV(sop);
13642             if (fop || sop
13643             ){
13644                 OP * nop = o;
13645                 OP * lop = o;
13646                 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
13647                     while (nop && nop->op_next) {
13648                         switch (nop->op_next->op_type) {
13649                             case OP_NOT:
13650                             case OP_AND:
13651                             case OP_OR:
13652                             case OP_DOR:
13653                                 lop = nop = nop->op_next;
13654                                 break;
13655                             case OP_NULL:
13656                                 nop = nop->op_next;
13657                                 break;
13658                             default:
13659                                 nop = NULL;
13660                                 break;
13661                         }
13662                     }
13663                 }
13664                 if (fop) {
13665                     if (  (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
13666                       || o->op_type == OP_AND  )
13667                         fop->op_private |= OPpTRUEBOOL;
13668                     else if (!(lop->op_flags & OPf_WANT))
13669                         fop->op_private |= OPpMAYBE_TRUEBOOL;
13670                 }
13671                 if (  (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
13672                    && sop)
13673                     sop->op_private |= OPpTRUEBOOL;
13674             }
13675
13676
13677             break;
13678
13679         case OP_COND_EXPR:
13680             if ((fop = HV_OR_SCALARHV(cLOGOP->op_first)))
13681                 fop->op_private |= OPpTRUEBOOL;
13682 #undef HV_OR_SCALARHV
13683             /* GERONIMO! */ /* FALLTHROUGH */
13684
13685         case OP_MAPWHILE:
13686         case OP_GREPWHILE:
13687         case OP_ANDASSIGN:
13688         case OP_ORASSIGN:
13689         case OP_DORASSIGN:
13690         case OP_RANGE:
13691         case OP_ONCE:
13692             while (cLOGOP->op_other->op_type == OP_NULL)
13693                 cLOGOP->op_other = cLOGOP->op_other->op_next;
13694             DEFER(cLOGOP->op_other);
13695             break;
13696
13697         case OP_ENTERLOOP:
13698         case OP_ENTERITER:
13699             while (cLOOP->op_redoop->op_type == OP_NULL)
13700                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
13701             while (cLOOP->op_nextop->op_type == OP_NULL)
13702                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
13703             while (cLOOP->op_lastop->op_type == OP_NULL)
13704                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
13705             /* a while(1) loop doesn't have an op_next that escapes the
13706              * loop, so we have to explicitly follow the op_lastop to
13707              * process the rest of the code */
13708             DEFER(cLOOP->op_lastop);
13709             break;
13710
13711         case OP_ENTERTRY:
13712             assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
13713             DEFER(cLOGOPo->op_other);
13714             break;
13715
13716         case OP_SUBST:
13717             assert(!(cPMOP->op_pmflags & PMf_ONCE));
13718             while (cPMOP->op_pmstashstartu.op_pmreplstart &&
13719                    cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
13720                 cPMOP->op_pmstashstartu.op_pmreplstart
13721                     = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
13722             DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
13723             break;
13724
13725         case OP_SORT: {
13726             OP *oright;
13727
13728             if (o->op_flags & OPf_SPECIAL) {
13729                 /* first arg is a code block */
13730                 OP * const nullop = OpSIBLING(cLISTOP->op_first);
13731                 OP * kid          = cUNOPx(nullop)->op_first;
13732
13733                 assert(nullop->op_type == OP_NULL);
13734                 assert(kid->op_type == OP_SCOPE
13735                  || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
13736                 /* since OP_SORT doesn't have a handy op_other-style
13737                  * field that can point directly to the start of the code
13738                  * block, store it in the otherwise-unused op_next field
13739                  * of the top-level OP_NULL. This will be quicker at
13740                  * run-time, and it will also allow us to remove leading
13741                  * OP_NULLs by just messing with op_nexts without
13742                  * altering the basic op_first/op_sibling layout. */
13743                 kid = kLISTOP->op_first;
13744                 assert(
13745                       (kid->op_type == OP_NULL
13746                       && (  kid->op_targ == OP_NEXTSTATE
13747                          || kid->op_targ == OP_DBSTATE  ))
13748                     || kid->op_type == OP_STUB
13749                     || kid->op_type == OP_ENTER);
13750                 nullop->op_next = kLISTOP->op_next;
13751                 DEFER(nullop->op_next);
13752             }
13753
13754             /* check that RHS of sort is a single plain array */
13755             oright = cUNOPo->op_first;
13756             if (!oright || oright->op_type != OP_PUSHMARK)
13757                 break;
13758
13759             if (o->op_private & OPpSORT_INPLACE)
13760                 break;
13761
13762             /* reverse sort ... can be optimised.  */
13763             if (!OpHAS_SIBLING(cUNOPo)) {
13764                 /* Nothing follows us on the list. */
13765                 OP * const reverse = o->op_next;
13766
13767                 if (reverse->op_type == OP_REVERSE &&
13768                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
13769                     OP * const pushmark = cUNOPx(reverse)->op_first;
13770                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
13771                         && (OpSIBLING(cUNOPx(pushmark)) == o)) {
13772                         /* reverse -> pushmark -> sort */
13773                         o->op_private |= OPpSORT_REVERSE;
13774                         op_null(reverse);
13775                         pushmark->op_next = oright->op_next;
13776                         op_null(oright);
13777                     }
13778                 }
13779             }
13780
13781             break;
13782         }
13783
13784         case OP_REVERSE: {
13785             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
13786             OP *gvop = NULL;
13787             LISTOP *enter, *exlist;
13788
13789             if (o->op_private & OPpSORT_INPLACE)
13790                 break;
13791
13792             enter = (LISTOP *) o->op_next;
13793             if (!enter)
13794                 break;
13795             if (enter->op_type == OP_NULL) {
13796                 enter = (LISTOP *) enter->op_next;
13797                 if (!enter)
13798                     break;
13799             }
13800             /* for $a (...) will have OP_GV then OP_RV2GV here.
13801                for (...) just has an OP_GV.  */
13802             if (enter->op_type == OP_GV) {
13803                 gvop = (OP *) enter;
13804                 enter = (LISTOP *) enter->op_next;
13805                 if (!enter)
13806                     break;
13807                 if (enter->op_type == OP_RV2GV) {
13808                   enter = (LISTOP *) enter->op_next;
13809                   if (!enter)
13810                     break;
13811                 }
13812             }
13813
13814             if (enter->op_type != OP_ENTERITER)
13815                 break;
13816
13817             iter = enter->op_next;
13818             if (!iter || iter->op_type != OP_ITER)
13819                 break;
13820
13821             expushmark = enter->op_first;
13822             if (!expushmark || expushmark->op_type != OP_NULL
13823                 || expushmark->op_targ != OP_PUSHMARK)
13824                 break;
13825
13826             exlist = (LISTOP *) OpSIBLING(expushmark);
13827             if (!exlist || exlist->op_type != OP_NULL
13828                 || exlist->op_targ != OP_LIST)
13829                 break;
13830
13831             if (exlist->op_last != o) {
13832                 /* Mmm. Was expecting to point back to this op.  */
13833                 break;
13834             }
13835             theirmark = exlist->op_first;
13836             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
13837                 break;
13838
13839             if (OpSIBLING(theirmark) != o) {
13840                 /* There's something between the mark and the reverse, eg
13841                    for (1, reverse (...))
13842                    so no go.  */
13843                 break;
13844             }
13845
13846             ourmark = ((LISTOP *)o)->op_first;
13847             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
13848                 break;
13849
13850             ourlast = ((LISTOP *)o)->op_last;
13851             if (!ourlast || ourlast->op_next != o)
13852                 break;
13853
13854             rv2av = OpSIBLING(ourmark);
13855             if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
13856                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
13857                 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
13858                 /* We're just reversing a single array.  */
13859                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
13860                 enter->op_flags |= OPf_STACKED;
13861             }
13862
13863             /* We don't have control over who points to theirmark, so sacrifice
13864                ours.  */
13865             theirmark->op_next = ourmark->op_next;
13866             theirmark->op_flags = ourmark->op_flags;
13867             ourlast->op_next = gvop ? gvop : (OP *) enter;
13868             op_null(ourmark);
13869             op_null(o);
13870             enter->op_private |= OPpITER_REVERSED;
13871             iter->op_private |= OPpITER_REVERSED;
13872
13873             break;
13874         }
13875
13876         case OP_QR:
13877         case OP_MATCH:
13878             if (!(cPMOP->op_pmflags & PMf_ONCE)) {
13879                 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
13880             }
13881             break;
13882
13883         case OP_RUNCV:
13884             if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
13885              && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
13886             {
13887                 SV *sv;
13888                 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
13889                 else {
13890                     sv = newRV((SV *)PL_compcv);
13891                     sv_rvweaken(sv);
13892                     SvREADONLY_on(sv);
13893                 }
13894                 CHANGE_TYPE(o, OP_CONST);
13895                 o->op_flags |= OPf_SPECIAL;
13896                 cSVOPo->op_sv = sv;
13897             }
13898             break;
13899
13900         case OP_SASSIGN:
13901             if (OP_GIMME(o,0) == G_VOID
13902              || (  o->op_next->op_type == OP_LINESEQ
13903                 && (  o->op_next->op_next->op_type == OP_LEAVESUB
13904                    || (  o->op_next->op_next->op_type == OP_RETURN
13905                       && !CvLVALUE(PL_compcv)))))
13906             {
13907                 OP *right = cBINOP->op_first;
13908                 if (right) {
13909                     /*   sassign
13910                     *      RIGHT
13911                     *      substr
13912                     *         pushmark
13913                     *         arg1
13914                     *         arg2
13915                     *         ...
13916                     * becomes
13917                     *
13918                     *  ex-sassign
13919                     *     substr
13920                     *        pushmark
13921                     *        RIGHT
13922                     *        arg1
13923                     *        arg2
13924                     *        ...
13925                     */
13926                     OP *left = OpSIBLING(right);
13927                     if (left->op_type == OP_SUBSTR
13928                          && (left->op_private & 7) < 4) {
13929                         op_null(o);
13930                         /* cut out right */
13931                         op_sibling_splice(o, NULL, 1, NULL);
13932                         /* and insert it as second child of OP_SUBSTR */
13933                         op_sibling_splice(left, cBINOPx(left)->op_first, 0,
13934                                     right);
13935                         left->op_private |= OPpSUBSTR_REPL_FIRST;
13936                         left->op_flags =
13937                             (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
13938                     }
13939                 }
13940             }
13941             break;
13942
13943         case OP_AASSIGN:
13944             /* We do the common-vars check here, rather than in newASSIGNOP
13945                (as formerly), so that all lexical vars that get aliased are
13946                marked as such before we do the check.  */
13947             /* There can’t be common vars if the lhs is a stub.  */
13948             if (OpSIBLING(cLISTOPx(cBINOPo->op_last)->op_first)
13949                     == cLISTOPx(cBINOPo->op_last)->op_last
13950              && cLISTOPx(cBINOPo->op_last)->op_last->op_type == OP_STUB)
13951             {
13952                 o->op_private &=~ OPpASSIGN_COMMON;
13953                 break;
13954             }
13955             if (o->op_private & OPpASSIGN_COMMON) {
13956                  /* See the comment before S_aassign_common_vars concerning
13957                     PL_generation sorcery.  */
13958                 PL_generation++;
13959                 if (!aassign_common_vars(o))
13960                     o->op_private &=~ OPpASSIGN_COMMON;
13961             }
13962             else if (S_aassign_common_vars_aliases_only(aTHX_ o))
13963                 o->op_private |= OPpASSIGN_COMMON;
13964             break;
13965
13966         case OP_CUSTOM: {
13967             Perl_cpeep_t cpeep =
13968                 XopENTRYCUSTOM(o, xop_peep);
13969             if (cpeep)
13970                 cpeep(aTHX_ o, oldop);
13971             break;
13972         }
13973
13974         }
13975         /* did we just null the current op? If so, re-process it to handle
13976          * eliding "empty" ops from the chain */
13977         if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
13978             o->op_opt = 0;
13979             o = oldop;
13980         }
13981         else {
13982             oldoldop = oldop;
13983             oldop = o;
13984         }
13985     }
13986     LEAVE;
13987 }
13988
13989 void
13990 Perl_peep(pTHX_ OP *o)
13991 {
13992     CALL_RPEEP(o);
13993 }
13994
13995 /*
13996 =head1 Custom Operators
13997
13998 =for apidoc Ao||custom_op_xop
13999 Return the XOP structure for a given custom op.  This macro should be
14000 considered internal to OP_NAME and the other access macros: use them instead.
14001 This macro does call a function.  Prior
14002 to 5.19.6, this was implemented as a
14003 function.
14004
14005 =cut
14006 */
14007
14008 XOPRETANY
14009 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
14010 {
14011     SV *keysv;
14012     HE *he = NULL;
14013     XOP *xop;
14014
14015     static const XOP xop_null = { 0, 0, 0, 0, 0 };
14016
14017     PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
14018     assert(o->op_type == OP_CUSTOM);
14019
14020     /* This is wrong. It assumes a function pointer can be cast to IV,
14021      * which isn't guaranteed, but this is what the old custom OP code
14022      * did. In principle it should be safer to Copy the bytes of the
14023      * pointer into a PV: since the new interface is hidden behind
14024      * functions, this can be changed later if necessary.  */
14025     /* Change custom_op_xop if this ever happens */
14026     keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
14027
14028     if (PL_custom_ops)
14029         he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
14030
14031     /* assume noone will have just registered a desc */
14032     if (!he && PL_custom_op_names &&
14033         (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
14034     ) {
14035         const char *pv;
14036         STRLEN l;
14037
14038         /* XXX does all this need to be shared mem? */
14039         Newxz(xop, 1, XOP);
14040         pv = SvPV(HeVAL(he), l);
14041         XopENTRY_set(xop, xop_name, savepvn(pv, l));
14042         if (PL_custom_op_descs &&
14043             (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
14044         ) {
14045             pv = SvPV(HeVAL(he), l);
14046             XopENTRY_set(xop, xop_desc, savepvn(pv, l));
14047         }
14048         Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
14049     }
14050     else {
14051         if (!he)
14052             xop = (XOP *)&xop_null;
14053         else
14054             xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
14055     }
14056     {
14057         XOPRETANY any;
14058         if(field == XOPe_xop_ptr) {
14059             any.xop_ptr = xop;
14060         } else {
14061             const U32 flags = XopFLAGS(xop);
14062             if(flags & field) {
14063                 switch(field) {
14064                 case XOPe_xop_name:
14065                     any.xop_name = xop->xop_name;
14066                     break;
14067                 case XOPe_xop_desc:
14068                     any.xop_desc = xop->xop_desc;
14069                     break;
14070                 case XOPe_xop_class:
14071                     any.xop_class = xop->xop_class;
14072                     break;
14073                 case XOPe_xop_peep:
14074                     any.xop_peep = xop->xop_peep;
14075                     break;
14076                 default:
14077                     NOT_REACHED;
14078                     break;
14079                 }
14080             } else {
14081                 switch(field) {
14082                 case XOPe_xop_name:
14083                     any.xop_name = XOPd_xop_name;
14084                     break;
14085                 case XOPe_xop_desc:
14086                     any.xop_desc = XOPd_xop_desc;
14087                     break;
14088                 case XOPe_xop_class:
14089                     any.xop_class = XOPd_xop_class;
14090                     break;
14091                 case XOPe_xop_peep:
14092                     any.xop_peep = XOPd_xop_peep;
14093                     break;
14094                 default:
14095                     NOT_REACHED;
14096                     break;
14097                 }
14098             }
14099         }
14100         /* Some gcc releases emit a warning for this function:
14101          * op.c: In function 'Perl_custom_op_get_field':
14102          * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
14103          * Whether this is true, is currently unknown. */
14104         return any;
14105     }
14106 }
14107
14108 /*
14109 =for apidoc Ao||custom_op_register
14110 Register a custom op.  See L<perlguts/"Custom Operators">.
14111
14112 =cut
14113 */
14114
14115 void
14116 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
14117 {
14118     SV *keysv;
14119
14120     PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
14121
14122     /* see the comment in custom_op_xop */
14123     keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
14124
14125     if (!PL_custom_ops)
14126         PL_custom_ops = newHV();
14127
14128     if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
14129         Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
14130 }
14131
14132 /*
14133
14134 =for apidoc core_prototype
14135
14136 This function assigns the prototype of the named core function to C<sv>, or
14137 to a new mortal SV if C<sv> is NULL.  It returns the modified C<sv>, or
14138 NULL if the core function has no prototype.  C<code> is a code as returned
14139 by C<keyword()>.  It must not be equal to 0.
14140
14141 =cut
14142 */
14143
14144 SV *
14145 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
14146                           int * const opnum)
14147 {
14148     int i = 0, n = 0, seen_question = 0, defgv = 0;
14149     I32 oa;
14150 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
14151     char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
14152     bool nullret = FALSE;
14153
14154     PERL_ARGS_ASSERT_CORE_PROTOTYPE;
14155
14156     assert (code);
14157
14158     if (!sv) sv = sv_newmortal();
14159
14160 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
14161
14162     switch (code < 0 ? -code : code) {
14163     case KEY_and   : case KEY_chop: case KEY_chomp:
14164     case KEY_cmp   : case KEY_defined: case KEY_delete: case KEY_exec  :
14165     case KEY_exists: case KEY_eq     : case KEY_ge    : case KEY_goto  :
14166     case KEY_grep  : case KEY_gt     : case KEY_last  : case KEY_le    :
14167     case KEY_lt    : case KEY_map    : case KEY_ne    : case KEY_next  :
14168     case KEY_or    : case KEY_print  : case KEY_printf: case KEY_qr    :
14169     case KEY_redo  : case KEY_require: case KEY_return: case KEY_say   :
14170     case KEY_select: case KEY_sort   : case KEY_split : case KEY_system:
14171     case KEY_x     : case KEY_xor    :
14172         if (!opnum) return NULL; nullret = TRUE; goto findopnum;
14173     case KEY_glob:    retsetpvs("_;", OP_GLOB);
14174     case KEY_keys:    retsetpvs("+", OP_KEYS);
14175     case KEY_values:  retsetpvs("+", OP_VALUES);
14176     case KEY_each:    retsetpvs("+", OP_EACH);
14177     case KEY_push:    retsetpvs("+@", OP_PUSH);
14178     case KEY_unshift: retsetpvs("+@", OP_UNSHIFT);
14179     case KEY_pop:     retsetpvs(";+", OP_POP);
14180     case KEY_shift:   retsetpvs(";+", OP_SHIFT);
14181     case KEY_pos:     retsetpvs(";\\[$*]", OP_POS);
14182     case KEY_splice:
14183         retsetpvs("+;$$@", OP_SPLICE);
14184     case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
14185         retsetpvs("", 0);
14186     case KEY_evalbytes:
14187         name = "entereval"; break;
14188     case KEY_readpipe:
14189         name = "backtick";
14190     }
14191
14192 #undef retsetpvs
14193
14194   findopnum:
14195     while (i < MAXO) {  /* The slow way. */
14196         if (strEQ(name, PL_op_name[i])
14197             || strEQ(name, PL_op_desc[i]))
14198         {
14199             if (nullret) { assert(opnum); *opnum = i; return NULL; }
14200             goto found;
14201         }
14202         i++;
14203     }
14204     return NULL;
14205   found:
14206     defgv = PL_opargs[i] & OA_DEFGV;
14207     oa = PL_opargs[i] >> OASHIFT;
14208     while (oa) {
14209         if (oa & OA_OPTIONAL && !seen_question && (
14210               !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
14211         )) {
14212             seen_question = 1;
14213             str[n++] = ';';
14214         }
14215         if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
14216             && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
14217             /* But globs are already references (kinda) */
14218             && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
14219         ) {
14220             str[n++] = '\\';
14221         }
14222         if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
14223          && !scalar_mod_type(NULL, i)) {
14224             str[n++] = '[';
14225             str[n++] = '$';
14226             str[n++] = '@';
14227             str[n++] = '%';
14228             if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
14229             str[n++] = '*';
14230             str[n++] = ']';
14231         }
14232         else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
14233         if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
14234             str[n-1] = '_'; defgv = 0;
14235         }
14236         oa = oa >> 4;
14237     }
14238     if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
14239     str[n++] = '\0';
14240     sv_setpvn(sv, str, n - 1);
14241     if (opnum) *opnum = i;
14242     return sv;
14243 }
14244
14245 OP *
14246 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
14247                       const int opnum)
14248 {
14249     OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
14250     OP *o;
14251
14252     PERL_ARGS_ASSERT_CORESUB_OP;
14253
14254     switch(opnum) {
14255     case 0:
14256         return op_append_elem(OP_LINESEQ,
14257                        argop,
14258                        newSLICEOP(0,
14259                                   newSVOP(OP_CONST, 0, newSViv(-code % 3)),
14260                                   newOP(OP_CALLER,0)
14261                        )
14262                );
14263     case OP_SELECT: /* which represents OP_SSELECT as well */
14264         if (code)
14265             return newCONDOP(
14266                          0,
14267                          newBINOP(OP_GT, 0,
14268                                   newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
14269                                   newSVOP(OP_CONST, 0, newSVuv(1))
14270                                  ),
14271                          coresub_op(newSVuv((UV)OP_SSELECT), 0,
14272                                     OP_SSELECT),
14273                          coresub_op(coreargssv, 0, OP_SELECT)
14274                    );
14275         /* FALLTHROUGH */
14276     default:
14277         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
14278         case OA_BASEOP:
14279             return op_append_elem(
14280                         OP_LINESEQ, argop,
14281                         newOP(opnum,
14282                               opnum == OP_WANTARRAY || opnum == OP_RUNCV
14283                                 ? OPpOFFBYONE << 8 : 0)
14284                    );
14285         case OA_BASEOP_OR_UNOP:
14286             if (opnum == OP_ENTEREVAL) {
14287                 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
14288                 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
14289             }
14290             else o = newUNOP(opnum,0,argop);
14291             if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
14292             else {
14293           onearg:
14294               if (is_handle_constructor(o, 1))
14295                 argop->op_private |= OPpCOREARGS_DEREF1;
14296               if (scalar_mod_type(NULL, opnum))
14297                 argop->op_private |= OPpCOREARGS_SCALARMOD;
14298             }
14299             return o;
14300         default:
14301             o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
14302             if (is_handle_constructor(o, 2))
14303                 argop->op_private |= OPpCOREARGS_DEREF2;
14304             if (opnum == OP_SUBSTR) {
14305                 o->op_private |= OPpMAYBE_LVSUB;
14306                 return o;
14307             }
14308             else goto onearg;
14309         }
14310     }
14311 }
14312
14313 void
14314 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
14315                                SV * const *new_const_svp)
14316 {
14317     const char *hvname;
14318     bool is_const = !!CvCONST(old_cv);
14319     SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
14320
14321     PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
14322
14323     if (is_const && new_const_svp && old_const_sv == *new_const_svp)
14324         return;
14325         /* They are 2 constant subroutines generated from
14326            the same constant. This probably means that
14327            they are really the "same" proxy subroutine
14328            instantiated in 2 places. Most likely this is
14329            when a constant is exported twice.  Don't warn.
14330         */
14331     if (
14332         (ckWARN(WARN_REDEFINE)
14333          && !(
14334                 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
14335              && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
14336              && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
14337                  strEQ(hvname, "autouse"))
14338              )
14339         )
14340      || (is_const
14341          && ckWARN_d(WARN_REDEFINE)
14342          && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
14343         )
14344     )
14345         Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
14346                           is_const
14347                             ? "Constant subroutine %"SVf" redefined"
14348                             : "Subroutine %"SVf" redefined",
14349                           SVfARG(name));
14350 }
14351
14352 /*
14353 =head1 Hook manipulation
14354
14355 These functions provide convenient and thread-safe means of manipulating
14356 hook variables.
14357
14358 =cut
14359 */
14360
14361 /*
14362 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
14363
14364 Puts a C function into the chain of check functions for a specified op
14365 type.  This is the preferred way to manipulate the L</PL_check> array.
14366 I<opcode> specifies which type of op is to be affected.  I<new_checker>
14367 is a pointer to the C function that is to be added to that opcode's
14368 check chain, and I<old_checker_p> points to the storage location where a
14369 pointer to the next function in the chain will be stored.  The value of
14370 I<new_pointer> is written into the L</PL_check> array, while the value
14371 previously stored there is written to I<*old_checker_p>.
14372
14373 The function should be defined like this:
14374
14375     static OP *new_checker(pTHX_ OP *op) { ... }
14376
14377 It is intended to be called in this manner:
14378
14379     new_checker(aTHX_ op)
14380
14381 I<old_checker_p> should be defined like this:
14382
14383     static Perl_check_t old_checker_p;
14384
14385 L</PL_check> is global to an entire process, and a module wishing to
14386 hook op checking may find itself invoked more than once per process,
14387 typically in different threads.  To handle that situation, this function
14388 is idempotent.  The location I<*old_checker_p> must initially (once
14389 per process) contain a null pointer.  A C variable of static duration
14390 (declared at file scope, typically also marked C<static> to give
14391 it internal linkage) will be implicitly initialised appropriately,
14392 if it does not have an explicit initialiser.  This function will only
14393 actually modify the check chain if it finds I<*old_checker_p> to be null.
14394 This function is also thread safe on the small scale.  It uses appropriate
14395 locking to avoid race conditions in accessing L</PL_check>.
14396
14397 When this function is called, the function referenced by I<new_checker>
14398 must be ready to be called, except for I<*old_checker_p> being unfilled.
14399 In a threading situation, I<new_checker> may be called immediately,
14400 even before this function has returned.  I<*old_checker_p> will always
14401 be appropriately set before I<new_checker> is called.  If I<new_checker>
14402 decides not to do anything special with an op that it is given (which
14403 is the usual case for most uses of op check hooking), it must chain the
14404 check function referenced by I<*old_checker_p>.
14405
14406 If you want to influence compilation of calls to a specific subroutine,
14407 then use L</cv_set_call_checker> rather than hooking checking of all
14408 C<entersub> ops.
14409
14410 =cut
14411 */
14412
14413 void
14414 Perl_wrap_op_checker(pTHX_ Optype opcode,
14415     Perl_check_t new_checker, Perl_check_t *old_checker_p)
14416 {
14417     dVAR;
14418
14419     PERL_UNUSED_CONTEXT;
14420     PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
14421     if (*old_checker_p) return;
14422     OP_CHECK_MUTEX_LOCK;
14423     if (!*old_checker_p) {
14424         *old_checker_p = PL_check[opcode];
14425         PL_check[opcode] = new_checker;
14426     }
14427     OP_CHECK_MUTEX_UNLOCK;
14428 }
14429
14430 #include "XSUB.h"
14431
14432 /* Efficient sub that returns a constant scalar value. */
14433 static void
14434 const_sv_xsub(pTHX_ CV* cv)
14435 {
14436     dXSARGS;
14437     SV *const sv = MUTABLE_SV(XSANY.any_ptr);
14438     PERL_UNUSED_ARG(items);
14439     if (!sv) {
14440         XSRETURN(0);
14441     }
14442     EXTEND(sp, 1);
14443     ST(0) = sv;
14444     XSRETURN(1);
14445 }
14446
14447 static void
14448 const_av_xsub(pTHX_ CV* cv)
14449 {
14450     dXSARGS;
14451     AV * const av = MUTABLE_AV(XSANY.any_ptr);
14452     SP -= items;
14453     assert(av);
14454 #ifndef DEBUGGING
14455     if (!av) {
14456         XSRETURN(0);
14457     }
14458 #endif
14459     if (SvRMAGICAL(av))
14460         Perl_croak(aTHX_ "Magical list constants are not supported");
14461     if (GIMME_V != G_ARRAY) {
14462         EXTEND(SP, 1);
14463         ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
14464         XSRETURN(1);
14465     }
14466     EXTEND(SP, AvFILLp(av)+1);
14467     Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
14468     XSRETURN(AvFILLp(av)+1);
14469 }
14470
14471 /*
14472  * Local variables:
14473  * c-indentation-style: bsd
14474  * c-basic-offset: 4
14475  * indent-tabs-mode: nil
14476  * End:
14477  *
14478  * ex: set ts=8 sts=4 sw=4 et:
14479  */