op.c

   1 #line 2 "op.c"
   2 /*    op.c
   3  *
   4  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
   5  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
   6  *
   7  *    You may distribute under the terms of either the GNU General Public
   8  *    License or the Artistic License, as specified in the README file.
   9  *
  10  */
  11
  12 /*
  13  * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck.  She was
  14  *  our Mr. Bilbo's first cousin on the mother's side (her mother being the
  15  *  youngest of the Old Took's daughters); and Mr. Drogo was his second
  16  *  cousin.  So Mr. Frodo is his first *and* second cousin, once removed
  17  *  either way, as the saying is, if you follow me.'       --the Gaffer
  18  *
  19  *     [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
  20  */
  21
  22 /* This file contains the functions that create, manipulate and optimize
  23  * the OP structures that hold a compiled perl program.
  24  *
  25  * A Perl program is compiled into a tree of OPs. Each op contains
  26  * structural pointers (eg to its siblings and the next op in the
  27  * execution sequence), a pointer to the function that would execute the
  28  * op, plus any data specific to that op. For example, an OP_CONST op
  29  * points to the pp_const() function and to an SV containing the constant
  30  * value. When pp_const() is executed, its job is to push that SV onto the
  31  * stack.
  32  *
  33  * OPs are mainly created by the newFOO() functions, which are mainly
  34  * called from the parser (in perly.y) as the code is parsed. For example
  35  * the Perl code $a + $b * $c would cause the equivalent of the following
  36  * to be called (oversimplifying a bit):
  37  *
  38  *  newBINOP(OP_ADD, flags,
  39  *      newSVREF($a),
  40  *      newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
  41  *  )
  42  *
  43  * Note that during the build of miniperl, a temporary copy of this file
  44  * is made, called opmini.c.
  45  */
  46
  47 /*
  48 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
  49
  50     A bottom-up pass
  51     A top-down pass
  52     An execution-order pass
  53
  54 The bottom-up pass is represented by all the "newOP" routines and
  55 the ck_ routines.  The bottom-upness is actually driven by yacc.
  56 So at the point that a ck_ routine fires, we have no idea what the
  57 context is, either upward in the syntax tree, or either forward or
  58 backward in the execution order.  (The bottom-up parser builds that
  59 part of the execution order it knows about, but if you follow the "next"
  60 links around, you'll find it's actually a closed loop through the
  61 top level node.)
  62
  63 Whenever the bottom-up parser gets to a node that supplies context to
  64 its components, it invokes that portion of the top-down pass that applies
  65 to that part of the subtree (and marks the top node as processed, so
  66 if a node further up supplies context, it doesn't have to take the
  67 plunge again).  As a particular subcase of this, as the new node is
  68 built, it takes all the closed execution loops of its subcomponents
  69 and links them into a new closed loop for the higher level node.  But
  70 it's still not the real execution order.
  71
  72 The actual execution order is not known till we get a grammar reduction
  73 to a top-level unit like a subroutine or file that will be called by
  74 "name" rather than via a "next" pointer.  At that point, we can call
  75 into peep() to do that code's portion of the 3rd pass.  It has to be
  76 recursive, but it's recursive on basic blocks, not on tree nodes.
  77 */
  78
  79 /* To implement user lexical pragmas, there needs to be a way at run time to
  80    get the compile time state of %^H for that block.  Storing %^H in every
  81    block (or even COP) would be very expensive, so a different approach is
  82    taken.  The (running) state of %^H is serialised into a tree of HE-like
  83    structs.  Stores into %^H are chained onto the current leaf as a struct
  84    refcounted_he * with the key and the value.  Deletes from %^H are saved
  85    with a value of PL_sv_placeholder.  The state of %^H at any point can be
  86    turned back into a regular HV by walking back up the tree from that point's
  87    leaf, ignoring any key you've already seen (placeholder or not), storing
  88    the rest into the HV structure, then removing the placeholders. Hence
  89    memory is only used to store the %^H deltas from the enclosing COP, rather
  90    than the entire %^H on each COP.
  91
  92    To cause actions on %^H to write out the serialisation records, it has
  93    magic type 'H'. This magic (itself) does nothing, but its presence causes
  94    the values to gain magic type 'h', which has entries for set and clear.
  95    C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
  96    record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
  97    saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
  98    it will be correctly restored when any inner compiling scope is exited.
  99 */
 100
 101 #include "EXTERN.h"
 102 #define PERL_IN_OP_C
 103 #include "perl.h"
 104 #include "keywords.h"
 105 #include "feature.h"
 106 #include "regcomp.h"
 107
 108 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
 109 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
 110 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
 111
 112 /* Used to avoid recursion through the op tree in scalarvoid() and
 113    op_free()
 114 */
 115
 116 #define DEFERRED_OP_STEP 100
 117 #define DEFER_OP(o) \
 118   STMT_START { \
 119     if (UNLIKELY(defer_ix == (defer_stack_alloc-1))) {    \
 120         defer_stack_alloc += DEFERRED_OP_STEP; \
 121         assert(defer_stack_alloc > 0); \
 122         Renew(defer_stack, defer_stack_alloc, OP *); \
 123     } \
 124     defer_stack[++defer_ix] = o; \
 125   } STMT_END
 126
 127 #define POP_DEFERRED_OP() (defer_ix >= 0 ? defer_stack[defer_ix--] : (OP *)NULL)
 128
 129 /* remove any leading "empty" ops from the op_next chain whose first
 130  * node's address is stored in op_p. Store the updated address of the
 131  * first node in op_p.
 132  */
 133
 134 STATIC void
 135 S_prune_chain_head(OP** op_p)
 136 {
 137     while (*op_p
 138         && (   (*op_p)->op_type == OP_NULL
 139             || (*op_p)->op_type == OP_SCOPE
 140             || (*op_p)->op_type == OP_SCALAR
 141             || (*op_p)->op_type == OP_LINESEQ)
 142     )
 143         *op_p = (*op_p)->op_next;
 144 }
 145
 146
 147 /* See the explanatory comments above struct opslab in op.h. */
 148
 149 #ifdef PERL_DEBUG_READONLY_OPS
 150 #  define PERL_SLAB_SIZE 128
 151 #  define PERL_MAX_SLAB_SIZE 4096
 152 #  include <sys/mman.h>
 153 #endif
 154
 155 #ifndef PERL_SLAB_SIZE
 156 #  define PERL_SLAB_SIZE 64
 157 #endif
 158 #ifndef PERL_MAX_SLAB_SIZE
 159 #  define PERL_MAX_SLAB_SIZE 2048
 160 #endif
 161
 162 /* rounds up to nearest pointer */
 163 #define SIZE_TO_PSIZE(x)        (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
 164 #define DIFF(o,p)               ((size_t)((I32 **)(p) - (I32**)(o)))
 165
 166 static OPSLAB *
 167 S_new_slab(pTHX_ size_t sz)
 168 {
 169 #ifdef PERL_DEBUG_READONLY_OPS
 170     OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
 171                                    PROT_READ|PROT_WRITE,
 172                                    MAP_ANON|MAP_PRIVATE, -1, 0);
 173     DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
 174                           (unsigned long) sz, slab));
 175     if (slab == MAP_FAILED) {
 176         perror("mmap failed");
 177         abort();
 178     }
 179     slab->opslab_size = (U16)sz;
 180 #else
 181     OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
 182 #endif
 183 #ifndef WIN32
 184     /* The context is unused in non-Windows */
 185     PERL_UNUSED_CONTEXT;
 186 #endif
 187     slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
 188     return slab;
 189 }
 190
 191 /* requires double parens and aTHX_ */
 192 #define DEBUG_S_warn(args)                                             \
 193     DEBUG_S(                                                            \
 194         PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
 195     )
 196
 197 void *
 198 Perl_Slab_Alloc(pTHX_ size_t sz)
 199 {
 200     OPSLAB *slab;
 201     OPSLAB *slab2;
 202     OPSLOT *slot;
 203     OP *o;
 204     size_t opsz, space;
 205
 206     /* We only allocate ops from the slab during subroutine compilation.
 207        We find the slab via PL_compcv, hence that must be non-NULL. It could
 208        also be pointing to a subroutine which is now fully set up (CvROOT()
 209        pointing to the top of the optree for that sub), or a subroutine
 210        which isn't using the slab allocator. If our sanity checks aren't met,
 211        don't use a slab, but allocate the OP directly from the heap.  */
 212     if (!PL_compcv || CvROOT(PL_compcv)
 213      || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
 214     {
 215         o = (OP*)PerlMemShared_calloc(1, sz);
 216         goto gotit;
 217     }
 218
 219     /* While the subroutine is under construction, the slabs are accessed via
 220        CvSTART(), to avoid needing to expand PVCV by one pointer for something
 221        unneeded at runtime. Once a subroutine is constructed, the slabs are
 222        accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
 223        allocated yet.  See the commit message for 8be227ab5eaa23f2 for more
 224        details.  */
 225     if (!CvSTART(PL_compcv)) {
 226         CvSTART(PL_compcv) =
 227             (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
 228         CvSLABBED_on(PL_compcv);
 229         slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
 230     }
 231     else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
 232
 233     opsz = SIZE_TO_PSIZE(sz);
 234     sz = opsz + OPSLOT_HEADER_P;
 235
 236     /* The slabs maintain a free list of OPs. In particular, constant folding
 237        will free up OPs, so it makes sense to re-use them where possible. A
 238        freed up slot is used in preference to a new allocation.  */
 239     if (slab->opslab_freed) {
 240         OP **too = &slab->opslab_freed;
 241         o = *too;
 242         DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", (void*)o, (void*)slab));
 243         while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
 244             DEBUG_S_warn((aTHX_ "Alas! too small"));
 245             o = *(too = &o->op_next);
 246             if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", (void*)o)); }
 247         }
 248         if (o) {
 249             *too = o->op_next;
 250             Zero(o, opsz, I32 *);
 251             o->op_slabbed = 1;
 252             goto gotit;
 253         }
 254     }
 255
 256 #define INIT_OPSLOT \
 257             slot->opslot_slab = slab;                   \
 258             slot->opslot_next = slab2->opslab_first;    \
 259             slab2->opslab_first = slot;                 \
 260             o = &slot->opslot_op;                       \
 261             o->op_slabbed = 1
 262
 263     /* The partially-filled slab is next in the chain. */
 264     slab2 = slab->opslab_next ? slab->opslab_next : slab;
 265     if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
 266         /* Remaining space is too small. */
 267
 268         /* If we can fit a BASEOP, add it to the free chain, so as not
 269            to waste it. */
 270         if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
 271             slot = &slab2->opslab_slots;
 272             INIT_OPSLOT;
 273             o->op_type = OP_FREED;
 274             o->op_next = slab->opslab_freed;
 275             slab->opslab_freed = o;
 276         }
 277
 278         /* Create a new slab.  Make this one twice as big. */
 279         slot = slab2->opslab_first;
 280         while (slot->opslot_next) slot = slot->opslot_next;
 281         slab2 = S_new_slab(aTHX_
 282                             (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
 283                                         ? PERL_MAX_SLAB_SIZE
 284                                         : (DIFF(slab2, slot)+1)*2);
 285         slab2->opslab_next = slab->opslab_next;
 286         slab->opslab_next = slab2;
 287     }
 288     assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
 289
 290     /* Create a new op slot */
 291     slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
 292     assert(slot >= &slab2->opslab_slots);
 293     if (DIFF(&slab2->opslab_slots, slot)
 294          < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
 295         slot = &slab2->opslab_slots;
 296     INIT_OPSLOT;
 297     DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab));
 298
 299   gotit:
 300     /* lastsib == 1, op_sibling == 0 implies a solitary unattached op */
 301     o->op_lastsib = 1;
 302     assert(!o->op_sibling);
 303
 304     return (void *)o;
 305 }
 306
 307 #undef INIT_OPSLOT
 308
 309 #ifdef PERL_DEBUG_READONLY_OPS
 310 void
 311 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
 312 {
 313     PERL_ARGS_ASSERT_SLAB_TO_RO;
 314
 315     if (slab->opslab_readonly) return;
 316     slab->opslab_readonly = 1;
 317     for (; slab; slab = slab->opslab_next) {
 318         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
 319                               (unsigned long) slab->opslab_size, slab));*/
 320         if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
 321             Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
 322                              (unsigned long)slab->opslab_size, errno);
 323     }
 324 }
 325
 326 void
 327 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
 328 {
 329     OPSLAB *slab2;
 330
 331     PERL_ARGS_ASSERT_SLAB_TO_RW;
 332
 333     if (!slab->opslab_readonly) return;
 334     slab2 = slab;
 335     for (; slab2; slab2 = slab2->opslab_next) {
 336         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
 337                               (unsigned long) size, slab2));*/
 338         if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
 339                      PROT_READ|PROT_WRITE)) {
 340             Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
 341                              (unsigned long)slab2->opslab_size, errno);
 342         }
 343     }
 344     slab->opslab_readonly = 0;
 345 }
 346
 347 #else
 348 #  define Slab_to_rw(op)    NOOP
 349 #endif
 350
 351 /* This cannot possibly be right, but it was copied from the old slab
 352    allocator, to which it was originally added, without explanation, in
 353    commit 083fcd5. */
 354 #ifdef NETWARE
 355 #    define PerlMemShared PerlMem
 356 #endif
 357
 358 void
 359 Perl_Slab_Free(pTHX_ void *op)
 360 {
 361     OP * const o = (OP *)op;
 362     OPSLAB *slab;
 363
 364     PERL_ARGS_ASSERT_SLAB_FREE;
 365
 366     if (!o->op_slabbed) {
 367         if (!o->op_static)
 368             PerlMemShared_free(op);
 369         return;
 370     }
 371
 372     slab = OpSLAB(o);
 373     /* If this op is already freed, our refcount will get screwy. */
 374     assert(o->op_type != OP_FREED);
 375     o->op_type = OP_FREED;
 376     o->op_next = slab->opslab_freed;
 377     slab->opslab_freed = o;
 378     DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", (void*)o, (void*)slab));
 379     OpslabREFCNT_dec_padok(slab);
 380 }
 381
 382 void
 383 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
 384 {
 385     const bool havepad = !!PL_comppad;
 386     PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
 387     if (havepad) {
 388         ENTER;
 389         PAD_SAVE_SETNULLPAD();
 390     }
 391     opslab_free(slab);
 392     if (havepad) LEAVE;
 393 }
 394
 395 void
 396 Perl_opslab_free(pTHX_ OPSLAB *slab)
 397 {
 398     OPSLAB *slab2;
 399     PERL_ARGS_ASSERT_OPSLAB_FREE;
 400     PERL_UNUSED_CONTEXT;
 401     DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
 402     assert(slab->opslab_refcnt == 1);
 403     for (; slab; slab = slab2) {
 404         slab2 = slab->opslab_next;
 405 #ifdef DEBUGGING
 406         slab->opslab_refcnt = ~(size_t)0;
 407 #endif
 408 #ifdef PERL_DEBUG_READONLY_OPS
 409         DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
 410                                                (void*)slab));
 411         if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
 412             perror("munmap failed");
 413             abort();
 414         }
 415 #else
 416         PerlMemShared_free(slab);
 417 #endif
 418     }
 419 }
 420
 421 void
 422 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
 423 {
 424     OPSLAB *slab2;
 425     OPSLOT *slot;
 426 #ifdef DEBUGGING
 427     size_t savestack_count = 0;
 428 #endif
 429     PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
 430     slab2 = slab;
 431     do {
 432         for (slot = slab2->opslab_first;
 433              slot->opslot_next;
 434              slot = slot->opslot_next) {
 435             if (slot->opslot_op.op_type != OP_FREED
 436              && !(slot->opslot_op.op_savefree
 437 #ifdef DEBUGGING
 438                   && ++savestack_count
 439 #endif
 440                  )
 441             ) {
 442                 assert(slot->opslot_op.op_slabbed);
 443                 op_free(&slot->opslot_op);
 444                 if (slab->opslab_refcnt == 1) goto free;
 445             }
 446         }
 447     } while ((slab2 = slab2->opslab_next));
 448     /* > 1 because the CV still holds a reference count. */
 449     if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
 450 #ifdef DEBUGGING
 451         assert(savestack_count == slab->opslab_refcnt-1);
 452 #endif
 453         /* Remove the CV’s reference count. */
 454         slab->opslab_refcnt--;
 455         return;
 456     }
 457    free:
 458     opslab_free(slab);
 459 }
 460
 461 #ifdef PERL_DEBUG_READONLY_OPS
 462 OP *
 463 Perl_op_refcnt_inc(pTHX_ OP *o)
 464 {
 465     if(o) {
 466         OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
 467         if (slab && slab->opslab_readonly) {
 468             Slab_to_rw(slab);
 469             ++o->op_targ;
 470             Slab_to_ro(slab);
 471         } else {
 472             ++o->op_targ;
 473         }
 474     }
 475     return o;
 476
 477 }
 478
 479 PADOFFSET
 480 Perl_op_refcnt_dec(pTHX_ OP *o)
 481 {
 482     PADOFFSET result;
 483     OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
 484
 485     PERL_ARGS_ASSERT_OP_REFCNT_DEC;
 486
 487     if (slab && slab->opslab_readonly) {
 488         Slab_to_rw(slab);
 489         result = --o->op_targ;
 490         Slab_to_ro(slab);
 491     } else {
 492         result = --o->op_targ;
 493     }
 494     return result;
 495 }
 496 #endif
 497 /*
 498  * In the following definition, the ", (OP*)0" is just to make the compiler
 499  * think the expression is of the right type: croak actually does a Siglongjmp.
 500  */
 501 #define CHECKOP(type,o) \
 502     ((PL_op_mask && PL_op_mask[type])                           \
 503      ? ( op_free((OP*)o),                                       \
 504          Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]),  \
 505          (OP*)0 )                                               \
 506      : PL_check[type](aTHX_ (OP*)o))
 507
 508 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
 509
 510 #define CHANGE_TYPE(o,type) \
 511     STMT_START {                                \
 512         o->op_type = (OPCODE)type;              \
 513         o->op_ppaddr = PL_ppaddr[type];         \
 514     } STMT_END
 515
 516 STATIC OP *
 517 S_no_fh_allowed(pTHX_ OP *o)
 518 {
 519     PERL_ARGS_ASSERT_NO_FH_ALLOWED;
 520
 521     yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
 522                  OP_DESC(o)));
 523     return o;
 524 }
 525
 526 STATIC OP *
 527 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
 528 {
 529     PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
 530     yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
 531     return o;
 532 }
 533
 534 STATIC OP *
 535 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
 536 {
 537     PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
 538
 539     yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
 540     return o;
 541 }
 542
 543 STATIC void
 544 S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid)
 545 {
 546     PERL_ARGS_ASSERT_BAD_TYPE_PV;
 547
 548     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
 549                  (int)n, name, t, OP_DESC(kid)), flags);
 550 }
 551
 552 STATIC void
 553 S_bad_type_gv(pTHX_ I32 n, const char *t, GV *gv, U32 flags, const OP *kid)
 554 {
 555     SV * const namesv = cv_name((CV *)gv, NULL, 0);
 556     PERL_ARGS_ASSERT_BAD_TYPE_GV;
 557
 558     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
 559                  (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv) | flags);
 560 }
 561
 562 STATIC void
 563 S_no_bareword_allowed(pTHX_ OP *o)
 564 {
 565     PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
 566
 567     qerror(Perl_mess(aTHX_
 568                      "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
 569                      SVfARG(cSVOPo_sv)));
 570     o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
 571 }
 572
 573 /* "register" allocation */
 574
 575 PADOFFSET
 576 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
 577 {
 578     PADOFFSET off;
 579     const bool is_our = (PL_parser->in_my == KEY_our);
 580
 581     PERL_ARGS_ASSERT_ALLOCMY;
 582
 583     if (flags & ~SVf_UTF8)
 584         Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
 585                    (UV)flags);
 586
 587     /* complain about "my $<special_var>" etc etc */
 588     if (len &&
 589         !(is_our ||
 590           isALPHA(name[1]) ||
 591           ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
 592           (name[1] == '_' && (*name == '$' || len > 2))))
 593     {
 594         if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
 595          && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
 596             yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
 597                               name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
 598                               PL_parser->in_my == KEY_state ? "state" : "my"));
 599         } else {
 600             yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
 601                               PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
 602         }
 603     }
 604     else if (len == 2 && name[1] == '_' && !is_our)
 605         /* diag_listed_as: Use of my $_ is experimental */
 606         Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__LEXICAL_TOPIC),
 607                               "Use of %s $_ is experimental",
 608                                PL_parser->in_my == KEY_state
 609                                  ? "state"
 610                                  : "my");
 611
 612     /* allocate a spare slot and store the name in that slot */
 613
 614     off = pad_add_name_pvn(name, len,
 615                        (is_our ? padadd_OUR :
 616                         PL_parser->in_my == KEY_state ? padadd_STATE : 0)
 617                             | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ),
 618                     PL_parser->in_my_stash,
 619                     (is_our
 620                         /* $_ is always in main::, even with our */
 621                         ? (PL_curstash && !memEQs(name,len,"$_")
 622                             ? PL_curstash
 623                             : PL_defstash)
 624                         : NULL
 625                     )
 626     );
 627     /* anon sub prototypes contains state vars should always be cloned,
 628      * otherwise the state var would be shared between anon subs */
 629
 630     if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
 631         CvCLONE_on(PL_compcv);
 632
 633     return off;
 634 }
 635
 636 /*
 637 =head1 Optree Manipulation Functions
 638
 639 =for apidoc alloccopstash
 640
 641 Available only under threaded builds, this function allocates an entry in
 642 C<PL_stashpad> for the stash passed to it.
 643
 644 =cut
 645 */
 646
 647 #ifdef USE_ITHREADS
 648 PADOFFSET
 649 Perl_alloccopstash(pTHX_ HV *hv)
 650 {
 651     PADOFFSET off = 0, o = 1;
 652     bool found_slot = FALSE;
 653
 654     PERL_ARGS_ASSERT_ALLOCCOPSTASH;
 655
 656     if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
 657
 658     for (; o < PL_stashpadmax; ++o) {
 659         if (PL_stashpad[o] == hv) return PL_stashpadix = o;
 660         if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
 661             found_slot = TRUE, off = o;
 662     }
 663     if (!found_slot) {
 664         Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
 665         Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
 666         off = PL_stashpadmax;
 667         PL_stashpadmax += 10;
 668     }
 669
 670     PL_stashpad[PL_stashpadix = off] = hv;
 671     return off;
 672 }
 673 #endif
 674
 675 /* free the body of an op without examining its contents.
 676  * Always use this rather than FreeOp directly */
 677
 678 static void
 679 S_op_destroy(pTHX_ OP *o)
 680 {
 681     FreeOp(o);
 682 }
 683
 684 /* Destructor */
 685
 686 /*
 687 =for apidoc Am|void|op_free|OP *o
 688
 689 Free an op.  Only use this when an op is no longer linked to from any
 690 optree.
 691
 692 =cut
 693 */
 694
 695 void
 696 Perl_op_free(pTHX_ OP *o)
 697 {
 698     dVAR;
 699     OPCODE type;
 700     SSize_t defer_ix = -1;
 701     SSize_t defer_stack_alloc = 0;
 702     OP **defer_stack = NULL;
 703
 704     do {
 705
 706         /* Though ops may be freed twice, freeing the op after its slab is a
 707            big no-no. */
 708         assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
 709         /* During the forced freeing of ops after compilation failure, kidops
 710            may be freed before their parents. */
 711         if (!o || o->op_type == OP_FREED)
 712             continue;
 713
 714         type = o->op_type;
 715
 716         /* an op should only ever acquire op_private flags that we know about.
 717          * If this fails, you may need to fix something in regen/op_private */
 718         if (o->op_ppaddr == PL_ppaddr[o->op_type]) {
 719             assert(!(o->op_private & ~PL_op_private_valid[type]));
 720         }
 721
 722         if (o->op_private & OPpREFCOUNTED) {
 723             switch (type) {
 724             case OP_LEAVESUB:
 725             case OP_LEAVESUBLV:
 726             case OP_LEAVEEVAL:
 727             case OP_LEAVE:
 728             case OP_SCOPE:
 729             case OP_LEAVEWRITE:
 730                 {
 731                 PADOFFSET refcnt;
 732                 OP_REFCNT_LOCK;
 733                 refcnt = OpREFCNT_dec(o);
 734                 OP_REFCNT_UNLOCK;
 735                 if (refcnt) {
 736                     /* Need to find and remove any pattern match ops from the list
 737                        we maintain for reset().  */
 738                     find_and_forget_pmops(o);
 739                     continue;
 740                 }
 741                 }
 742                 break;
 743             default:
 744                 break;
 745             }
 746         }
 747
 748         /* Call the op_free hook if it has been set. Do it now so that it's called
 749          * at the right time for refcounted ops, but still before all of the kids
 750          * are freed. */
 751         CALL_OPFREEHOOK(o);
 752
 753         if (o->op_flags & OPf_KIDS) {
 754             OP *kid, *nextkid;
 755             for (kid = cUNOPo->op_first; kid; kid = nextkid) {
 756                 nextkid = OP_SIBLING(kid); /* Get before next freeing kid */
 757                 if (!kid || kid->op_type == OP_FREED)
 758                     /* During the forced freeing of ops after
 759                        compilation failure, kidops may be freed before
 760                        their parents. */
 761                     continue;
 762                 if (!(kid->op_flags & OPf_KIDS))
 763                     /* If it has no kids, just free it now */
 764                     op_free(kid);
 765                 else
 766                     DEFER_OP(kid);
 767             }
 768         }
 769         if (type == OP_NULL)
 770             type = (OPCODE)o->op_targ;
 771
 772         if (o->op_slabbed)
 773             Slab_to_rw(OpSLAB(o));
 774
 775         /* COP* is not cleared by op_clear() so that we may track line
 776          * numbers etc even after null() */
 777         if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
 778             cop_free((COP*)o);
 779         }
 780
 781         op_clear(o);
 782         FreeOp(o);
 783 #ifdef DEBUG_LEAKING_SCALARS
 784         if (PL_op == o)
 785             PL_op = NULL;
 786 #endif
 787     } while ( (o = POP_DEFERRED_OP()) );
 788
 789     Safefree(defer_stack);
 790 }
 791
 792 void
 793 Perl_op_clear(pTHX_ OP *o)
 794 {
 795
 796     dVAR;
 797
 798     PERL_ARGS_ASSERT_OP_CLEAR;
 799
 800     switch (o->op_type) {
 801     case OP_NULL:       /* Was holding old type, if any. */
 802         /* FALLTHROUGH */
 803     case OP_ENTERTRY:
 804     case OP_ENTEREVAL:  /* Was holding hints. */
 805         o->op_targ = 0;
 806         break;
 807     default:
 808         if (!(o->op_flags & OPf_REF)
 809             || (PL_check[o->op_type] != Perl_ck_ftst))
 810             break;
 811         /* FALLTHROUGH */
 812     case OP_GVSV:
 813     case OP_GV:
 814     case OP_AELEMFAST:
 815         {
 816             GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
 817 #ifdef USE_ITHREADS
 818                         && PL_curpad
 819 #endif
 820                         ? cGVOPo_gv : NULL;
 821             /* It's possible during global destruction that the GV is freed
 822                before the optree. Whilst the SvREFCNT_inc is happy to bump from
 823                0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
 824                will trigger an assertion failure, because the entry to sv_clear
 825                checks that the scalar is not already freed.  A check of for
 826                !SvIS_FREED(gv) turns out to be invalid, because during global
 827                destruction the reference count can be forced down to zero
 828                (with SVf_BREAK set).  In which case raising to 1 and then
 829                dropping to 0 triggers cleanup before it should happen.  I
 830                *think* that this might actually be a general, systematic,
 831                weakness of the whole idea of SVf_BREAK, in that code *is*
 832                allowed to raise and lower references during global destruction,
 833                so any *valid* code that happens to do this during global
 834                destruction might well trigger premature cleanup.  */
 835             bool still_valid = gv && SvREFCNT(gv);
 836
 837             if (still_valid)
 838                 SvREFCNT_inc_simple_void(gv);
 839 #ifdef USE_ITHREADS
 840             if (cPADOPo->op_padix > 0) {
 841                 pad_swipe(cPADOPo->op_padix, TRUE);
 842                 cPADOPo->op_padix = 0;
 843             }
 844 #else
 845             SvREFCNT_dec(cSVOPo->op_sv);
 846             cSVOPo->op_sv = NULL;
 847 #endif
 848             if (still_valid) {
 849                 int try_downgrade = SvREFCNT(gv) == 2;
 850                 SvREFCNT_dec_NN(gv);
 851                 if (try_downgrade)
 852                     gv_try_downgrade(gv);
 853             }
 854         }
 855         break;
 856     case OP_METHOD_NAMED:
 857         SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
 858         cMETHOPx(o)->op_u.op_meth_sv = NULL;
 859 #ifdef USE_ITHREADS
 860         if (o->op_targ) {
 861             pad_swipe(o->op_targ, 1);
 862             o->op_targ = 0;
 863         }
 864 #endif
 865         break;
 866     case OP_CONST:
 867     case OP_HINTSEVAL:
 868         SvREFCNT_dec(cSVOPo->op_sv);
 869         cSVOPo->op_sv = NULL;
 870 #ifdef USE_ITHREADS
 871         /** Bug #15654
 872           Even if op_clear does a pad_free for the target of the op,
 873           pad_free doesn't actually remove the sv that exists in the pad;
 874           instead it lives on. This results in that it could be reused as
 875           a target later on when the pad was reallocated.
 876         **/
 877         if(o->op_targ) {
 878           pad_swipe(o->op_targ,1);
 879           o->op_targ = 0;
 880         }
 881 #endif
 882         break;
 883     case OP_DUMP:
 884     case OP_GOTO:
 885     case OP_NEXT:
 886     case OP_LAST:
 887     case OP_REDO:
 888         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
 889             break;
 890         /* FALLTHROUGH */
 891     case OP_TRANS:
 892     case OP_TRANSR:
 893         if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
 894             assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
 895 #ifdef USE_ITHREADS
 896             if (cPADOPo->op_padix > 0) {
 897                 pad_swipe(cPADOPo->op_padix, TRUE);
 898                 cPADOPo->op_padix = 0;
 899             }
 900 #else
 901             SvREFCNT_dec(cSVOPo->op_sv);
 902             cSVOPo->op_sv = NULL;
 903 #endif
 904         }
 905         else {
 906             PerlMemShared_free(cPVOPo->op_pv);
 907             cPVOPo->op_pv = NULL;
 908         }
 909         break;
 910     case OP_SUBST:
 911         op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
 912         goto clear_pmop;
 913     case OP_PUSHRE:
 914 #ifdef USE_ITHREADS
 915         if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
 916             pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
 917         }
 918 #else
 919         SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
 920 #endif
 921         /* FALLTHROUGH */
 922     case OP_MATCH:
 923     case OP_QR:
 924 clear_pmop:
 925         if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
 926             op_free(cPMOPo->op_code_list);
 927         cPMOPo->op_code_list = NULL;
 928         forget_pmop(cPMOPo);
 929         cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
 930         /* we use the same protection as the "SAFE" version of the PM_ macros
 931          * here since sv_clean_all might release some PMOPs
 932          * after PL_regex_padav has been cleared
 933          * and the clearing of PL_regex_padav needs to
 934          * happen before sv_clean_all
 935          */
 936 #ifdef USE_ITHREADS
 937         if(PL_regex_pad) {        /* We could be in destruction */
 938             const IV offset = (cPMOPo)->op_pmoffset;
 939             ReREFCNT_dec(PM_GETRE(cPMOPo));
 940             PL_regex_pad[offset] = &PL_sv_undef;
 941             sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
 942                            sizeof(offset));
 943         }
 944 #else
 945         ReREFCNT_dec(PM_GETRE(cPMOPo));
 946         PM_SETRE(cPMOPo, NULL);
 947 #endif
 948
 949         break;
 950     }
 951
 952     if (o->op_targ > 0) {
 953         pad_free(o->op_targ);
 954         o->op_targ = 0;
 955     }
 956 }
 957
 958 STATIC void
 959 S_cop_free(pTHX_ COP* cop)
 960 {
 961     PERL_ARGS_ASSERT_COP_FREE;
 962
 963     CopFILE_free(cop);
 964     if (! specialWARN(cop->cop_warnings))
 965         PerlMemShared_free(cop->cop_warnings);
 966     cophh_free(CopHINTHASH_get(cop));
 967     if (PL_curcop == cop)
 968        PL_curcop = NULL;
 969 }
 970
 971 STATIC void
 972 S_forget_pmop(pTHX_ PMOP *const o
 973               )
 974 {
 975     HV * const pmstash = PmopSTASH(o);
 976
 977     PERL_ARGS_ASSERT_FORGET_PMOP;
 978
 979     if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
 980         MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
 981         if (mg) {
 982             PMOP **const array = (PMOP**) mg->mg_ptr;
 983             U32 count = mg->mg_len / sizeof(PMOP**);
 984             U32 i = count;
 985
 986             while (i--) {
 987                 if (array[i] == o) {
 988                     /* Found it. Move the entry at the end to overwrite it.  */
 989                     array[i] = array[--count];
 990                     mg->mg_len = count * sizeof(PMOP**);
 991                     /* Could realloc smaller at this point always, but probably
 992                        not worth it. Probably worth free()ing if we're the
 993                        last.  */
 994                     if(!count) {
 995                         Safefree(mg->mg_ptr);
 996                         mg->mg_ptr = NULL;
 997                     }
 998                     break;
 999                 }
1000             }
1001         }
1002     }
1003     if (PL_curpm == o)
1004         PL_curpm = NULL;
1005 }
1006
1007 STATIC void
1008 S_find_and_forget_pmops(pTHX_ OP *o)
1009 {
1010     PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1011
1012     if (o->op_flags & OPf_KIDS) {
1013         OP *kid = cUNOPo->op_first;
1014         while (kid) {
1015             switch (kid->op_type) {
1016             case OP_SUBST:
1017             case OP_PUSHRE:
1018             case OP_MATCH:
1019             case OP_QR:
1020                 forget_pmop((PMOP*)kid);
1021             }
1022             find_and_forget_pmops(kid);
1023             kid = OP_SIBLING(kid);
1024         }
1025     }
1026 }
1027
1028 /*
1029 =for apidoc Am|void|op_null|OP *o
1030
1031 Neutralizes an op when it is no longer needed, but is still linked to from
1032 other ops.
1033
1034 =cut
1035 */
1036
1037 void
1038 Perl_op_null(pTHX_ OP *o)
1039 {
1040     dVAR;
1041
1042     PERL_ARGS_ASSERT_OP_NULL;
1043
1044     if (o->op_type == OP_NULL)
1045         return;
1046     op_clear(o);
1047     o->op_targ = o->op_type;
1048     CHANGE_TYPE(o, OP_NULL);
1049 }
1050
1051 void
1052 Perl_op_refcnt_lock(pTHX)
1053 {
1054 #ifdef USE_ITHREADS
1055     dVAR;
1056 #endif
1057     PERL_UNUSED_CONTEXT;
1058     OP_REFCNT_LOCK;
1059 }
1060
1061 void
1062 Perl_op_refcnt_unlock(pTHX)
1063 {
1064 #ifdef USE_ITHREADS
1065     dVAR;
1066 #endif
1067     PERL_UNUSED_CONTEXT;
1068     OP_REFCNT_UNLOCK;
1069 }
1070
1071
1072 /*
1073 =for apidoc op_sibling_splice
1074
1075 A general function for editing the structure of an existing chain of
1076 op_sibling nodes.  By analogy with the perl-level splice() function, allows
1077 you to delete zero or more sequential nodes, replacing them with zero or
1078 more different nodes.  Performs the necessary op_first/op_last
1079 housekeeping on the parent node and op_sibling manipulation on the
1080 children.  The last deleted node will be marked as as the last node by
1081 updating the op_sibling or op_lastsib field as appropriate.
1082
1083 Note that op_next is not manipulated, and nodes are not freed; that is the
1084 responsibility of the caller.  It also won't create a new list op for an
1085 empty list etc; use higher-level functions like op_append_elem() for that.
1086
1087 parent is the parent node of the sibling chain.
1088
1089 start is the node preceding the first node to be spliced.  Node(s)
1090 following it will be deleted, and ops will be inserted after it.  If it is
1091 NULL, the first node onwards is deleted, and nodes are inserted at the
1092 beginning.
1093
1094 del_count is the number of nodes to delete.  If zero, no nodes are deleted.
1095 If -1 or greater than or equal to the number of remaining kids, all
1096 remaining kids are deleted.
1097
1098 insert is the first of a chain of nodes to be inserted in place of the nodes.
1099 If NULL, no nodes are inserted.
1100
1101 The head of the chain of deleted ops is returned, or NULL if no ops were
1102 deleted.
1103
1104 For example:
1105
1106     action                    before      after         returns
1107     ------                    -----       -----         -------
1108
1109                               P           P
1110     splice(P, A, 2, X-Y-Z)    |           |             B-C
1111                               A-B-C-D     A-X-Y-Z-D
1112
1113                               P           P
1114     splice(P, NULL, 1, X-Y)   |           |             A
1115                               A-B-C-D     X-Y-B-C-D
1116
1117                               P           P
1118     splice(P, NULL, 3, NULL)  |           |             A-B-C
1119                               A-B-C-D     D
1120
1121                               P           P
1122     splice(P, B, 0, X-Y)      |           |             NULL
1123                               A-B-C-D     A-B-X-Y-C-D
1124
1125 =cut
1126 */
1127
1128 OP *
1129 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1130 {
1131     OP *first = start ? OP_SIBLING(start) : cLISTOPx(parent)->op_first;
1132     OP *rest;
1133     OP *last_del = NULL;
1134     OP *last_ins = NULL;
1135
1136     PERL_ARGS_ASSERT_OP_SIBLING_SPLICE;
1137
1138     assert(del_count >= -1);
1139
1140     if (del_count && first) {
1141         last_del = first;
1142         while (--del_count && OP_HAS_SIBLING(last_del))
1143             last_del = OP_SIBLING(last_del);
1144         rest = OP_SIBLING(last_del);
1145         OP_SIBLING_set(last_del, NULL);
1146         last_del->op_lastsib = 1;
1147     }
1148     else
1149         rest = first;
1150
1151     if (insert) {
1152         last_ins = insert;
1153         while (OP_HAS_SIBLING(last_ins))
1154             last_ins = OP_SIBLING(last_ins);
1155         OP_SIBLING_set(last_ins, rest);
1156         last_ins->op_lastsib = rest ? 0 : 1;
1157     }
1158     else
1159         insert = rest;
1160
1161     if (start) {
1162         OP_SIBLING_set(start, insert);
1163         start->op_lastsib = insert ? 0 : 1;
1164     }
1165     else
1166         cLISTOPx(parent)->op_first = insert;
1167
1168     if (!rest) {
1169         /* update op_last etc */
1170         U32 type = parent->op_type;
1171         OP *lastop;
1172
1173         if (type == OP_NULL)
1174             type = parent->op_targ;
1175         type = PL_opargs[type] & OA_CLASS_MASK;
1176
1177         lastop = last_ins ? last_ins : start ? start : NULL;
1178         if (   type == OA_BINOP
1179             || type == OA_LISTOP
1180             || type == OA_PMOP
1181             || type == OA_LOOP
1182         )
1183             cLISTOPx(parent)->op_last = lastop;
1184
1185         if (lastop) {
1186             lastop->op_lastsib = 1;
1187 #ifdef PERL_OP_PARENT
1188             lastop->op_sibling = parent;
1189 #endif
1190         }
1191     }
1192     return last_del ? first : NULL;
1193 }
1194
1195 /*
1196 =for apidoc op_parent
1197
1198 returns the parent OP of o, if it has a parent.  Returns NULL otherwise.
1199 (Currently perl must be built with C<-DPERL_OP_PARENT> for this feature to
1200 work.
1201
1202 =cut
1203 */
1204
1205 OP *
1206 Perl_op_parent(OP *o)
1207 {
1208     PERL_ARGS_ASSERT_OP_PARENT;
1209 #ifdef PERL_OP_PARENT
1210     while (OP_HAS_SIBLING(o))
1211         o = OP_SIBLING(o);
1212     return o->op_sibling;
1213 #else
1214     PERL_UNUSED_ARG(o);
1215     return NULL;
1216 #endif
1217 }
1218
1219
1220 /* replace the sibling following start with a new UNOP, which becomes
1221  * the parent of the original sibling; e.g.
1222  *
1223  *  op_sibling_newUNOP(P, A, unop-args...)
1224  *
1225  *  P              P
1226  *  |      becomes |
1227  *  A-B-C          A-U-C
1228  *                   |
1229  *                   B
1230  *
1231  * where U is the new UNOP.
1232  *
1233  * parent and start args are the same as for op_sibling_splice();
1234  * type and flags args are as newUNOP().
1235  *
1236  * Returns the new UNOP.
1237  */
1238
1239 OP *
1240 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1241 {
1242     OP *kid, *newop;
1243
1244     kid = op_sibling_splice(parent, start, 1, NULL);
1245     newop = newUNOP(type, flags, kid);
1246     op_sibling_splice(parent, start, 0, newop);
1247     return newop;
1248 }
1249
1250
1251 /* lowest-level newLOGOP-style function - just allocates and populates
1252  * the struct. Higher-level stuff should be done by S_new_logop() /
1253  * newLOGOP(). This function exists mainly to avoid op_first assignment
1254  * being spread throughout this file.
1255  */
1256
1257 LOGOP *
1258 S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1259 {
1260     dVAR;
1261     LOGOP *logop;
1262     OP *kid = first;
1263     NewOp(1101, logop, 1, LOGOP);
1264     CHANGE_TYPE(logop, type);
1265     logop->op_first = first;
1266     logop->op_other = other;
1267     logop->op_flags = OPf_KIDS;
1268     while (kid && OP_HAS_SIBLING(kid))
1269         kid = OP_SIBLING(kid);
1270     if (kid) {
1271         kid->op_lastsib = 1;
1272 #ifdef PERL_OP_PARENT
1273         kid->op_sibling = (OP*)logop;
1274 #endif
1275     }
1276     return logop;
1277 }
1278
1279
1280 /* Contextualizers */
1281
1282 /*
1283 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1284
1285 Applies a syntactic context to an op tree representing an expression.
1286 I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
1287 or C<G_VOID> to specify the context to apply.  The modified op tree
1288 is returned.
1289
1290 =cut
1291 */
1292
1293 OP *
1294 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1295 {
1296     PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1297     switch (context) {
1298         case G_SCALAR: return scalar(o);
1299         case G_ARRAY:  return list(o);
1300         case G_VOID:   return scalarvoid(o);
1301         default:
1302             Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1303                        (long) context);
1304     }
1305 }
1306
1307 /*
1308
1309 =for apidoc Am|OP*|op_linklist|OP *o
1310 This function is the implementation of the L</LINKLIST> macro.  It should
1311 not be called directly.
1312
1313 =cut
1314 */
1315
1316 OP *
1317 Perl_op_linklist(pTHX_ OP *o)
1318 {
1319     OP *first;
1320
1321     PERL_ARGS_ASSERT_OP_LINKLIST;
1322
1323     if (o->op_next)
1324         return o->op_next;
1325
1326     /* establish postfix order */
1327     first = cUNOPo->op_first;
1328     if (first) {
1329         OP *kid;
1330         o->op_next = LINKLIST(first);
1331         kid = first;
1332         for (;;) {
1333             OP *sibl = OP_SIBLING(kid);
1334             if (sibl) {
1335                 kid->op_next = LINKLIST(sibl);
1336                 kid = sibl;
1337             } else {
1338                 kid->op_next = o;
1339                 break;
1340             }
1341         }
1342     }
1343     else
1344         o->op_next = o;
1345
1346     return o->op_next;
1347 }
1348
1349 static OP *
1350 S_scalarkids(pTHX_ OP *o)
1351 {
1352     if (o && o->op_flags & OPf_KIDS) {
1353         OP *kid;
1354         for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
1355             scalar(kid);
1356     }
1357     return o;
1358 }
1359
1360 STATIC OP *
1361 S_scalarboolean(pTHX_ OP *o)
1362 {
1363     PERL_ARGS_ASSERT_SCALARBOOLEAN;
1364
1365     if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
1366      && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
1367         if (ckWARN(WARN_SYNTAX)) {
1368             const line_t oldline = CopLINE(PL_curcop);
1369
1370             if (PL_parser && PL_parser->copline != NOLINE) {
1371                 /* This ensures that warnings are reported at the first line
1372                    of the conditional, not the last.  */
1373                 CopLINE_set(PL_curcop, PL_parser->copline);
1374             }
1375             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1376             CopLINE_set(PL_curcop, oldline);
1377         }
1378     }
1379     return scalar(o);
1380 }
1381
1382 static SV *
1383 S_op_varname(pTHX_ const OP *o)
1384 {
1385     assert(o);
1386     assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1387            o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1388     {
1389         const char funny  = o->op_type == OP_PADAV
1390                          || o->op_type == OP_RV2AV ? '@' : '%';
1391         if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1392             GV *gv;
1393             if (cUNOPo->op_first->op_type != OP_GV
1394              || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1395                 return NULL;
1396             return varname(gv, funny, 0, NULL, 0, 1);
1397         }
1398         return
1399             varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, 1);
1400     }
1401 }
1402
1403 static void
1404 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1405 { /* or not so pretty :-) */
1406     if (o->op_type == OP_CONST) {
1407         *retsv = cSVOPo_sv;
1408         if (SvPOK(*retsv)) {
1409             SV *sv = *retsv;
1410             *retsv = sv_newmortal();
1411             pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1412                       PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1413         }
1414         else if (!SvOK(*retsv))
1415             *retpv = "undef";
1416     }
1417     else *retpv = "...";
1418 }
1419
1420 static void
1421 S_scalar_slice_warning(pTHX_ const OP *o)
1422 {
1423     OP *kid;
1424     const char lbrack =
1425         o->op_type == OP_HSLICE ? '{' : '[';
1426     const char rbrack =
1427         o->op_type == OP_HSLICE ? '}' : ']';
1428     SV *name;
1429     SV *keysv = NULL; /* just to silence compiler warnings */
1430     const char *key = NULL;
1431
1432     if (!(o->op_private & OPpSLICEWARNING))
1433         return;
1434     if (PL_parser && PL_parser->error_count)
1435         /* This warning can be nonsensical when there is a syntax error. */
1436         return;
1437
1438     kid = cLISTOPo->op_first;
1439     kid = OP_SIBLING(kid); /* get past pushmark */
1440     /* weed out false positives: any ops that can return lists */
1441     switch (kid->op_type) {
1442     case OP_BACKTICK:
1443     case OP_GLOB:
1444     case OP_READLINE:
1445     case OP_MATCH:
1446     case OP_RV2AV:
1447     case OP_EACH:
1448     case OP_VALUES:
1449     case OP_KEYS:
1450     case OP_SPLIT:
1451     case OP_LIST:
1452     case OP_SORT:
1453     case OP_REVERSE:
1454     case OP_ENTERSUB:
1455     case OP_CALLER:
1456     case OP_LSTAT:
1457     case OP_STAT:
1458     case OP_READDIR:
1459     case OP_SYSTEM:
1460     case OP_TMS:
1461     case OP_LOCALTIME:
1462     case OP_GMTIME:
1463     case OP_ENTEREVAL:
1464     case OP_REACH:
1465     case OP_RKEYS:
1466     case OP_RVALUES:
1467         return;
1468     }
1469
1470     /* Don't warn if we have a nulled list either. */
1471     if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1472         return;
1473
1474     assert(OP_SIBLING(kid));
1475     name = S_op_varname(aTHX_ OP_SIBLING(kid));
1476     if (!name) /* XS module fiddling with the op tree */
1477         return;
1478     S_op_pretty(aTHX_ kid, &keysv, &key);
1479     assert(SvPOK(name));
1480     sv_chop(name,SvPVX(name)+1);
1481     if (key)
1482        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1483         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1484                    "Scalar value @%"SVf"%c%s%c better written as $%"SVf
1485                    "%c%s%c",
1486                     SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1487                     lbrack, key, rbrack);
1488     else
1489        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1490         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1491                    "Scalar value @%"SVf"%c%"SVf"%c better written as $%"
1492                     SVf"%c%"SVf"%c",
1493                     SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1494                     SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1495 }
1496
1497 OP *
1498 Perl_scalar(pTHX_ OP *o)
1499 {
1500     OP *kid;
1501
1502     /* assumes no premature commitment */
1503     if (!o || (PL_parser && PL_parser->error_count)
1504          || (o->op_flags & OPf_WANT)
1505          || o->op_type == OP_RETURN)
1506     {
1507         return o;
1508     }
1509
1510     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1511
1512     switch (o->op_type) {
1513     case OP_REPEAT:
1514         scalar(cBINOPo->op_first);
1515         if (o->op_private & OPpREPEAT_DOLIST) {
1516             kid = cLISTOPx(cUNOPo->op_first)->op_first;
1517             assert(kid->op_type == OP_PUSHMARK);
1518             if (OP_HAS_SIBLING(kid) && !OP_HAS_SIBLING(OP_SIBLING(kid))) {
1519                 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1520                 o->op_private &=~ OPpREPEAT_DOLIST;
1521             }
1522         }
1523         break;
1524     case OP_OR:
1525     case OP_AND:
1526     case OP_COND_EXPR:
1527         for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
1528             scalar(kid);
1529         break;
1530         /* FALLTHROUGH */
1531     case OP_SPLIT:
1532     case OP_MATCH:
1533     case OP_QR:
1534     case OP_SUBST:
1535     case OP_NULL:
1536     default:
1537         if (o->op_flags & OPf_KIDS) {
1538             for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid))
1539                 scalar(kid);
1540         }
1541         break;
1542     case OP_LEAVE:
1543     case OP_LEAVETRY:
1544         kid = cLISTOPo->op_first;
1545         scalar(kid);
1546         kid = OP_SIBLING(kid);
1547     do_kids:
1548         while (kid) {
1549             OP *sib = OP_SIBLING(kid);
1550             if (sib && kid->op_type != OP_LEAVEWHEN)
1551                 scalarvoid(kid);
1552             else
1553                 scalar(kid);
1554             kid = sib;
1555         }
1556         PL_curcop = &PL_compiling;
1557         break;
1558     case OP_SCOPE:
1559     case OP_LINESEQ:
1560     case OP_LIST:
1561         kid = cLISTOPo->op_first;
1562         goto do_kids;
1563     case OP_SORT:
1564         Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1565         break;
1566     case OP_KVHSLICE:
1567     case OP_KVASLICE:
1568     {
1569         /* Warn about scalar context */
1570         const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1571         const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1572         SV *name;
1573         SV *keysv;
1574         const char *key = NULL;
1575
1576         /* This warning can be nonsensical when there is a syntax error. */
1577         if (PL_parser && PL_parser->error_count)
1578             break;
1579
1580         if (!ckWARN(WARN_SYNTAX)) break;
1581
1582         kid = cLISTOPo->op_first;
1583         kid = OP_SIBLING(kid); /* get past pushmark */
1584         assert(OP_SIBLING(kid));
1585         name = S_op_varname(aTHX_ OP_SIBLING(kid));
1586         if (!name) /* XS module fiddling with the op tree */
1587             break;
1588         S_op_pretty(aTHX_ kid, &keysv, &key);
1589         assert(SvPOK(name));
1590         sv_chop(name,SvPVX(name)+1);
1591         if (key)
1592   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1593             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1594                        "%%%"SVf"%c%s%c in scalar context better written "
1595                        "as $%"SVf"%c%s%c",
1596                         SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1597                         lbrack, key, rbrack);
1598         else
1599   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1600             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1601                        "%%%"SVf"%c%"SVf"%c in scalar context better "
1602                        "written as $%"SVf"%c%"SVf"%c",
1603                         SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1604                         SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1605     }
1606     }
1607     return o;
1608 }
1609
1610 OP *
1611 Perl_scalarvoid(pTHX_ OP *arg)
1612 {
1613     dVAR;
1614     OP *kid;
1615     SV* sv;
1616     U8 want;
1617     SSize_t defer_stack_alloc = 0;
1618     SSize_t defer_ix = -1;
1619     OP **defer_stack = NULL;
1620     OP *o = arg;
1621
1622     PERL_ARGS_ASSERT_SCALARVOID;
1623
1624     do {
1625         SV *useless_sv = NULL;
1626         const char* useless = NULL;
1627
1628         if (o->op_type == OP_NEXTSTATE
1629             || o->op_type == OP_DBSTATE
1630             || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1631                                           || o->op_targ == OP_DBSTATE)))
1632             PL_curcop = (COP*)o;                /* for warning below */
1633
1634         /* assumes no premature commitment */
1635         want = o->op_flags & OPf_WANT;
1636         if ((want && want != OPf_WANT_SCALAR)
1637             || (PL_parser && PL_parser->error_count)
1638             || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1639         {
1640             continue;
1641         }
1642
1643         if ((o->op_private & OPpTARGET_MY)
1644             && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1645         {
1646             /* newASSIGNOP has already applied scalar context, which we
1647                leave, as if this op is inside SASSIGN.  */
1648             continue;
1649         }
1650
1651         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1652
1653         switch (o->op_type) {
1654         default:
1655             if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1656                 break;
1657             /* FALLTHROUGH */
1658         case OP_REPEAT:
1659             if (o->op_flags & OPf_STACKED)
1660                 break;
1661             goto func_ops;
1662         case OP_SUBSTR:
1663             if (o->op_private == 4)
1664                 break;
1665             /* FALLTHROUGH */
1666         case OP_WANTARRAY:
1667         case OP_GV:
1668         case OP_SMARTMATCH:
1669         case OP_AV2ARYLEN:
1670         case OP_REF:
1671         case OP_REFGEN:
1672         case OP_SREFGEN:
1673         case OP_DEFINED:
1674         case OP_HEX:
1675         case OP_OCT:
1676         case OP_LENGTH:
1677         case OP_VEC:
1678         case OP_INDEX:
1679         case OP_RINDEX:
1680         case OP_SPRINTF:
1681         case OP_KVASLICE:
1682         case OP_KVHSLICE:
1683         case OP_UNPACK:
1684         case OP_PACK:
1685         case OP_JOIN:
1686         case OP_LSLICE:
1687         case OP_ANONLIST:
1688         case OP_ANONHASH:
1689         case OP_SORT:
1690         case OP_REVERSE:
1691         case OP_RANGE:
1692         case OP_FLIP:
1693         case OP_FLOP:
1694         case OP_CALLER:
1695         case OP_FILENO:
1696         case OP_EOF:
1697         case OP_TELL:
1698         case OP_GETSOCKNAME:
1699         case OP_GETPEERNAME:
1700         case OP_READLINK:
1701         case OP_TELLDIR:
1702         case OP_GETPPID:
1703         case OP_GETPGRP:
1704         case OP_GETPRIORITY:
1705         case OP_TIME:
1706         case OP_TMS:
1707         case OP_LOCALTIME:
1708         case OP_GMTIME:
1709         case OP_GHBYNAME:
1710         case OP_GHBYADDR:
1711         case OP_GHOSTENT:
1712         case OP_GNBYNAME:
1713         case OP_GNBYADDR:
1714         case OP_GNETENT:
1715         case OP_GPBYNAME:
1716         case OP_GPBYNUMBER:
1717         case OP_GPROTOENT:
1718         case OP_GSBYNAME:
1719         case OP_GSBYPORT:
1720         case OP_GSERVENT:
1721         case OP_GPWNAM:
1722         case OP_GPWUID:
1723         case OP_GGRNAM:
1724         case OP_GGRGID:
1725         case OP_GETLOGIN:
1726         case OP_PROTOTYPE:
1727         case OP_RUNCV:
1728         func_ops:
1729             useless = OP_DESC(o);
1730             break;
1731
1732         case OP_GVSV:
1733         case OP_PADSV:
1734         case OP_PADAV:
1735         case OP_PADHV:
1736         case OP_PADANY:
1737         case OP_AELEM:
1738         case OP_AELEMFAST:
1739         case OP_AELEMFAST_LEX:
1740         case OP_ASLICE:
1741         case OP_HELEM:
1742         case OP_HSLICE:
1743             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1744                 /* Otherwise it's "Useless use of grep iterator" */
1745                 useless = OP_DESC(o);
1746             break;
1747
1748         case OP_SPLIT:
1749             kid = cLISTOPo->op_first;
1750             if (kid && kid->op_type == OP_PUSHRE
1751                 && !kid->op_targ
1752                 && !(o->op_flags & OPf_STACKED)
1753 #ifdef USE_ITHREADS
1754                 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
1755 #else
1756                 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
1757 #endif
1758                 )
1759                 useless = OP_DESC(o);
1760             break;
1761
1762         case OP_NOT:
1763             kid = cUNOPo->op_first;
1764             if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1765                 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1766                 goto func_ops;
1767             }
1768             useless = "negative pattern binding (!~)";
1769             break;
1770
1771         case OP_SUBST:
1772             if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1773                 useless = "non-destructive substitution (s///r)";
1774             break;
1775
1776         case OP_TRANSR:
1777             useless = "non-destructive transliteration (tr///r)";
1778             break;
1779
1780         case OP_RV2GV:
1781         case OP_RV2SV:
1782         case OP_RV2AV:
1783         case OP_RV2HV:
1784             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1785                 (!OP_HAS_SIBLING(o) || OP_SIBLING(o)->op_type != OP_READLINE))
1786                 useless = "a variable";
1787             break;
1788
1789         case OP_CONST:
1790             sv = cSVOPo_sv;
1791             if (cSVOPo->op_private & OPpCONST_STRICT)
1792                 no_bareword_allowed(o);
1793             else {
1794                 if (ckWARN(WARN_VOID)) {
1795                     NV nv;
1796                     /* don't warn on optimised away booleans, eg
1797                      * use constant Foo, 5; Foo || print; */
1798                     if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1799                         useless = NULL;
1800                     /* the constants 0 and 1 are permitted as they are
1801                        conventionally used as dummies in constructs like
1802                        1 while some_condition_with_side_effects;  */
1803                     else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
1804                         useless = NULL;
1805                     else if (SvPOK(sv)) {
1806                         SV * const dsv = newSVpvs("");
1807                         useless_sv
1808                             = Perl_newSVpvf(aTHX_
1809                                             "a constant (%s)",
1810                                             pv_pretty(dsv, SvPVX_const(sv),
1811                                                       SvCUR(sv), 32, NULL, NULL,
1812                                                       PERL_PV_PRETTY_DUMP
1813                                                       | PERL_PV_ESCAPE_NOCLEAR
1814                                                       | PERL_PV_ESCAPE_UNI_DETECT));
1815                         SvREFCNT_dec_NN(dsv);
1816                     }
1817                     else if (SvOK(sv)) {
1818                         useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", SVfARG(sv));
1819                     }
1820                     else
1821                         useless = "a constant (undef)";
1822                 }
1823             }
1824             op_null(o);         /* don't execute or even remember it */
1825             break;
1826
1827         case OP_POSTINC:
1828             CHANGE_TYPE(o, OP_PREINC);  /* pre-increment is faster */
1829             break;
1830
1831         case OP_POSTDEC:
1832             CHANGE_TYPE(o, OP_PREDEC);  /* pre-decrement is faster */
1833             break;
1834
1835         case OP_I_POSTINC:
1836             CHANGE_TYPE(o, OP_I_PREINC);        /* pre-increment is faster */
1837             break;
1838
1839         case OP_I_POSTDEC:
1840             CHANGE_TYPE(o, OP_I_PREDEC);        /* pre-decrement is faster */
1841             break;
1842
1843         case OP_SASSIGN: {
1844             OP *rv2gv;
1845             UNOP *refgen, *rv2cv;
1846             LISTOP *exlist;
1847
1848             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
1849                 break;
1850
1851             rv2gv = ((BINOP *)o)->op_last;
1852             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
1853                 break;
1854
1855             refgen = (UNOP *)((BINOP *)o)->op_first;
1856
1857             if (!refgen || (refgen->op_type != OP_REFGEN
1858                             && refgen->op_type != OP_SREFGEN))
1859                 break;
1860
1861             exlist = (LISTOP *)refgen->op_first;
1862             if (!exlist || exlist->op_type != OP_NULL
1863                 || exlist->op_targ != OP_LIST)
1864                 break;
1865
1866             if (exlist->op_first->op_type != OP_PUSHMARK
1867                 && exlist->op_first != exlist->op_last)
1868                 break;
1869
1870             rv2cv = (UNOP*)exlist->op_last;
1871
1872             if (rv2cv->op_type != OP_RV2CV)
1873                 break;
1874
1875             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
1876             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
1877             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
1878
1879             o->op_private |= OPpASSIGN_CV_TO_GV;
1880             rv2gv->op_private |= OPpDONT_INIT_GV;
1881             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
1882
1883             break;
1884         }
1885
1886         case OP_AASSIGN: {
1887             inplace_aassign(o);
1888             break;
1889         }
1890
1891         case OP_OR:
1892         case OP_AND:
1893             kid = cLOGOPo->op_first;
1894             if (kid->op_type == OP_NOT
1895                 && (kid->op_flags & OPf_KIDS)) {
1896                 if (o->op_type == OP_AND) {
1897                     CHANGE_TYPE(o, OP_OR);
1898                 } else {
1899                     CHANGE_TYPE(o, OP_AND);
1900                 }
1901                 op_null(kid);
1902             }
1903             /* FALLTHROUGH */
1904
1905         case OP_DOR:
1906         case OP_COND_EXPR:
1907         case OP_ENTERGIVEN:
1908         case OP_ENTERWHEN:
1909             for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
1910                 if (!(kid->op_flags & OPf_KIDS))
1911                     scalarvoid(kid);
1912                 else
1913                     DEFER_OP(kid);
1914         break;
1915
1916         case OP_NULL:
1917             if (o->op_flags & OPf_STACKED)
1918                 break;
1919             /* FALLTHROUGH */
1920         case OP_NEXTSTATE:
1921         case OP_DBSTATE:
1922         case OP_ENTERTRY:
1923         case OP_ENTER:
1924             if (!(o->op_flags & OPf_KIDS))
1925                 break;
1926             /* FALLTHROUGH */
1927         case OP_SCOPE:
1928         case OP_LEAVE:
1929         case OP_LEAVETRY:
1930         case OP_LEAVELOOP:
1931         case OP_LINESEQ:
1932         case OP_LEAVEGIVEN:
1933         case OP_LEAVEWHEN:
1934         kids:
1935             for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
1936                 if (!(kid->op_flags & OPf_KIDS))
1937                     scalarvoid(kid);
1938                 else
1939                     DEFER_OP(kid);
1940             break;
1941         case OP_LIST:
1942             /* If the first kid after pushmark is something that the padrange
1943                optimisation would reject, then null the list and the pushmark.
1944             */
1945             if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
1946                 && (  !(kid = OP_SIBLING(kid))
1947                       || (  kid->op_type != OP_PADSV
1948                             && kid->op_type != OP_PADAV
1949                             && kid->op_type != OP_PADHV)
1950                       || kid->op_private & ~OPpLVAL_INTRO
1951                       || !(kid = OP_SIBLING(kid))
1952                       || (  kid->op_type != OP_PADSV
1953                             && kid->op_type != OP_PADAV
1954                             && kid->op_type != OP_PADHV)
1955                       || kid->op_private & ~OPpLVAL_INTRO)
1956             ) {
1957                 op_null(cUNOPo->op_first); /* NULL the pushmark */
1958                 op_null(o); /* NULL the list */
1959             }
1960             goto kids;
1961         case OP_ENTEREVAL:
1962             scalarkids(o);
1963             break;
1964         case OP_SCALAR:
1965             scalar(o);
1966             break;
1967         }
1968
1969         if (useless_sv) {
1970             /* mortalise it, in case warnings are fatal.  */
1971             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1972                            "Useless use of %"SVf" in void context",
1973                            SVfARG(sv_2mortal(useless_sv)));
1974         }
1975         else if (useless) {
1976             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1977                            "Useless use of %s in void context",
1978                            useless);
1979         }
1980     } while ( (o = POP_DEFERRED_OP()) );
1981
1982     Safefree(defer_stack);
1983
1984     return arg;
1985 }
1986
1987 static OP *
1988 S_listkids(pTHX_ OP *o)
1989 {
1990     if (o && o->op_flags & OPf_KIDS) {
1991         OP *kid;
1992         for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
1993             list(kid);
1994     }
1995     return o;
1996 }
1997
1998 OP *
1999 Perl_list(pTHX_ OP *o)
2000 {
2001     OP *kid;
2002
2003     /* assumes no premature commitment */
2004     if (!o || (o->op_flags & OPf_WANT)
2005          || (PL_parser && PL_parser->error_count)
2006          || o->op_type == OP_RETURN)
2007     {
2008         return o;
2009     }
2010
2011     if ((o->op_private & OPpTARGET_MY)
2012         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2013     {
2014         return o;                               /* As if inside SASSIGN */
2015     }
2016
2017     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2018
2019     switch (o->op_type) {
2020     case OP_FLOP:
2021         list(cBINOPo->op_first);
2022         break;
2023     case OP_REPEAT:
2024         if (o->op_private & OPpREPEAT_DOLIST
2025          && !(o->op_flags & OPf_STACKED))
2026         {
2027             list(cBINOPo->op_first);
2028             kid = cBINOPo->op_last;
2029             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2030              && SvIVX(kSVOP_sv) == 1)
2031             {
2032                 op_null(o); /* repeat */
2033                 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2034                 /* const (rhs): */
2035                 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2036             }
2037         }
2038         break;
2039     case OP_OR:
2040     case OP_AND:
2041     case OP_COND_EXPR:
2042         for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
2043             list(kid);
2044         break;
2045     default:
2046     case OP_MATCH:
2047     case OP_QR:
2048     case OP_SUBST:
2049     case OP_NULL:
2050         if (!(o->op_flags & OPf_KIDS))
2051             break;
2052         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2053             list(cBINOPo->op_first);
2054             return gen_constant_list(o);
2055         }
2056         listkids(o);
2057         break;
2058     case OP_LIST:
2059         listkids(o);
2060         if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2061             op_null(cUNOPo->op_first); /* NULL the pushmark */
2062             op_null(o); /* NULL the list */
2063         }
2064         break;
2065     case OP_LEAVE:
2066     case OP_LEAVETRY:
2067         kid = cLISTOPo->op_first;
2068         list(kid);
2069         kid = OP_SIBLING(kid);
2070     do_kids:
2071         while (kid) {
2072             OP *sib = OP_SIBLING(kid);
2073             if (sib && kid->op_type != OP_LEAVEWHEN)
2074                 scalarvoid(kid);
2075             else
2076                 list(kid);
2077             kid = sib;
2078         }
2079         PL_curcop = &PL_compiling;
2080         break;
2081     case OP_SCOPE:
2082     case OP_LINESEQ:
2083         kid = cLISTOPo->op_first;
2084         goto do_kids;
2085     }
2086     return o;
2087 }
2088
2089 static OP *
2090 S_scalarseq(pTHX_ OP *o)
2091 {
2092     if (o) {
2093         const OPCODE type = o->op_type;
2094
2095         if (type == OP_LINESEQ || type == OP_SCOPE ||
2096             type == OP_LEAVE || type == OP_LEAVETRY)
2097         {
2098             OP *kid;
2099             for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) {
2100                 if (OP_HAS_SIBLING(kid)) {
2101                     scalarvoid(kid);
2102                 }
2103             }
2104             PL_curcop = &PL_compiling;
2105         }
2106         o->op_flags &= ~OPf_PARENS;
2107         if (PL_hints & HINT_BLOCK_SCOPE)
2108             o->op_flags |= OPf_PARENS;
2109     }
2110     else
2111         o = newOP(OP_STUB, 0);
2112     return o;
2113 }
2114
2115 STATIC OP *
2116 S_modkids(pTHX_ OP *o, I32 type)
2117 {
2118     if (o && o->op_flags & OPf_KIDS) {
2119         OP *kid;
2120         for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
2121             op_lvalue(kid, type);
2122     }
2123     return o;
2124 }
2125
2126 /*
2127 =for apidoc finalize_optree
2128
2129 This function finalizes the optree.  Should be called directly after
2130 the complete optree is built.  It does some additional
2131 checking which can't be done in the normal ck_xxx functions and makes
2132 the tree thread-safe.
2133
2134 =cut
2135 */
2136 void
2137 Perl_finalize_optree(pTHX_ OP* o)
2138 {
2139     PERL_ARGS_ASSERT_FINALIZE_OPTREE;
2140
2141     ENTER;
2142     SAVEVPTR(PL_curcop);
2143
2144     finalize_op(o);
2145
2146     LEAVE;
2147 }
2148
2149 #ifdef USE_ITHREADS
2150 /* Relocate sv to the pad for thread safety.
2151  * Despite being a "constant", the SV is written to,
2152  * for reference counts, sv_upgrade() etc. */
2153 PERL_STATIC_INLINE void
2154 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
2155 {
2156     PADOFFSET ix;
2157     PERL_ARGS_ASSERT_OP_RELOCATE_SV;
2158     if (!*svp) return;
2159     ix = pad_alloc(OP_CONST, SVf_READONLY);
2160     SvREFCNT_dec(PAD_SVl(ix));
2161     PAD_SETSV(ix, *svp);
2162     /* XXX I don't know how this isn't readonly already. */
2163     if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
2164     *svp = NULL;
2165     *targp = ix;
2166 }
2167 #endif
2168
2169
2170 STATIC void
2171 S_finalize_op(pTHX_ OP* o)
2172 {
2173     PERL_ARGS_ASSERT_FINALIZE_OP;
2174
2175
2176     switch (o->op_type) {
2177     case OP_NEXTSTATE:
2178     case OP_DBSTATE:
2179         PL_curcop = ((COP*)o);          /* for warnings */
2180         break;
2181     case OP_EXEC:
2182         if (OP_HAS_SIBLING(o)) {
2183             OP *sib = OP_SIBLING(o);
2184             if ((  sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
2185                 && ckWARN(WARN_EXEC)
2186                 && OP_HAS_SIBLING(sib))
2187             {
2188                     const OPCODE type = OP_SIBLING(sib)->op_type;
2189                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
2190                         const line_t oldline = CopLINE(PL_curcop);
2191                         CopLINE_set(PL_curcop, CopLINE((COP*)sib));
2192                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
2193                             "Statement unlikely to be reached");
2194                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
2195                             "\t(Maybe you meant system() when you said exec()?)\n");
2196                         CopLINE_set(PL_curcop, oldline);
2197                     }
2198             }
2199         }
2200         break;
2201
2202     case OP_GV:
2203         if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
2204             GV * const gv = cGVOPo_gv;
2205             if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
2206                 /* XXX could check prototype here instead of just carping */
2207                 SV * const sv = sv_newmortal();
2208                 gv_efullname3(sv, gv, NULL);
2209                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
2210                     "%"SVf"() called too early to check prototype",
2211                     SVfARG(sv));
2212             }
2213         }
2214         break;
2215
2216     case OP_CONST:
2217         if (cSVOPo->op_private & OPpCONST_STRICT)
2218             no_bareword_allowed(o);
2219         /* FALLTHROUGH */
2220 #ifdef USE_ITHREADS
2221     case OP_HINTSEVAL:
2222         op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
2223 #endif
2224         break;
2225
2226 #ifdef USE_ITHREADS
2227     /* Relocate all the METHOP's SVs to the pad for thread safety. */
2228     case OP_METHOD_NAMED:
2229         op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
2230         break;
2231 #endif
2232
2233     case OP_HELEM: {
2234         UNOP *rop;
2235         SV *lexname;
2236         GV **fields;
2237         SVOP *key_op;
2238         OP *kid;
2239         bool check_fields;
2240
2241         if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
2242             break;
2243
2244         rop = (UNOP*)((BINOP*)o)->op_first;
2245
2246         goto check_keys;
2247
2248     case OP_HSLICE:
2249         S_scalar_slice_warning(aTHX_ o);
2250         /* FALLTHROUGH */
2251
2252     case OP_KVHSLICE:
2253         kid = OP_SIBLING(cLISTOPo->op_first);
2254         if (/* I bet there's always a pushmark... */
2255             OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
2256             && OP_TYPE_ISNT_NN(kid, OP_CONST))
2257         {
2258             break;
2259         }
2260
2261         key_op = (SVOP*)(kid->op_type == OP_CONST
2262                                 ? kid
2263                                 : OP_SIBLING(kLISTOP->op_first));
2264
2265         rop = (UNOP*)((LISTOP*)o)->op_last;
2266
2267       check_keys:
2268         if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
2269             rop = NULL;
2270         else if (rop->op_first->op_type == OP_PADSV)
2271             /* @$hash{qw(keys here)} */
2272             rop = (UNOP*)rop->op_first;
2273         else {
2274             /* @{$hash}{qw(keys here)} */
2275             if (rop->op_first->op_type == OP_SCOPE
2276                 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2277                 {
2278                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2279                 }
2280             else
2281                 rop = NULL;
2282         }
2283
2284         lexname = NULL; /* just to silence compiler warnings */
2285         fields  = NULL; /* just to silence compiler warnings */
2286
2287         check_fields =
2288             rop
2289          && (lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE),
2290              SvPAD_TYPED(lexname))
2291          && (fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE))
2292          && isGV(*fields) && GvHV(*fields);
2293         for (; key_op;
2294              key_op = (SVOP*)OP_SIBLING(key_op)) {
2295             SV **svp, *sv;
2296             if (key_op->op_type != OP_CONST)
2297                 continue;
2298             svp = cSVOPx_svp(key_op);
2299
2300             /* Make the CONST have a shared SV */
2301             if ((!SvIsCOW_shared_hash(sv = *svp))
2302              && SvTYPE(sv) < SVt_PVMG && SvOK(sv) && !SvROK(sv)) {
2303                 SSize_t keylen;
2304                 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2305                 SV *nsv = newSVpvn_share(key,
2306                                          SvUTF8(sv) ? -keylen : keylen, 0);
2307                 SvREFCNT_dec_NN(sv);
2308                 *svp = nsv;
2309             }
2310
2311             if (check_fields
2312              && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0)) {
2313                 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
2314                            "in variable %"SVf" of type %"HEKf,
2315                       SVfARG(*svp), SVfARG(lexname),
2316                       HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
2317             }
2318         }
2319         break;
2320     }
2321     case OP_ASLICE:
2322         S_scalar_slice_warning(aTHX_ o);
2323         break;
2324
2325     case OP_SUBST: {
2326         if (cPMOPo->op_pmreplrootu.op_pmreplroot)
2327             finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
2328         break;
2329     }
2330     default:
2331         break;
2332     }
2333
2334     if (o->op_flags & OPf_KIDS) {
2335         OP *kid;
2336
2337 #ifdef DEBUGGING
2338         /* check that op_last points to the last sibling, and that
2339          * the last op_sibling field points back to the parent, and
2340          * that the only ops with KIDS are those which are entitled to
2341          * them */
2342         U32 type = o->op_type;
2343         U32 family;
2344         bool has_last;
2345
2346         if (type == OP_NULL) {
2347             type = o->op_targ;
2348             /* ck_glob creates a null UNOP with ex-type GLOB
2349              * (which is a list op. So pretend it wasn't a listop */
2350             if (type == OP_GLOB)
2351                 type = OP_NULL;
2352         }
2353         family = PL_opargs[type] & OA_CLASS_MASK;
2354
2355         has_last = (   family == OA_BINOP
2356                     || family == OA_LISTOP
2357                     || family == OA_PMOP
2358                     || family == OA_LOOP
2359                    );
2360         assert(  has_last /* has op_first and op_last, or ...
2361               ... has (or may have) op_first: */
2362               || family == OA_UNOP
2363               || family == OA_LOGOP
2364               || family == OA_BASEOP_OR_UNOP
2365               || family == OA_FILESTATOP
2366               || family == OA_LOOPEXOP
2367               || family == OA_METHOP
2368               /* I don't know why SASSIGN is tagged as OA_BASEOP - DAPM */
2369               || type == OP_SASSIGN
2370               || type == OP_CUSTOM
2371               || type == OP_NULL /* new_logop does this */
2372               );
2373         /* XXX list form of 'x' is has a null op_last. This is wrong,
2374          * but requires too much hacking (e.g. in Deparse) to fix for
2375          * now */
2376         if (type == OP_REPEAT && (o->op_private & OPpREPEAT_DOLIST)) {
2377             assert(has_last);
2378             has_last = 0;
2379         }
2380
2381         for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid)) {
2382 #  ifdef PERL_OP_PARENT
2383             if (!OP_HAS_SIBLING(kid)) {
2384                 if (has_last)
2385                     assert(kid == cLISTOPo->op_last);
2386                 assert(kid->op_sibling == o);
2387             }
2388 #  else
2389             if (OP_HAS_SIBLING(kid)) {
2390                 assert(!kid->op_lastsib);
2391             }
2392             else {
2393                 assert(kid->op_lastsib);
2394                 if (has_last)
2395                     assert(kid == cLISTOPo->op_last);
2396             }
2397 #  endif
2398         }
2399 #endif
2400
2401         for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid))
2402             finalize_op(kid);
2403     }
2404 }
2405
2406 /*
2407 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
2408
2409 Propagate lvalue ("modifiable") context to an op and its children.
2410 I<type> represents the context type, roughly based on the type of op that
2411 would do the modifying, although C<local()> is represented by OP_NULL,
2412 because it has no op type of its own (it is signalled by a flag on
2413 the lvalue op).
2414
2415 This function detects things that can't be modified, such as C<$x+1>, and
2416 generates errors for them.  For example, C<$x+1 = 2> would cause it to be
2417 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
2418
2419 It also flags things that need to behave specially in an lvalue context,
2420 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
2421
2422 =cut
2423 */
2424
2425 static bool
2426 S_vivifies(const OPCODE type)
2427 {
2428     switch(type) {
2429     case OP_RV2AV:     case   OP_ASLICE:
2430     case OP_RV2HV:     case OP_KVASLICE:
2431     case OP_RV2SV:     case   OP_HSLICE:
2432     case OP_AELEMFAST: case OP_KVHSLICE:
2433     case OP_HELEM:
2434     case OP_AELEM:
2435         return 1;
2436     }
2437     return 0;
2438 }
2439
2440 static void
2441 S_lvref(pTHX_ OP *o, I32 type)
2442 {
2443     dVAR;
2444     OP *kid;
2445     switch (o->op_type) {
2446     case OP_COND_EXPR:
2447         for (kid = OP_SIBLING(cUNOPo->op_first); kid;
2448              kid = OP_SIBLING(kid))
2449             S_lvref(aTHX_ kid, type);
2450         /* FALLTHROUGH */
2451     case OP_PUSHMARK:
2452         return;
2453     case OP_RV2AV:
2454         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2455         o->op_flags |= OPf_STACKED;
2456         if (o->op_flags & OPf_PARENS) {
2457             if (o->op_private & OPpLVAL_INTRO) {
2458                  yyerror(Perl_form(aTHX_ "Can't modify reference to "
2459                       "localized parenthesized array in list assignment"));
2460                 return;
2461             }
2462           slurpy:
2463             CHANGE_TYPE(o, OP_LVAVREF);
2464             o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
2465             o->op_flags |= OPf_MOD|OPf_REF;
2466             return;
2467         }
2468         o->op_private |= OPpLVREF_AV;
2469         goto checkgv;
2470     case OP_RV2CV:
2471         kid = cUNOPo->op_first;
2472         if (kid->op_type == OP_NULL)
2473             kid = cUNOPx(kUNOP->op_first->op_sibling)
2474                 ->op_first;
2475         o->op_private = OPpLVREF_CV;
2476         if (kid->op_type == OP_GV)
2477             o->op_flags |= OPf_STACKED;
2478         else if (kid->op_type == OP_PADCV) {
2479             o->op_targ = kid->op_targ;
2480             kid->op_targ = 0;
2481             op_free(cUNOPo->op_first);
2482             cUNOPo->op_first = NULL;
2483             o->op_flags &=~ OPf_KIDS;
2484         }
2485         else goto badref;
2486         break;
2487     case OP_RV2HV:
2488         if (o->op_flags & OPf_PARENS) {
2489           parenhash:
2490             yyerror(Perl_form(aTHX_ "Can't modify reference to "
2491                                  "parenthesized hash in list assignment"));
2492                 return;
2493         }
2494         o->op_private |= OPpLVREF_HV;
2495         /* FALLTHROUGH */
2496     case OP_RV2SV:
2497       checkgv:
2498         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2499         o->op_flags |= OPf_STACKED;
2500         break;
2501     case OP_PADHV:
2502         if (o->op_flags & OPf_PARENS) goto parenhash;
2503         o->op_private |= OPpLVREF_HV;
2504         /* FALLTHROUGH */
2505     case OP_PADSV:
2506         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2507         break;
2508     case OP_PADAV:
2509         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2510         if (o->op_flags & OPf_PARENS) goto slurpy;
2511         o->op_private |= OPpLVREF_AV;
2512         break;
2513     case OP_AELEM:
2514     case OP_HELEM:
2515         o->op_private |= OPpLVREF_ELEM;
2516         o->op_flags   |= OPf_STACKED;
2517         break;
2518     case OP_ASLICE:
2519     case OP_HSLICE:
2520         CHANGE_TYPE(o, OP_LVREFSLICE);
2521         o->op_private &= OPpLVAL_INTRO|OPpLVREF_ELEM;
2522         return;
2523     case OP_NULL:
2524         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
2525             goto badref;
2526         else if (!(o->op_flags & OPf_KIDS))
2527             return;
2528         if (o->op_targ != OP_LIST) {
2529             S_lvref(aTHX_ cBINOPo->op_first, type);
2530             return;
2531         }
2532         /* FALLTHROUGH */
2533     case OP_LIST:
2534         for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) {
2535             assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
2536             S_lvref(aTHX_ kid, type);
2537         }
2538         return;
2539     case OP_STUB:
2540         if (o->op_flags & OPf_PARENS)
2541             return;
2542         /* FALLTHROUGH */
2543     default:
2544       badref:
2545         /* diag_listed_as: Can't modify reference to %s in %s assignment */
2546         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
2547                      o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
2548                       ? "do block"
2549                       : OP_DESC(o),
2550                      PL_op_desc[type]));
2551         return;
2552     }
2553     CHANGE_TYPE(o, OP_LVREF);
2554     o->op_private &=
2555         OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
2556     if (type == OP_ENTERLOOP)
2557         o->op_private |= OPpLVREF_ITER;
2558 }
2559
2560 OP *
2561 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
2562 {
2563     dVAR;
2564     OP *kid;
2565     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2566     int localize = -1;
2567
2568     if (!o || (PL_parser && PL_parser->error_count))
2569         return o;
2570
2571     if ((o->op_private & OPpTARGET_MY)
2572         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2573     {
2574         return o;
2575     }
2576
2577     assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2578
2579     if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2580
2581     switch (o->op_type) {
2582     case OP_UNDEF:
2583         PL_modcount++;
2584         return o;
2585     case OP_STUB:
2586         if ((o->op_flags & OPf_PARENS))
2587             break;
2588         goto nomod;
2589     case OP_ENTERSUB:
2590         if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
2591             !(o->op_flags & OPf_STACKED)) {
2592             CHANGE_TYPE(o, OP_RV2CV);           /* entersub => rv2cv */
2593             assert(cUNOPo->op_first->op_type == OP_NULL);
2594             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
2595             break;
2596         }
2597         else {                          /* lvalue subroutine call */
2598             o->op_private |= OPpLVAL_INTRO;
2599             PL_modcount = RETURN_UNLIMITED_NUMBER;
2600             if (type == OP_GREPSTART || type == OP_ENTERSUB
2601              || type == OP_REFGEN    || type == OP_LEAVESUBLV) {
2602                 /* Potential lvalue context: */
2603                 o->op_private |= OPpENTERSUB_INARGS;
2604                 break;
2605             }
2606             else {                      /* Compile-time error message: */
2607                 OP *kid = cUNOPo->op_first;
2608                 CV *cv;
2609                 GV *gv;
2610
2611                 if (kid->op_type != OP_PUSHMARK) {
2612                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2613                         Perl_croak(aTHX_
2614                                 "panic: unexpected lvalue entersub "
2615                                 "args: type/targ %ld:%"UVuf,
2616                                 (long)kid->op_type, (UV)kid->op_targ);
2617                     kid = kLISTOP->op_first;
2618                 }
2619                 while (OP_HAS_SIBLING(kid))
2620                     kid = OP_SIBLING(kid);
2621                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
2622                     break;      /* Postpone until runtime */
2623                 }
2624
2625                 kid = kUNOP->op_first;
2626                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2627                     kid = kUNOP->op_first;
2628                 if (kid->op_type == OP_NULL)
2629                     Perl_croak(aTHX_
2630                                "Unexpected constant lvalue entersub "
2631                                "entry via type/targ %ld:%"UVuf,
2632                                (long)kid->op_type, (UV)kid->op_targ);
2633                 if (kid->op_type != OP_GV) {
2634                     break;
2635                 }
2636
2637                 gv = kGVOP_gv;
2638                 cv = isGV(gv)
2639                     ? GvCV(gv)
2640                     : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
2641                         ? MUTABLE_CV(SvRV(gv))
2642                         : NULL;
2643                 if (!cv)
2644                     break;
2645                 if (CvLVALUE(cv))
2646                     break;
2647             }
2648         }
2649         /* FALLTHROUGH */
2650     default:
2651       nomod:
2652         if (flags & OP_LVALUE_NO_CROAK) return NULL;
2653         /* grep, foreach, subcalls, refgen */
2654         if (type == OP_GREPSTART || type == OP_ENTERSUB
2655          || type == OP_REFGEN    || type == OP_LEAVESUBLV)
2656             break;
2657         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2658                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
2659                       ? "do block"
2660                       : (o->op_type == OP_ENTERSUB
2661                         ? "non-lvalue subroutine call"
2662                         : OP_DESC(o))),
2663                      type ? PL_op_desc[type] : "local"));
2664         return o;
2665
2666     case OP_PREINC:
2667     case OP_PREDEC:
2668     case OP_POW:
2669     case OP_MULTIPLY:
2670     case OP_DIVIDE:
2671     case OP_MODULO:
2672     case OP_ADD:
2673     case OP_SUBTRACT:
2674     case OP_CONCAT:
2675     case OP_LEFT_SHIFT:
2676     case OP_RIGHT_SHIFT:
2677     case OP_BIT_AND:
2678     case OP_BIT_XOR:
2679     case OP_BIT_OR:
2680     case OP_I_MULTIPLY:
2681     case OP_I_DIVIDE:
2682     case OP_I_MODULO:
2683     case OP_I_ADD:
2684     case OP_I_SUBTRACT:
2685         if (!(o->op_flags & OPf_STACKED))
2686             goto nomod;
2687         PL_modcount++;
2688         break;
2689
2690     case OP_REPEAT:
2691         if (o->op_flags & OPf_STACKED) {
2692             PL_modcount++;
2693             break;
2694         }
2695         if (!(o->op_private & OPpREPEAT_DOLIST))
2696             goto nomod;
2697         else {
2698             const I32 mods = PL_modcount;
2699             modkids(cBINOPo->op_first, type);
2700             if (type != OP_AASSIGN)
2701                 goto nomod;
2702             kid = cBINOPo->op_last;
2703             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
2704                 const IV iv = SvIV(kSVOP_sv);
2705                 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
2706                     PL_modcount =
2707                         mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
2708             }
2709             else
2710                 PL_modcount = RETURN_UNLIMITED_NUMBER;
2711         }
2712         break;
2713
2714     case OP_COND_EXPR:
2715         localize = 1;
2716         for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
2717             op_lvalue(kid, type);
2718         break;
2719
2720     case OP_RV2AV:
2721     case OP_RV2HV:
2722         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
2723            PL_modcount = RETURN_UNLIMITED_NUMBER;
2724             return o;           /* Treat \(@foo) like ordinary list. */
2725         }
2726         /* FALLTHROUGH */
2727     case OP_RV2GV:
2728         if (scalar_mod_type(o, type))
2729             goto nomod;
2730         ref(cUNOPo->op_first, o->op_type);
2731         /* FALLTHROUGH */
2732     case OP_ASLICE:
2733     case OP_HSLICE:
2734         localize = 1;
2735         /* FALLTHROUGH */
2736     case OP_AASSIGN:
2737         /* Do not apply the lvsub flag for rv2[ah]v in scalar context.  */
2738         if (type == OP_LEAVESUBLV && (
2739                 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
2740              || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2741            ))
2742             o->op_private |= OPpMAYBE_LVSUB;
2743         /* FALLTHROUGH */
2744     case OP_NEXTSTATE:
2745     case OP_DBSTATE:
2746        PL_modcount = RETURN_UNLIMITED_NUMBER;
2747         break;
2748     case OP_KVHSLICE:
2749     case OP_KVASLICE:
2750         if (type == OP_LEAVESUBLV)
2751             o->op_private |= OPpMAYBE_LVSUB;
2752         goto nomod;
2753     case OP_AV2ARYLEN:
2754         PL_hints |= HINT_BLOCK_SCOPE;
2755         if (type == OP_LEAVESUBLV)
2756             o->op_private |= OPpMAYBE_LVSUB;
2757         PL_modcount++;
2758         break;
2759     case OP_RV2SV:
2760         ref(cUNOPo->op_first, o->op_type);
2761         localize = 1;
2762         /* FALLTHROUGH */
2763     case OP_GV:
2764         PL_hints |= HINT_BLOCK_SCOPE;
2765         /* FALLTHROUGH */
2766     case OP_SASSIGN:
2767     case OP_ANDASSIGN:
2768     case OP_ORASSIGN:
2769     case OP_DORASSIGN:
2770         PL_modcount++;
2771         break;
2772
2773     case OP_AELEMFAST:
2774     case OP_AELEMFAST_LEX:
2775         localize = -1;
2776         PL_modcount++;
2777         break;
2778
2779     case OP_PADAV:
2780     case OP_PADHV:
2781        PL_modcount = RETURN_UNLIMITED_NUMBER;
2782         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
2783             return o;           /* Treat \(@foo) like ordinary list. */
2784         if (scalar_mod_type(o, type))
2785             goto nomod;
2786         if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2787           && type == OP_LEAVESUBLV)
2788             o->op_private |= OPpMAYBE_LVSUB;
2789         /* FALLTHROUGH */
2790     case OP_PADSV:
2791         PL_modcount++;
2792         if (!type) /* local() */
2793             Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
2794                  PAD_COMPNAME_SV(o->op_targ));
2795         break;
2796
2797     case OP_PUSHMARK:
2798         localize = 0;
2799         break;
2800
2801     case OP_KEYS:
2802     case OP_RKEYS:
2803         if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
2804             goto nomod;
2805         goto lvalue_func;
2806     case OP_SUBSTR:
2807         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
2808             goto nomod;
2809         /* FALLTHROUGH */
2810     case OP_POS:
2811     case OP_VEC:
2812       lvalue_func:
2813         if (type == OP_LEAVESUBLV)
2814             o->op_private |= OPpMAYBE_LVSUB;
2815         if (o->op_flags & OPf_KIDS)
2816             op_lvalue(OP_SIBLING(cBINOPo->op_first), type);
2817         break;
2818
2819     case OP_AELEM:
2820     case OP_HELEM:
2821         ref(cBINOPo->op_first, o->op_type);
2822         if (type == OP_ENTERSUB &&
2823              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
2824             o->op_private |= OPpLVAL_DEFER;
2825         if (type == OP_LEAVESUBLV)
2826             o->op_private |= OPpMAYBE_LVSUB;
2827         localize = 1;
2828         PL_modcount++;
2829         break;
2830
2831     case OP_LEAVE:
2832     case OP_LEAVELOOP:
2833         o->op_private |= OPpLVALUE;
2834         /* FALLTHROUGH */
2835     case OP_SCOPE:
2836     case OP_ENTER:
2837     case OP_LINESEQ:
2838         localize = 0;
2839         if (o->op_flags & OPf_KIDS)
2840             op_lvalue(cLISTOPo->op_last, type);
2841         break;
2842
2843     case OP_NULL:
2844         localize = 0;
2845         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
2846             goto nomod;
2847         else if (!(o->op_flags & OPf_KIDS))
2848             break;
2849         if (o->op_targ != OP_LIST) {
2850             op_lvalue(cBINOPo->op_first, type);
2851             break;
2852         }
2853         /* FALLTHROUGH */
2854     case OP_LIST:
2855         localize = 0;
2856         for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
2857             /* elements might be in void context because the list is
2858                in scalar context or because they are attribute sub calls */
2859             if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
2860                 op_lvalue(kid, type);
2861         break;
2862
2863     case OP_COREARGS:
2864         return o;
2865
2866     case OP_AND:
2867     case OP_OR:
2868         if (type == OP_LEAVESUBLV
2869          || !S_vivifies(cLOGOPo->op_first->op_type))
2870             op_lvalue(cLOGOPo->op_first, type);
2871         if (type == OP_LEAVESUBLV
2872          || !S_vivifies(OP_SIBLING(cLOGOPo->op_first)->op_type))
2873             op_lvalue(OP_SIBLING(cLOGOPo->op_first), type);
2874         goto nomod;
2875
2876     case OP_SREFGEN:
2877         if (type != OP_AASSIGN && type != OP_SASSIGN
2878          && type != OP_ENTERLOOP)
2879             goto nomod;
2880         /* Don’t bother applying lvalue context to the ex-list.  */
2881         kid = cUNOPx(cUNOPo->op_first)->op_first;
2882         assert (!OP_HAS_SIBLING(kid));
2883         goto kid_2lvref;
2884     case OP_REFGEN:
2885         if (type != OP_AASSIGN) goto nomod;
2886         kid = cUNOPo->op_first;
2887       kid_2lvref:
2888         {
2889             const U8 ec = PL_parser ? PL_parser->error_count : 0;
2890             S_lvref(aTHX_ kid, type);
2891             if (!PL_parser || PL_parser->error_count == ec) {
2892                 if (!FEATURE_REFALIASING_IS_ENABLED)
2893                     Perl_croak(aTHX_
2894                        "Experimental aliasing via reference not enabled");
2895                 Perl_ck_warner_d(aTHX_
2896                                  packWARN(WARN_EXPERIMENTAL__REFALIASING),
2897                                 "Aliasing via reference is experimental");
2898             }
2899         }
2900         if (o->op_type == OP_REFGEN)
2901             op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
2902         op_null(o);
2903         return o;
2904
2905     case OP_SPLIT:
2906         kid = cLISTOPo->op_first;
2907         if (kid && kid->op_type == OP_PUSHRE &&
2908                 (  kid->op_targ
2909                 || o->op_flags & OPf_STACKED
2910 #ifdef USE_ITHREADS
2911                 || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
2912 #else
2913                 || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
2914 #endif
2915         )) {
2916             /* This is actually @array = split.  */
2917             PL_modcount = RETURN_UNLIMITED_NUMBER;
2918             break;
2919         }
2920         goto nomod;
2921     }
2922
2923     /* [20011101.069] File test operators interpret OPf_REF to mean that
2924        their argument is a filehandle; thus \stat(".") should not set
2925        it. AMS 20011102 */
2926     if (type == OP_REFGEN &&
2927         PL_check[o->op_type] == Perl_ck_ftst)
2928         return o;
2929
2930     if (type != OP_LEAVESUBLV)
2931         o->op_flags |= OPf_MOD;
2932
2933     if (type == OP_AASSIGN || type == OP_SASSIGN)
2934         o->op_flags |= OPf_SPECIAL|OPf_REF;
2935     else if (!type) { /* local() */
2936         switch (localize) {
2937         case 1:
2938             o->op_private |= OPpLVAL_INTRO;
2939             o->op_flags &= ~OPf_SPECIAL;
2940             PL_hints |= HINT_BLOCK_SCOPE;
2941             break;
2942         case 0:
2943             break;
2944         case -1:
2945             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2946                            "Useless localization of %s", OP_DESC(o));
2947         }
2948     }
2949     else if (type != OP_GREPSTART && type != OP_ENTERSUB
2950              && type != OP_LEAVESUBLV)
2951         o->op_flags |= OPf_REF;
2952     return o;
2953 }
2954
2955 STATIC bool
2956 S_scalar_mod_type(const OP *o, I32 type)
2957 {
2958     switch (type) {
2959     case OP_POS:
2960     case OP_SASSIGN:
2961         if (o && o->op_type == OP_RV2GV)
2962             return FALSE;
2963         /* FALLTHROUGH */
2964     case OP_PREINC:
2965     case OP_PREDEC:
2966     case OP_POSTINC:
2967     case OP_POSTDEC:
2968     case OP_I_PREINC:
2969     case OP_I_PREDEC:
2970     case OP_I_POSTINC:
2971     case OP_I_POSTDEC:
2972     case OP_POW:
2973     case OP_MULTIPLY:
2974     case OP_DIVIDE:
2975     case OP_MODULO:
2976     case OP_REPEAT:
2977     case OP_ADD:
2978     case OP_SUBTRACT:
2979     case OP_I_MULTIPLY:
2980     case OP_I_DIVIDE:
2981     case OP_I_MODULO:
2982     case OP_I_ADD:
2983     case OP_I_SUBTRACT:
2984     case OP_LEFT_SHIFT:
2985     case OP_RIGHT_SHIFT:
2986     case OP_BIT_AND:
2987     case OP_BIT_XOR:
2988     case OP_BIT_OR:
2989     case OP_CONCAT:
2990     case OP_SUBST:
2991     case OP_TRANS:
2992     case OP_TRANSR:
2993     case OP_READ:
2994     case OP_SYSREAD:
2995     case OP_RECV:
2996     case OP_ANDASSIGN:
2997     case OP_ORASSIGN:
2998     case OP_DORASSIGN:
2999         return TRUE;
3000     default:
3001         return FALSE;
3002     }
3003 }
3004
3005 STATIC bool
3006 S_is_handle_constructor(const OP *o, I32 numargs)
3007 {
3008     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
3009
3010     switch (o->op_type) {
3011     case OP_PIPE_OP:
3012     case OP_SOCKPAIR:
3013         if (numargs == 2)
3014             return TRUE;
3015         /* FALLTHROUGH */
3016     case OP_SYSOPEN:
3017     case OP_OPEN:
3018     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
3019     case OP_SOCKET:
3020     case OP_OPEN_DIR:
3021     case OP_ACCEPT:
3022         if (numargs == 1)
3023             return TRUE;
3024         /* FALLTHROUGH */
3025     default:
3026         return FALSE;
3027     }
3028 }
3029
3030 static OP *
3031 S_refkids(pTHX_ OP *o, I32 type)
3032 {
3033     if (o && o->op_flags & OPf_KIDS) {
3034         OP *kid;
3035         for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
3036             ref(kid, type);
3037     }
3038     return o;
3039 }
3040
3041 OP *
3042 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
3043 {
3044     dVAR;
3045     OP *kid;
3046
3047     PERL_ARGS_ASSERT_DOREF;
3048
3049     if (!o || (PL_parser && PL_parser->error_count))
3050         return o;
3051
3052     switch (o->op_type) {
3053     case OP_ENTERSUB:
3054         if ((type == OP_EXISTS || type == OP_DEFINED) &&
3055             !(o->op_flags & OPf_STACKED)) {
3056             CHANGE_TYPE(o, OP_RV2CV);             /* entersub => rv2cv */
3057             assert(cUNOPo->op_first->op_type == OP_NULL);
3058             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
3059             o->op_flags |= OPf_SPECIAL;
3060         }
3061         else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
3062             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3063                               : type == OP_RV2HV ? OPpDEREF_HV
3064                               : OPpDEREF_SV);
3065             o->op_flags |= OPf_MOD;
3066         }
3067
3068         break;
3069
3070     case OP_COND_EXPR:
3071         for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
3072             doref(kid, type, set_op_ref);
3073         break;
3074     case OP_RV2SV:
3075         if (type == OP_DEFINED)
3076             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
3077         doref(cUNOPo->op_first, o->op_type, set_op_ref);
3078         /* FALLTHROUGH */
3079     case OP_PADSV:
3080         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3081             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3082                               : type == OP_RV2HV ? OPpDEREF_HV
3083                               : OPpDEREF_SV);
3084             o->op_flags |= OPf_MOD;
3085         }
3086         break;
3087
3088     case OP_RV2AV:
3089     case OP_RV2HV:
3090         if (set_op_ref)
3091             o->op_flags |= OPf_REF;
3092         /* FALLTHROUGH */
3093     case OP_RV2GV:
3094         if (type == OP_DEFINED)
3095             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
3096         doref(cUNOPo->op_first, o->op_type, set_op_ref);
3097         break;
3098
3099     case OP_PADAV:
3100     case OP_PADHV:
3101         if (set_op_ref)
3102             o->op_flags |= OPf_REF;
3103         break;
3104
3105     case OP_SCALAR:
3106     case OP_NULL:
3107         if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
3108             break;
3109         doref(cBINOPo->op_first, type, set_op_ref);
3110         break;
3111     case OP_AELEM:
3112     case OP_HELEM:
3113         doref(cBINOPo->op_first, o->op_type, set_op_ref);
3114         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3115             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3116                               : type == OP_RV2HV ? OPpDEREF_HV
3117                               : OPpDEREF_SV);
3118             o->op_flags |= OPf_MOD;
3119         }
3120         break;
3121
3122     case OP_SCOPE:
3123     case OP_LEAVE:
3124         set_op_ref = FALSE;
3125         /* FALLTHROUGH */
3126     case OP_ENTER:
3127     case OP_LIST:
3128         if (!(o->op_flags & OPf_KIDS))
3129             break;
3130         doref(cLISTOPo->op_last, type, set_op_ref);
3131         break;
3132     default:
3133         break;
3134     }
3135     return scalar(o);
3136
3137 }
3138
3139 STATIC OP *
3140 S_dup_attrlist(pTHX_ OP *o)
3141 {
3142     OP *rop;
3143
3144     PERL_ARGS_ASSERT_DUP_ATTRLIST;
3145
3146     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
3147      * where the first kid is OP_PUSHMARK and the remaining ones
3148      * are OP_CONST.  We need to push the OP_CONST values.
3149      */
3150     if (o->op_type == OP_CONST)
3151         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
3152     else {
3153         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
3154         rop = NULL;
3155         for (o = cLISTOPo->op_first; o; o = OP_SIBLING(o)) {
3156             if (o->op_type == OP_CONST)
3157                 rop = op_append_elem(OP_LIST, rop,
3158                                   newSVOP(OP_CONST, o->op_flags,
3159                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
3160         }
3161     }
3162     return rop;
3163 }
3164
3165 STATIC void
3166 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
3167 {
3168     SV * const stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
3169
3170     PERL_ARGS_ASSERT_APPLY_ATTRS;
3171
3172     /* fake up C<use attributes $pkg,$rv,@attrs> */
3173
3174 #define ATTRSMODULE "attributes"
3175 #define ATTRSMODULE_PM "attributes.pm"
3176
3177     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3178                          newSVpvs(ATTRSMODULE),
3179                          NULL,
3180                          op_prepend_elem(OP_LIST,
3181                                       newSVOP(OP_CONST, 0, stashsv),
3182                                       op_prepend_elem(OP_LIST,
3183                                                    newSVOP(OP_CONST, 0,
3184                                                            newRV(target)),
3185                                                    dup_attrlist(attrs))));
3186 }
3187
3188 STATIC void
3189 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
3190 {
3191     OP *pack, *imop, *arg;
3192     SV *meth, *stashsv, **svp;
3193
3194     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
3195
3196     if (!attrs)
3197         return;
3198
3199     assert(target->op_type == OP_PADSV ||
3200            target->op_type == OP_PADHV ||
3201            target->op_type == OP_PADAV);
3202
3203     /* Ensure that attributes.pm is loaded. */
3204     /* Don't force the C<use> if we don't need it. */
3205     svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
3206     if (svp && *svp != &PL_sv_undef)
3207         NOOP;   /* already in %INC */
3208     else
3209         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
3210                                newSVpvs(ATTRSMODULE), NULL);
3211
3212     /* Need package name for method call. */
3213     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
3214
3215     /* Build up the real arg-list. */
3216     stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
3217
3218     arg = newOP(OP_PADSV, 0);
3219     arg->op_targ = target->op_targ;
3220     arg = op_prepend_elem(OP_LIST,
3221                        newSVOP(OP_CONST, 0, stashsv),
3222                        op_prepend_elem(OP_LIST,
3223                                     newUNOP(OP_REFGEN, 0,
3224                                             op_lvalue(arg, OP_REFGEN)),
3225                                     dup_attrlist(attrs)));
3226
3227     /* Fake up a method call to import */
3228     meth = newSVpvs_share("import");
3229     imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
3230                    op_append_elem(OP_LIST,
3231                                op_prepend_elem(OP_LIST, pack, arg),
3232                                newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
3233
3234     /* Combine the ops. */
3235     *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
3236 }
3237
3238 /*
3239 =notfor apidoc apply_attrs_string
3240
3241 Attempts to apply a list of attributes specified by the C<attrstr> and
3242 C<len> arguments to the subroutine identified by the C<cv> argument which
3243 is expected to be associated with the package identified by the C<stashpv>
3244 argument (see L<attributes>).  It gets this wrong, though, in that it
3245 does not correctly identify the boundaries of the individual attribute
3246 specifications within C<attrstr>.  This is not really intended for the
3247 public API, but has to be listed here for systems such as AIX which
3248 need an explicit export list for symbols.  (It's called from XS code
3249 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
3250 to respect attribute syntax properly would be welcome.
3251
3252 =cut
3253 */
3254
3255 void
3256 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
3257                         const char *attrstr, STRLEN len)
3258 {
3259     OP *attrs = NULL;
3260
3261     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
3262
3263     if (!len) {
3264         len = strlen(attrstr);
3265     }
3266
3267     while (len) {
3268         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
3269         if (len) {
3270             const char * const sstr = attrstr;
3271             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
3272             attrs = op_append_elem(OP_LIST, attrs,
3273                                 newSVOP(OP_CONST, 0,
3274                                         newSVpvn(sstr, attrstr-sstr)));
3275         }
3276     }
3277
3278     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3279                      newSVpvs(ATTRSMODULE),
3280                      NULL, op_prepend_elem(OP_LIST,
3281                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
3282                                   op_prepend_elem(OP_LIST,
3283                                                newSVOP(OP_CONST, 0,
3284                                                        newRV(MUTABLE_SV(cv))),
3285                                                attrs)));
3286 }
3287
3288 STATIC void
3289 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
3290 {
3291     OP *new_proto = NULL;
3292     STRLEN pvlen;
3293     char *pv;
3294     OP *o;
3295
3296     PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
3297
3298     if (!*attrs)
3299         return;
3300
3301     o = *attrs;
3302     if (o->op_type == OP_CONST) {
3303         pv = SvPV(cSVOPo_sv, pvlen);
3304         if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3305             SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3306             SV ** const tmpo = cSVOPx_svp(o);
3307             SvREFCNT_dec(cSVOPo_sv);
3308             *tmpo = tmpsv;
3309             new_proto = o;
3310             *attrs = NULL;
3311         }
3312     } else if (o->op_type == OP_LIST) {
3313         OP * lasto;
3314         assert(o->op_flags & OPf_KIDS);
3315         lasto = cLISTOPo->op_first;
3316         assert(lasto->op_type == OP_PUSHMARK);
3317         for (o = OP_SIBLING(lasto); o; o = OP_SIBLING(o)) {
3318             if (o->op_type == OP_CONST) {
3319                 pv = SvPV(cSVOPo_sv, pvlen);
3320                 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3321                     SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3322                     SV ** const tmpo = cSVOPx_svp(o);
3323                     SvREFCNT_dec(cSVOPo_sv);
3324                     *tmpo = tmpsv;
3325                     if (new_proto && ckWARN(WARN_MISC)) {
3326                         STRLEN new_len;
3327                         const char * newp = SvPV(cSVOPo_sv, new_len);
3328                         Perl_warner(aTHX_ packWARN(WARN_MISC),
3329                             "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub",
3330                             UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
3331                         op_free(new_proto);
3332                     }
3333                     else if (new_proto)
3334                         op_free(new_proto);
3335                     new_proto = o;
3336                     /* excise new_proto from the list */
3337                     op_sibling_splice(*attrs, lasto, 1, NULL);
3338                     o = lasto;
3339                     continue;
3340                 }
3341             }
3342             lasto = o;
3343         }
3344         /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
3345            would get pulled in with no real need */
3346         if (!OP_HAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
3347             op_free(*attrs);
3348             *attrs = NULL;
3349         }
3350     }
3351
3352     if (new_proto) {
3353         SV *svname;
3354         if (isGV(name)) {
3355             svname = sv_newmortal();
3356             gv_efullname3(svname, name, NULL);
3357         }
3358         else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
3359             svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
3360         else
3361             svname = (SV *)name;
3362         if (ckWARN(WARN_ILLEGALPROTO))
3363             (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
3364         if (*proto && ckWARN(WARN_PROTOTYPE)) {
3365             STRLEN old_len, new_len;
3366             const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
3367             const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
3368
3369             Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3370                 "Prototype '%"UTF8f"' overridden by attribute 'prototype(%"UTF8f")'"
3371                 " in %"SVf,
3372                 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
3373                 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
3374                 SVfARG(svname));
3375         }
3376         if (*proto)
3377             op_free(*proto);
3378         *proto = new_proto;
3379     }
3380 }
3381
3382 static void
3383 S_cant_declare(pTHX_ OP *o)
3384 {
3385     if (o->op_type == OP_NULL
3386      && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
3387         o = cUNOPo->op_first;
3388     yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
3389                              o->op_type == OP_NULL
3390                                && o->op_flags & OPf_SPECIAL
3391                                  ? "do block"
3392                                  : OP_DESC(o),
3393                              PL_parser->in_my == KEY_our   ? "our"   :
3394                              PL_parser->in_my == KEY_state ? "state" :
3395                                                              "my"));
3396 }
3397
3398 STATIC OP *
3399 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
3400 {
3401     I32 type;
3402     const bool stately = PL_parser && PL_parser->in_my == KEY_state;
3403
3404     PERL_ARGS_ASSERT_MY_KID;
3405
3406     if (!o || (PL_parser && PL_parser->error_count))
3407         return o;
3408
3409     type = o->op_type;
3410
3411     if (type == OP_LIST) {
3412         OP *kid;
3413         for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
3414             my_kid(kid, attrs, imopsp);
3415         return o;
3416     } else if (type == OP_UNDEF || type == OP_STUB) {
3417         return o;
3418     } else if (type == OP_RV2SV ||      /* "our" declaration */
3419                type == OP_RV2AV ||
3420                type == OP_RV2HV) { /* XXX does this let anything illegal in? */
3421         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
3422             S_cant_declare(aTHX_ o);
3423         } else if (attrs) {
3424             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
3425             assert(PL_parser);
3426             PL_parser->in_my = FALSE;
3427             PL_parser->in_my_stash = NULL;
3428             apply_attrs(GvSTASH(gv),
3429                         (type == OP_RV2SV ? GvSV(gv) :
3430                          type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
3431                          type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
3432                         attrs);
3433         }
3434         o->op_private |= OPpOUR_INTRO;
3435         return o;
3436     }
3437     else if (type != OP_PADSV &&
3438              type != OP_PADAV &&
3439              type != OP_PADHV &&
3440              type != OP_PUSHMARK)
3441     {
3442         S_cant_declare(aTHX_ o);
3443         return o;
3444     }
3445     else if (attrs && type != OP_PUSHMARK) {
3446         HV *stash;
3447
3448         assert(PL_parser);
3449         PL_parser->in_my = FALSE;
3450         PL_parser->in_my_stash = NULL;
3451
3452         /* check for C<my Dog $spot> when deciding package */
3453         stash = PAD_COMPNAME_TYPE(o->op_targ);
3454         if (!stash)
3455             stash = PL_curstash;
3456         apply_attrs_my(stash, o, attrs, imopsp);
3457     }
3458     o->op_flags |= OPf_MOD;
3459     o->op_private |= OPpLVAL_INTRO;
3460     if (stately)
3461         o->op_private |= OPpPAD_STATE;
3462     return o;
3463 }
3464
3465 OP *
3466 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
3467 {
3468     OP *rops;
3469     int maybe_scalar = 0;
3470
3471     PERL_ARGS_ASSERT_MY_ATTRS;
3472
3473 /* [perl #17376]: this appears to be premature, and results in code such as
3474    C< our(%x); > executing in list mode rather than void mode */
3475 #if 0
3476     if (o->op_flags & OPf_PARENS)
3477         list(o);
3478     else
3479         maybe_scalar = 1;
3480 #else
3481     maybe_scalar = 1;
3482 #endif
3483     if (attrs)
3484         SAVEFREEOP(attrs);
3485     rops = NULL;
3486     o = my_kid(o, attrs, &rops);
3487     if (rops) {
3488         if (maybe_scalar && o->op_type == OP_PADSV) {
3489             o = scalar(op_append_list(OP_LIST, rops, o));
3490             o->op_private |= OPpLVAL_INTRO;
3491         }
3492         else {
3493             /* The listop in rops might have a pushmark at the beginning,
3494                which will mess up list assignment. */
3495             LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
3496             if (rops->op_type == OP_LIST &&
3497                 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
3498             {
3499                 OP * const pushmark = lrops->op_first;
3500                 /* excise pushmark */
3501                 op_sibling_splice(rops, NULL, 1, NULL);
3502                 op_free(pushmark);
3503             }
3504             o = op_append_list(OP_LIST, o, rops);
3505         }
3506     }
3507     PL_parser->in_my = FALSE;
3508     PL_parser->in_my_stash = NULL;
3509     return o;
3510 }
3511
3512 OP *
3513 Perl_sawparens(pTHX_ OP *o)
3514 {
3515     PERL_UNUSED_CONTEXT;
3516     if (o)
3517         o->op_flags |= OPf_PARENS;
3518     return o;
3519 }
3520
3521 OP *
3522 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
3523 {
3524     OP *o;
3525     bool ismatchop = 0;
3526     const OPCODE ltype = left->op_type;
3527     const OPCODE rtype = right->op_type;
3528
3529     PERL_ARGS_ASSERT_BIND_MATCH;
3530
3531     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
3532           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
3533     {
3534       const char * const desc
3535           = PL_op_desc[(
3536                           rtype == OP_SUBST || rtype == OP_TRANS
3537                        || rtype == OP_TRANSR
3538                        )
3539                        ? (int)rtype : OP_MATCH];
3540       const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
3541       SV * const name =
3542         S_op_varname(aTHX_ left);
3543       if (name)
3544         Perl_warner(aTHX_ packWARN(WARN_MISC),
3545              "Applying %s to %"SVf" will act on scalar(%"SVf")",
3546              desc, SVfARG(name), SVfARG(name));
3547       else {
3548         const char * const sample = (isary
3549              ? "@array" : "%hash");
3550         Perl_warner(aTHX_ packWARN(WARN_MISC),
3551              "Applying %s to %s will act on scalar(%s)",
3552              desc, sample, sample);
3553       }
3554     }
3555
3556     if (rtype == OP_CONST &&
3557         cSVOPx(right)->op_private & OPpCONST_BARE &&
3558         cSVOPx(right)->op_private & OPpCONST_STRICT)
3559     {
3560         no_bareword_allowed(right);
3561     }
3562
3563     /* !~ doesn't make sense with /r, so error on it for now */
3564     if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
3565         type == OP_NOT)
3566         /* diag_listed_as: Using !~ with %s doesn't make sense */
3567         yyerror("Using !~ with s///r doesn't make sense");
3568     if (rtype == OP_TRANSR && type == OP_NOT)
3569         /* diag_listed_as: Using !~ with %s doesn't make sense */
3570         yyerror("Using !~ with tr///r doesn't make sense");
3571
3572     ismatchop = (rtype == OP_MATCH ||
3573                  rtype == OP_SUBST ||
3574                  rtype == OP_TRANS || rtype == OP_TRANSR)
3575              && !(right->op_flags & OPf_SPECIAL);
3576     if (ismatchop && right->op_private & OPpTARGET_MY) {
3577         right->op_targ = 0;
3578         right->op_private &= ~OPpTARGET_MY;
3579     }
3580     if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
3581         if (left->op_type == OP_PADSV
3582          && !(left->op_private & OPpLVAL_INTRO))
3583         {
3584             right->op_targ = left->op_targ;
3585             op_free(left);
3586             o = right;
3587         }
3588         else {
3589             right->op_flags |= OPf_STACKED;
3590             if (rtype != OP_MATCH && rtype != OP_TRANSR &&
3591             ! (rtype == OP_TRANS &&
3592                right->op_private & OPpTRANS_IDENTICAL) &&
3593             ! (rtype == OP_SUBST &&
3594                (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3595                 left = op_lvalue(left, rtype);
3596             if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
3597                 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
3598             else
3599                 o = op_prepend_elem(rtype, scalar(left), right);
3600         }
3601         if (type == OP_NOT)
3602             return newUNOP(OP_NOT, 0, scalar(o));
3603         return o;
3604     }
3605     else
3606         return bind_match(type, left,
3607                 pmruntime(newPMOP(OP_MATCH, 0), right, 0, 0));
3608 }
3609
3610 OP *
3611 Perl_invert(pTHX_ OP *o)
3612 {
3613     if (!o)
3614         return NULL;
3615     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
3616 }
3617
3618 /*
3619 =for apidoc Amx|OP *|op_scope|OP *o
3620
3621 Wraps up an op tree with some additional ops so that at runtime a dynamic
3622 scope will be created.  The original ops run in the new dynamic scope,
3623 and then, provided that they exit normally, the scope will be unwound.
3624 The additional ops used to create and unwind the dynamic scope will
3625 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
3626 instead if the ops are simple enough to not need the full dynamic scope
3627 structure.
3628
3629 =cut
3630 */
3631
3632 OP *
3633 Perl_op_scope(pTHX_ OP *o)
3634 {
3635     dVAR;
3636     if (o) {
3637         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
3638             o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
3639             CHANGE_TYPE(o, OP_LEAVE);
3640         }
3641         else if (o->op_type == OP_LINESEQ) {
3642             OP *kid;
3643             CHANGE_TYPE(o, OP_SCOPE);
3644             kid = ((LISTOP*)o)->op_first;
3645             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
3646                 op_null(kid);
3647
3648                 /* The following deals with things like 'do {1 for 1}' */
3649                 kid = OP_SIBLING(kid);
3650                 if (kid &&
3651                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
3652                     op_null(kid);
3653             }
3654         }
3655         else
3656             o = newLISTOP(OP_SCOPE, 0, o, NULL);
3657     }
3658     return o;
3659 }
3660
3661 OP *
3662 Perl_op_unscope(pTHX_ OP *o)
3663 {
3664     if (o && o->op_type == OP_LINESEQ) {
3665         OP *kid = cLISTOPo->op_first;
3666         for(; kid; kid = OP_SIBLING(kid))
3667             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
3668                 op_null(kid);
3669     }
3670     return o;
3671 }
3672
3673 /*
3674 =for apidoc Am|int|block_start|int full
3675
3676 Handles compile-time scope entry.
3677 Arranges for hints to be restored on block
3678 exit and also handles pad sequence numbers to make lexical variables scope
3679 right.  Returns a savestack index for use with C<block_end>.
3680
3681 =cut
3682 */
3683
3684 int
3685 Perl_block_start(pTHX_ int full)
3686 {
3687     const int retval = PL_savestack_ix;
3688
3689     PL_compiling.cop_seq = PL_cop_seqmax++;
3690     if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
3691         PL_cop_seqmax++;
3692     pad_block_start(full);
3693     SAVEHINTS();
3694     PL_hints &= ~HINT_BLOCK_SCOPE;
3695     SAVECOMPILEWARNINGS();
3696     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
3697     SAVEI32(PL_compiling.cop_seq);
3698     PL_compiling.cop_seq = 0;
3699
3700     CALL_BLOCK_HOOKS(bhk_start, full);
3701
3702     return retval;
3703 }
3704
3705 /*
3706 =for apidoc Am|OP *|block_end|I32 floor|OP *seq
3707
3708 Handles compile-time scope exit.  I<floor>
3709 is the savestack index returned by
3710 C<block_start>, and I<seq> is the body of the block.  Returns the block,
3711 possibly modified.
3712
3713 =cut
3714 */
3715
3716 OP*
3717 Perl_block_end(pTHX_ I32 floor, OP *seq)
3718 {
3719     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
3720     OP* retval = scalarseq(seq);
3721     OP *o;
3722
3723     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
3724
3725     LEAVE_SCOPE(floor);
3726     if (needblockscope)
3727         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
3728     o = pad_leavemy();
3729
3730     if (o) {
3731         /* pad_leavemy has created a sequence of introcv ops for all my
3732            subs declared in the block.  We have to replicate that list with
3733            clonecv ops, to deal with this situation:
3734
3735                sub {
3736                    my sub s1;
3737                    my sub s2;
3738                    sub s1 { state sub foo { \&s2 } }
3739                }->()
3740
3741            Originally, I was going to have introcv clone the CV and turn
3742            off the stale flag.  Since &s1 is declared before &s2, the
3743            introcv op for &s1 is executed (on sub entry) before the one for
3744            &s2.  But the &foo sub inside &s1 (which is cloned when &s1 is
3745            cloned, since it is a state sub) closes over &s2 and expects
3746            to see it in its outer CV’s pad.  If the introcv op clones &s1,
3747            then &s2 is still marked stale.  Since &s1 is not active, and
3748            &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
3749            ble will not stay shared’ warning.  Because it is the same stub
3750            that will be used when the introcv op for &s2 is executed, clos-
3751            ing over it is safe.  Hence, we have to turn off the stale flag
3752            on all lexical subs in the block before we clone any of them.
3753            Hence, having introcv clone the sub cannot work.  So we create a
3754            list of ops like this:
3755
3756                lineseq
3757                   |
3758                   +-- introcv
3759                   |
3760                   +-- introcv
3761                   |
3762                   +-- introcv
3763                   |
3764                   .
3765                   .
3766                   .
3767                   |
3768                   +-- clonecv
3769                   |
3770                   +-- clonecv
3771                   |
3772                   +-- clonecv
3773                   |
3774                   .
3775                   .
3776                   .
3777          */
3778         OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
3779         OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
3780         for (;; kid = OP_SIBLING(kid)) {
3781             OP *newkid = newOP(OP_CLONECV, 0);
3782             newkid->op_targ = kid->op_targ;
3783             o = op_append_elem(OP_LINESEQ, o, newkid);
3784             if (kid == last) break;
3785         }
3786         retval = op_prepend_elem(OP_LINESEQ, o, retval);
3787     }
3788
3789     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
3790
3791     return retval;
3792 }
3793
3794 /*
3795 =head1 Compile-time scope hooks
3796
3797 =for apidoc Aox||blockhook_register
3798
3799 Register a set of hooks to be called when the Perl lexical scope changes
3800 at compile time.  See L<perlguts/"Compile-time scope hooks">.
3801
3802 =cut
3803 */
3804
3805 void
3806 Perl_blockhook_register(pTHX_ BHK *hk)
3807 {
3808     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
3809
3810     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
3811 }
3812
3813 void
3814 Perl_newPROG(pTHX_ OP *o)
3815 {
3816     PERL_ARGS_ASSERT_NEWPROG;
3817
3818     if (PL_in_eval) {
3819         PERL_CONTEXT *cx;
3820         I32 i;
3821         if (PL_eval_root)
3822                 return;
3823         PL_eval_root = newUNOP(OP_LEAVEEVAL,
3824                                ((PL_in_eval & EVAL_KEEPERR)
3825                                 ? OPf_SPECIAL : 0), o);
3826
3827         cx = &cxstack[cxstack_ix];
3828         assert(CxTYPE(cx) == CXt_EVAL);
3829
3830         if ((cx->blk_gimme & G_WANT) == G_VOID)
3831             scalarvoid(PL_eval_root);
3832         else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
3833             list(PL_eval_root);
3834         else
3835             scalar(PL_eval_root);
3836
3837         PL_eval_start = op_linklist(PL_eval_root);
3838         PL_eval_root->op_private |= OPpREFCOUNTED;
3839         OpREFCNT_set(PL_eval_root, 1);
3840         PL_eval_root->op_next = 0;
3841         i = PL_savestack_ix;
3842         SAVEFREEOP(o);
3843         ENTER;
3844         CALL_PEEP(PL_eval_start);
3845         finalize_optree(PL_eval_root);
3846         S_prune_chain_head(&PL_eval_start);
3847         LEAVE;
3848         PL_savestack_ix = i;
3849     }
3850     else {
3851         if (o->op_type == OP_STUB) {
3852             /* This block is entered if nothing is compiled for the main
3853                program. This will be the case for an genuinely empty main
3854                program, or one which only has BEGIN blocks etc, so already
3855                run and freed.
3856
3857                Historically (5.000) the guard above was !o. However, commit
3858                f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
3859                c71fccf11fde0068, changed perly.y so that newPROG() is now
3860                called with the output of block_end(), which returns a new
3861                OP_STUB for the case of an empty optree. ByteLoader (and
3862                maybe other things) also take this path, because they set up
3863                PL_main_start and PL_main_root directly, without generating an
3864                optree.
3865
3866                If the parsing the main program aborts (due to parse errors,
3867                or due to BEGIN or similar calling exit), then newPROG()
3868                isn't even called, and hence this code path and its cleanups
3869                are skipped. This shouldn't make a make a difference:
3870                * a non-zero return from perl_parse is a failure, and
3871                  perl_destruct() should be called immediately.
3872                * however, if exit(0) is called during the parse, then
3873                  perl_parse() returns 0, and perl_run() is called. As
3874                  PL_main_start will be NULL, perl_run() will return
3875                  promptly, and the exit code will remain 0.
3876             */
3877
3878             PL_comppad_name = 0;
3879             PL_compcv = 0;
3880             S_op_destroy(aTHX_ o);
3881             return;
3882         }
3883         PL_main_root = op_scope(sawparens(scalarvoid(o)));
3884         PL_curcop = &PL_compiling;
3885         PL_main_start = LINKLIST(PL_main_root);
3886         PL_main_root->op_private |= OPpREFCOUNTED;
3887         OpREFCNT_set(PL_main_root, 1);
3888         PL_main_root->op_next = 0;
3889         CALL_PEEP(PL_main_start);
3890         finalize_optree(PL_main_root);
3891         S_prune_chain_head(&PL_main_start);
3892         cv_forget_slab(PL_compcv);
3893         PL_compcv = 0;
3894
3895         /* Register with debugger */
3896         if (PERLDB_INTER) {
3897             CV * const cv = get_cvs("DB::postponed", 0);
3898             if (cv) {
3899                 dSP;
3900                 PUSHMARK(SP);
3901                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3902                 PUTBACK;
3903                 call_sv(MUTABLE_SV(cv), G_DISCARD);
3904             }
3905         }
3906     }
3907 }
3908
3909 OP *
3910 Perl_localize(pTHX_ OP *o, I32 lex)
3911 {
3912     PERL_ARGS_ASSERT_LOCALIZE;
3913
3914     if (o->op_flags & OPf_PARENS)
3915 /* [perl #17376]: this appears to be premature, and results in code such as
3916    C< our(%x); > executing in list mode rather than void mode */
3917 #if 0
3918         list(o);
3919 #else
3920         NOOP;
3921 #endif
3922     else {
3923         if ( PL_parser->bufptr > PL_parser->oldbufptr
3924             && PL_parser->bufptr[-1] == ','
3925             && ckWARN(WARN_PARENTHESIS))
3926         {
3927             char *s = PL_parser->bufptr;
3928             bool sigil = FALSE;
3929
3930             /* some heuristics to detect a potential error */
3931             while (*s && (strchr(", \t\n", *s)))
3932                 s++;
3933
3934             while (1) {
3935                 if (*s && strchr("@$%*", *s) && *++s
3936                        && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
3937                     s++;
3938                     sigil = TRUE;
3939                     while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
3940                         s++;
3941                     while (*s && (strchr(", \t\n", *s)))
3942                         s++;
3943                 }
3944                 else
3945                     break;
3946             }
3947             if (sigil && (*s == ';' || *s == '=')) {
3948                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
3949                                 "Parentheses missing around \"%s\" list",
3950                                 lex
3951                                     ? (PL_parser->in_my == KEY_our
3952                                         ? "our"
3953                                         : PL_parser->in_my == KEY_state
3954                                             ? "state"
3955                                             : "my")
3956                                     : "local");
3957             }
3958         }
3959     }
3960     if (lex)
3961         o = my(o);
3962     else
3963         o = op_lvalue(o, OP_NULL);              /* a bit kludgey */
3964     PL_parser->in_my = FALSE;
3965     PL_parser->in_my_stash = NULL;
3966     return o;
3967 }
3968
3969 OP *
3970 Perl_jmaybe(pTHX_ OP *o)
3971 {
3972     PERL_ARGS_ASSERT_JMAYBE;
3973
3974     if (o->op_type == OP_LIST) {
3975         OP * const o2
3976             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
3977         o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
3978     }
3979     return o;
3980 }
3981
3982 PERL_STATIC_INLINE OP *
3983 S_op_std_init(pTHX_ OP *o)
3984 {
3985     I32 type = o->op_type;
3986
3987     PERL_ARGS_ASSERT_OP_STD_INIT;
3988
3989     if (PL_opargs[type] & OA_RETSCALAR)
3990         scalar(o);
3991     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
3992         o->op_targ = pad_alloc(type, SVs_PADTMP);
3993
3994     return o;
3995 }
3996
3997 PERL_STATIC_INLINE OP *
3998 S_op_integerize(pTHX_ OP *o)
3999 {
4000     I32 type = o->op_type;
4001
4002     PERL_ARGS_ASSERT_OP_INTEGERIZE;
4003
4004     /* integerize op. */
4005     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
4006     {
4007         dVAR;
4008         o->op_ppaddr = PL_ppaddr[++(o->op_type)];
4009     }
4010
4011     if (type == OP_NEGATE)
4012         /* XXX might want a ck_negate() for this */
4013         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
4014
4015     return o;
4016 }
4017
4018 static OP *
4019 S_fold_constants(pTHX_ OP *o)
4020 {
4021     dVAR;
4022     OP * VOL curop;
4023     OP *newop;
4024     VOL I32 type = o->op_type;
4025     bool folded;
4026     SV * VOL sv = NULL;
4027     int ret = 0;
4028     I32 oldscope;
4029     OP *old_next;
4030     SV * const oldwarnhook = PL_warnhook;
4031     SV * const olddiehook  = PL_diehook;
4032     COP not_compiling;
4033     U8 oldwarn = PL_dowarn;
4034     dJMPENV;
4035
4036     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
4037
4038     if (!(PL_opargs[type] & OA_FOLDCONST))
4039         goto nope;
4040
4041     switch (type) {
4042     case OP_UCFIRST:
4043     case OP_LCFIRST:
4044     case OP_UC:
4045     case OP_LC:
4046     case OP_FC:
4047 #ifdef USE_LOCALE_CTYPE
4048         if (IN_LC_COMPILETIME(LC_CTYPE))
4049             goto nope;
4050 #endif
4051         break;
4052     case OP_SLT:
4053     case OP_SGT:
4054     case OP_SLE:
4055     case OP_SGE:
4056     case OP_SCMP:
4057 #ifdef USE_LOCALE_COLLATE
4058         if (IN_LC_COMPILETIME(LC_COLLATE))
4059             goto nope;
4060 #endif
4061         break;
4062     case OP_SPRINTF:
4063         /* XXX what about the numeric ops? */
4064 #ifdef USE_LOCALE_NUMERIC
4065         if (IN_LC_COMPILETIME(LC_NUMERIC))
4066             goto nope;
4067 #endif
4068         break;
4069     case OP_PACK:
4070         if (!OP_HAS_SIBLING(cLISTOPo->op_first)
4071           || OP_SIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
4072             goto nope;
4073         {
4074             SV * const sv = cSVOPx_sv(OP_SIBLING(cLISTOPo->op_first));
4075             if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
4076             {
4077                 const char *s = SvPVX_const(sv);
4078                 while (s < SvEND(sv)) {
4079                     if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
4080                     s++;
4081                 }
4082             }
4083         }
4084         break;
4085     case OP_REPEAT:
4086         if (o->op_private & OPpREPEAT_DOLIST) goto nope;
4087         break;
4088     case OP_SREFGEN:
4089         if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
4090          || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
4091             goto nope;
4092     }
4093
4094     if (PL_parser && PL_parser->error_count)
4095         goto nope;              /* Don't try to run w/ errors */
4096
4097     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4098         const OPCODE type = curop->op_type;
4099         if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
4100             type != OP_LIST &&
4101             type != OP_SCALAR &&
4102             type != OP_NULL &&
4103             type != OP_PUSHMARK)
4104         {
4105             goto nope;
4106         }
4107     }
4108
4109     curop = LINKLIST(o);
4110     old_next = o->op_next;
4111     o->op_next = 0;
4112     PL_op = curop;
4113
4114     oldscope = PL_scopestack_ix;
4115     create_eval_scope(G_FAKINGEVAL);
4116
4117     /* Verify that we don't need to save it:  */
4118     assert(PL_curcop == &PL_compiling);
4119     StructCopy(&PL_compiling, &not_compiling, COP);
4120     PL_curcop = &not_compiling;
4121     /* The above ensures that we run with all the correct hints of the
4122        currently compiling COP, but that IN_PERL_RUNTIME is not true. */
4123     assert(IN_PERL_RUNTIME);
4124     PL_warnhook = PERL_WARNHOOK_FATAL;
4125     PL_diehook  = NULL;
4126     JMPENV_PUSH(ret);
4127
4128     /* Effective $^W=1.  */
4129     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
4130         PL_dowarn |= G_WARN_ON;
4131
4132     switch (ret) {
4133     case 0:
4134         CALLRUNOPS(aTHX);
4135         sv = *(PL_stack_sp--);
4136         if (o->op_targ && sv == PAD_SV(o->op_targ)) {   /* grab pad temp? */
4137             pad_swipe(o->op_targ,  FALSE);
4138         }
4139         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
4140             SvREFCNT_inc_simple_void(sv);
4141             SvTEMP_off(sv);
4142         }
4143         else { assert(SvIMMORTAL(sv)); }
4144         break;
4145     case 3:
4146         /* Something tried to die.  Abandon constant folding.  */
4147         /* Pretend the error never happened.  */
4148         CLEAR_ERRSV();
4149         o->op_next = old_next;
4150         break;
4151     default:
4152         JMPENV_POP;
4153         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
4154         PL_warnhook = oldwarnhook;
4155         PL_diehook  = olddiehook;
4156         /* XXX note that this croak may fail as we've already blown away
4157          * the stack - eg any nested evals */
4158         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
4159     }
4160     JMPENV_POP;
4161     PL_dowarn   = oldwarn;
4162     PL_warnhook = oldwarnhook;
4163     PL_diehook  = olddiehook;
4164     PL_curcop = &PL_compiling;
4165
4166     if (PL_scopestack_ix > oldscope)
4167         delete_eval_scope();
4168
4169     if (ret)
4170         goto nope;
4171
4172     folded = cBOOL(o->op_folded);
4173     op_free(o);
4174     assert(sv);
4175     if (type == OP_STRINGIFY) SvPADTMP_off(sv);
4176     else if (!SvIMMORTAL(sv)) {
4177         SvPADTMP_on(sv);
4178         SvREADONLY_on(sv);
4179     }
4180     if (type == OP_RV2GV)
4181         newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
4182     else
4183     {
4184         newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
4185         /* OP_STRINGIFY and constant folding are used to implement qq.
4186            Here the constant folding is an implementation detail that we
4187            want to hide.  If the stringify op is itself already marked
4188            folded, however, then it is actually a folded join.  */
4189         if (type != OP_STRINGIFY || folded) newop->op_folded = 1;
4190     }
4191     return newop;
4192
4193  nope:
4194     return o;
4195 }
4196
4197 static OP *
4198 S_gen_constant_list(pTHX_ OP *o)
4199 {
4200     dVAR;
4201     OP *curop;
4202     const SSize_t oldtmps_floor = PL_tmps_floor;
4203     SV **svp;
4204     AV *av;
4205
4206     list(o);
4207     if (PL_parser && PL_parser->error_count)
4208         return o;               /* Don't attempt to run with errors */
4209
4210     curop = LINKLIST(o);
4211     o->op_next = 0;
4212     CALL_PEEP(curop);
4213     S_prune_chain_head(&curop);
4214     PL_op = curop;
4215     Perl_pp_pushmark(aTHX);
4216     CALLRUNOPS(aTHX);
4217     PL_op = curop;
4218     assert (!(curop->op_flags & OPf_SPECIAL));
4219     assert(curop->op_type == OP_RANGE);
4220     Perl_pp_anonlist(aTHX);
4221     PL_tmps_floor = oldtmps_floor;
4222
4223     CHANGE_TYPE(o, OP_RV2AV);
4224     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
4225     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
4226     o->op_opt = 0;              /* needs to be revisited in rpeep() */
4227     av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
4228
4229     /* replace subtree with an OP_CONST */
4230     curop = ((UNOP*)o)->op_first;
4231     op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
4232     op_free(curop);
4233
4234     if (AvFILLp(av) != -1)
4235         for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
4236         {
4237             SvPADTMP_on(*svp);
4238             SvREADONLY_on(*svp);
4239         }
4240     LINKLIST(o);
4241     return list(o);
4242 }
4243
4244 /*
4245 =head1 Optree Manipulation Functions
4246 */
4247
4248 /* List constructors */
4249
4250 /*
4251 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
4252
4253 Append an item to the list of ops contained directly within a list-type
4254 op, returning the lengthened list.  I<first> is the list-type op,
4255 and I<last> is the op to append to the list.  I<optype> specifies the
4256 intended opcode for the list.  If I<first> is not already a list of the
4257 right type, it will be upgraded into one.  If either I<first> or I<last>
4258 is null, the other is returned unchanged.
4259
4260 =cut
4261 */
4262
4263 OP *
4264 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
4265 {
4266     if (!first)
4267         return last;
4268
4269     if (!last)
4270         return first;
4271
4272     if (first->op_type != (unsigned)type
4273         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
4274     {
4275         return newLISTOP(type, 0, first, last);
4276     }
4277
4278     op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
4279     first->op_flags |= OPf_KIDS;
4280     return first;
4281 }
4282
4283 /*
4284 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
4285
4286 Concatenate the lists of ops contained directly within two list-type ops,
4287 returning the combined list.  I<first> and I<last> are the list-type ops
4288 to concatenate.  I<optype> specifies the intended opcode for the list.
4289 If either I<first> or I<last> is not already a list of the right type,
4290 it will be upgraded into one.  If either I<first> or I<last> is null,
4291 the other is returned unchanged.
4292
4293 =cut
4294 */
4295
4296 OP *
4297 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
4298 {
4299     if (!first)
4300         return last;
4301
4302     if (!last)
4303         return first;
4304
4305     if (first->op_type != (unsigned)type)
4306         return op_prepend_elem(type, first, last);
4307
4308     if (last->op_type != (unsigned)type)
4309         return op_append_elem(type, first, last);
4310
4311     ((LISTOP*)first)->op_last->op_lastsib = 0;
4312     OP_SIBLING_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
4313     ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
4314     ((LISTOP*)first)->op_last->op_lastsib = 1;
4315 #ifdef PERL_OP_PARENT
4316     ((LISTOP*)first)->op_last->op_sibling = first;
4317 #endif
4318     first->op_flags |= (last->op_flags & OPf_KIDS);
4319
4320
4321     S_op_destroy(aTHX_ last);
4322
4323     return first;
4324 }
4325
4326 /*
4327 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
4328
4329 Prepend an item to the list of ops contained directly within a list-type
4330 op, returning the lengthened list.  I<first> is the op to prepend to the
4331 list, and I<last> is the list-type op.  I<optype> specifies the intended
4332 opcode for the list.  If I<last> is not already a list of the right type,
4333 it will be upgraded into one.  If either I<first> or I<last> is null,
4334 the other is returned unchanged.
4335
4336 =cut
4337 */
4338
4339 OP *
4340 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
4341 {
4342     if (!first)
4343         return last;
4344
4345     if (!last)
4346         return first;
4347
4348     if (last->op_type == (unsigned)type) {
4349         if (type == OP_LIST) {  /* already a PUSHMARK there */
4350             /* insert 'first' after pushmark */
4351             op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
4352             if (!(first->op_flags & OPf_PARENS))
4353                 last->op_flags &= ~OPf_PARENS;
4354         }
4355         else
4356             op_sibling_splice(last, NULL, 0, first);
4357         last->op_flags |= OPf_KIDS;
4358         return last;
4359     }
4360
4361     return newLISTOP(type, 0, first, last);
4362 }
4363
4364 /*
4365 =for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
4366
4367 Converts I<o> into a list op if it is not one already, and then converts it
4368 into the specified I<type>, calling its check function, allocating a target if
4369 it needs one, and folding constants.
4370
4371 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
4372 C<op_prepend_elem> and C<op_append_elem>.  Then finally it is passed to
4373 C<op_convert> to make it the right type.
4374
4375 =cut
4376 */
4377
4378 OP *
4379 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
4380 {
4381     dVAR;
4382     if (type < 0) type = -type, flags |= OPf_SPECIAL;
4383     if (!o || o->op_type != OP_LIST)
4384         o = force_list(o, 0);
4385     else
4386         o->op_flags &= ~OPf_WANT;
4387
4388     if (!(PL_opargs[type] & OA_MARK))
4389         op_null(cLISTOPo->op_first);
4390     else {
4391         OP * const kid2 = OP_SIBLING(cLISTOPo->op_first);
4392         if (kid2 && kid2->op_type == OP_COREARGS) {
4393             op_null(cLISTOPo->op_first);
4394             kid2->op_private |= OPpCOREARGS_PUSHMARK;
4395         }
4396     }
4397
4398     CHANGE_TYPE(o, type);
4399     o->op_flags |= flags;
4400
4401     o = CHECKOP(type, o);
4402     if (o->op_type != (unsigned)type)
4403         return o;
4404
4405     return fold_constants(op_integerize(op_std_init(o)));
4406 }
4407
4408 /* Constructors */
4409
4410
4411 /*
4412 =head1 Optree construction
4413
4414 =for apidoc Am|OP *|newNULLLIST
4415
4416 Constructs, checks, and returns a new C<stub> op, which represents an
4417 empty list expression.
4418
4419 =cut
4420 */
4421
4422 OP *
4423 Perl_newNULLLIST(pTHX)
4424 {
4425     return newOP(OP_STUB, 0);
4426 }
4427
4428 /* promote o and any siblings to be a list if its not already; i.e.
4429  *
4430  *  o - A - B
4431  *
4432  * becomes
4433  *
4434  *  list
4435  *    |
4436  *  pushmark - o - A - B
4437  *
4438  * If nullit it true, the list op is nulled.
4439  */
4440
4441 static OP *
4442 S_force_list(pTHX_ OP *o, bool nullit)
4443 {
4444     if (!o || o->op_type != OP_LIST) {
4445         OP *rest = NULL;
4446         if (o) {
4447             /* manually detach any siblings then add them back later */
4448             rest = OP_SIBLING(o);
4449             OP_SIBLING_set(o, NULL);
4450             o->op_lastsib = 1;
4451         }
4452         o = newLISTOP(OP_LIST, 0, o, NULL);
4453         if (rest)
4454             op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
4455     }
4456     if (nullit)
4457         op_null(o);
4458     return o;
4459 }
4460
4461 /*
4462 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
4463
4464 Constructs, checks, and returns an op of any list type.  I<type> is
4465 the opcode.  I<flags> gives the eight bits of C<op_flags>, except that
4466 C<OPf_KIDS> will be set automatically if required.  I<first> and I<last>
4467 supply up to two ops to be direct children of the list op; they are
4468 consumed by this function and become part of the constructed op tree.
4469
4470 =cut
4471 */
4472
4473 OP *
4474 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4475 {
4476     dVAR;
4477     LISTOP *listop;
4478
4479     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
4480
4481     NewOp(1101, listop, 1, LISTOP);
4482
4483     CHANGE_TYPE(listop, type);
4484     if (first || last)
4485         flags |= OPf_KIDS;
4486     listop->op_flags = (U8)flags;
4487
4488     if (!last && first)
4489         last = first;
4490     else if (!first && last)
4491         first = last;
4492     else if (first)
4493         OP_SIBLING_set(first, last);
4494     listop->op_first = first;
4495     listop->op_last = last;
4496     if (type == OP_LIST) {
4497         OP* const pushop = newOP(OP_PUSHMARK, 0);
4498         pushop->op_lastsib = 0;
4499         OP_SIBLING_set(pushop, first);
4500         listop->op_first = pushop;
4501         listop->op_flags |= OPf_KIDS;
4502         if (!last)
4503             listop->op_last = pushop;
4504     }
4505     if (first)
4506         first->op_lastsib = 0;
4507     if (listop->op_last) {
4508         listop->op_last->op_lastsib = 1;
4509 #ifdef PERL_OP_PARENT
4510         listop->op_last->op_sibling = (OP*)listop;
4511 #endif
4512     }
4513
4514     return CHECKOP(type, listop);
4515 }
4516
4517 /*
4518 =for apidoc Am|OP *|newOP|I32 type|I32 flags
4519
4520 Constructs, checks, and returns an op of any base type (any type that
4521 has no extra fields).  I<type> is the opcode.  I<flags> gives the
4522 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
4523 of C<op_private>.
4524
4525 =cut
4526 */
4527
4528 OP *
4529 Perl_newOP(pTHX_ I32 type, I32 flags)
4530 {
4531     dVAR;
4532     OP *o;
4533
4534     if (type == -OP_ENTEREVAL) {
4535         type = OP_ENTEREVAL;
4536         flags |= OPpEVAL_BYTES<<8;
4537     }
4538
4539     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
4540         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4541         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4542         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4543
4544     NewOp(1101, o, 1, OP);
4545     CHANGE_TYPE(o, type);
4546     o->op_flags = (U8)flags;
4547
4548     o->op_next = o;
4549     o->op_private = (U8)(0 | (flags >> 8));
4550     if (PL_opargs[type] & OA_RETSCALAR)
4551         scalar(o);
4552     if (PL_opargs[type] & OA_TARGET)
4553         o->op_targ = pad_alloc(type, SVs_PADTMP);
4554     return CHECKOP(type, o);
4555 }
4556
4557 /*
4558 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
4559
4560 Constructs, checks, and returns an op of any unary type.  I<type> is
4561 the opcode.  I<flags> gives the eight bits of C<op_flags>, except that
4562 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
4563 bits, the eight bits of C<op_private>, except that the bit with value 1
4564 is automatically set.  I<first> supplies an optional op to be the direct
4565 child of the unary op; it is consumed by this function and become part
4566 of the constructed op tree.
4567
4568 =cut
4569 */
4570
4571 OP *
4572 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
4573 {
4574     dVAR;
4575     UNOP *unop;
4576
4577     if (type == -OP_ENTEREVAL) {
4578         type = OP_ENTEREVAL;
4579         flags |= OPpEVAL_BYTES<<8;
4580     }
4581
4582     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
4583         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4584         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4585         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
4586         || type == OP_SASSIGN
4587         || type == OP_ENTERTRY
4588         || type == OP_NULL );
4589
4590     if (!first)
4591         first = newOP(OP_STUB, 0);
4592     if (PL_opargs[type] & OA_MARK)
4593         first = force_list(first, 1);
4594
4595     NewOp(1101, unop, 1, UNOP);
4596     CHANGE_TYPE(unop, type);
4597     unop->op_first = first;
4598     unop->op_flags = (U8)(flags | OPf_KIDS);
4599     unop->op_private = (U8)(1 | (flags >> 8));
4600
4601 #ifdef PERL_OP_PARENT
4602     if (!OP_HAS_SIBLING(first)) /* true unless weird syntax error */
4603         first->op_sibling = (OP*)unop;
4604 #endif
4605
4606     unop = (UNOP*) CHECKOP(type, unop);
4607     if (unop->op_next)
4608         return (OP*)unop;
4609
4610     return fold_constants(op_integerize(op_std_init((OP *) unop)));
4611 }
4612
4613 /*
4614 =for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
4615
4616 Constructs, checks, and returns an op of method type with a method name
4617 evaluated at runtime.  I<type> is the opcode.  I<flags> gives the eight
4618 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
4619 and, shifted up eight bits, the eight bits of C<op_private>, except that
4620 the bit with value 1 is automatically set.  I<dynamic_meth> supplies an
4621 op which evaluates method name; it is consumed by this function and
4622 become part of the constructed op tree.
4623 Supported optypes: OP_METHOD.
4624
4625 =cut
4626 */
4627
4628 static OP*
4629 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
4630     dVAR;
4631     METHOP *methop;
4632
4633     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP);
4634
4635     NewOp(1101, methop, 1, METHOP);
4636     if (dynamic_meth) {
4637         if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
4638         methop->op_flags = (U8)(flags | OPf_KIDS);
4639         methop->op_u.op_first = dynamic_meth;
4640         methop->op_private = (U8)(1 | (flags >> 8));
4641     }
4642     else {
4643         assert(const_meth);
4644         methop->op_flags = (U8)(flags & ~OPf_KIDS);
4645         methop->op_u.op_meth_sv = const_meth;
4646         methop->op_private = (U8)(0 | (flags >> 8));
4647         methop->op_next = (OP*)methop;
4648     }
4649
4650     CHANGE_TYPE(methop, type);
4651     methop = (METHOP*) CHECKOP(type, methop);
4652
4653     if (methop->op_next) return (OP*)methop;
4654
4655     return fold_constants(op_integerize(op_std_init((OP *) methop)));
4656 }
4657
4658 OP *
4659 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
4660     PERL_ARGS_ASSERT_NEWMETHOP;
4661     return newMETHOP_internal(type, flags, dynamic_meth, NULL);
4662 }
4663
4664 /*
4665 =for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
4666
4667 Constructs, checks, and returns an op of method type with a constant
4668 method name.  I<type> is the opcode.  I<flags> gives the eight bits of
4669 C<op_flags>, and, shifted up eight bits, the eight bits of
4670 C<op_private>.  I<const_meth> supplies a constant method name;
4671 it must be a shared COW string.
4672 Supported optypes: OP_METHOD_NAMED.
4673
4674 =cut
4675 */
4676
4677 OP *
4678 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
4679     PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
4680     return newMETHOP_internal(type, flags, NULL, const_meth);
4681 }
4682
4683 /*
4684 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
4685
4686 Constructs, checks, and returns an op of any binary type.  I<type>
4687 is the opcode.  I<flags> gives the eight bits of C<op_flags>, except
4688 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4689 the eight bits of C<op_private>, except that the bit with value 1 or
4690 2 is automatically set as required.  I<first> and I<last> supply up to
4691 two ops to be the direct children of the binary op; they are consumed
4692 by this function and become part of the constructed op tree.
4693
4694 =cut
4695 */
4696
4697 OP *
4698 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4699 {
4700     dVAR;
4701     BINOP *binop;
4702
4703     ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
4704         || type == OP_SASSIGN || type == OP_NULL );
4705
4706     NewOp(1101, binop, 1, BINOP);
4707
4708     if (!first)
4709         first = newOP(OP_NULL, 0);
4710
4711     CHANGE_TYPE(binop, type);
4712     binop->op_first = first;
4713     binop->op_flags = (U8)(flags | OPf_KIDS);
4714     if (!last) {
4715         last = first;
4716         binop->op_private = (U8)(1 | (flags >> 8));
4717     }
4718     else {
4719         binop->op_private = (U8)(2 | (flags >> 8));
4720         OP_SIBLING_set(first, last);
4721         first->op_lastsib = 0;
4722     }
4723
4724 #ifdef PERL_OP_PARENT
4725     if (!OP_HAS_SIBLING(last)) /* true unless weird syntax error */
4726         last->op_sibling = (OP*)binop;
4727 #endif
4728
4729     binop->op_last = OP_SIBLING(binop->op_first);
4730 #ifdef PERL_OP_PARENT
4731     if (binop->op_last)
4732         binop->op_last->op_sibling = (OP*)binop;
4733 #endif
4734
4735     binop = (BINOP*)CHECKOP(type, binop);
4736     if (binop->op_next || binop->op_type != (OPCODE)type)
4737         return (OP*)binop;
4738
4739     return fold_constants(op_integerize(op_std_init((OP *)binop)));
4740 }
4741
4742 static int uvcompare(const void *a, const void *b)
4743     __attribute__nonnull__(1)
4744     __attribute__nonnull__(2)
4745     __attribute__pure__;
4746 static int uvcompare(const void *a, const void *b)
4747 {
4748     if (*((const UV *)a) < (*(const UV *)b))
4749         return -1;
4750     if (*((const UV *)a) > (*(const UV *)b))
4751         return 1;
4752     if (*((const UV *)a+1) < (*(const UV *)b+1))
4753         return -1;
4754     if (*((const UV *)a+1) > (*(const UV *)b+1))
4755         return 1;
4756     return 0;
4757 }
4758
4759 static OP *
4760 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
4761 {
4762     SV * const tstr = ((SVOP*)expr)->op_sv;
4763     SV * const rstr =
4764                               ((SVOP*)repl)->op_sv;
4765     STRLEN tlen;
4766     STRLEN rlen;
4767     const U8 *t = (U8*)SvPV_const(tstr, tlen);
4768     const U8 *r = (U8*)SvPV_const(rstr, rlen);
4769     I32 i;
4770     I32 j;
4771     I32 grows = 0;
4772     short *tbl;
4773
4774     const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
4775     const I32 squash     = o->op_private & OPpTRANS_SQUASH;
4776     I32 del              = o->op_private & OPpTRANS_DELETE;
4777     SV* swash;
4778
4779     PERL_ARGS_ASSERT_PMTRANS;
4780
4781     PL_hints |= HINT_BLOCK_SCOPE;
4782
4783     if (SvUTF8(tstr))
4784         o->op_private |= OPpTRANS_FROM_UTF;
4785
4786     if (SvUTF8(rstr))
4787         o->op_private |= OPpTRANS_TO_UTF;
4788
4789     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
4790         SV* const listsv = newSVpvs("# comment\n");
4791         SV* transv = NULL;
4792         const U8* tend = t + tlen;
4793         const U8* rend = r + rlen;
4794         STRLEN ulen;
4795         UV tfirst = 1;
4796         UV tlast = 0;
4797         IV tdiff;
4798         STRLEN tcount = 0;
4799         UV rfirst = 1;
4800         UV rlast = 0;
4801         IV rdiff;
4802         STRLEN rcount = 0;
4803         IV diff;
4804         I32 none = 0;
4805         U32 max = 0;
4806         I32 bits;
4807         I32 havefinal = 0;
4808         U32 final = 0;
4809         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
4810         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
4811         U8* tsave = NULL;
4812         U8* rsave = NULL;
4813         const U32 flags = UTF8_ALLOW_DEFAULT;
4814
4815         if (!from_utf) {
4816             STRLEN len = tlen;
4817             t = tsave = bytes_to_utf8(t, &len);
4818             tend = t + len;
4819         }
4820         if (!to_utf && rlen) {
4821             STRLEN len = rlen;
4822             r = rsave = bytes_to_utf8(r, &len);
4823             rend = r + len;
4824         }
4825
4826 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
4827  * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
4828  * odd.  */
4829
4830         if (complement) {
4831             U8 tmpbuf[UTF8_MAXBYTES+1];
4832             UV *cp;
4833             UV nextmin = 0;
4834             Newx(cp, 2*tlen, UV);
4835             i = 0;
4836             transv = newSVpvs("");
4837             while (t < tend) {
4838                 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
4839                 t += ulen;
4840                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
4841                     t++;
4842                     cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
4843                     t += ulen;
4844                 }
4845                 else {
4846                  cp[2*i+1] = cp[2*i];
4847                 }
4848                 i++;
4849             }
4850             qsort(cp, i, 2*sizeof(UV), uvcompare);
4851             for (j = 0; j < i; j++) {
4852                 UV  val = cp[2*j];
4853                 diff = val - nextmin;
4854                 if (diff > 0) {
4855                     t = uvchr_to_utf8(tmpbuf,nextmin);
4856                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4857                     if (diff > 1) {
4858                         U8  range_mark = ILLEGAL_UTF8_BYTE;
4859                         t = uvchr_to_utf8(tmpbuf, val - 1);
4860                         sv_catpvn(transv, (char *)&range_mark, 1);
4861                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4862                     }
4863                 }
4864                 val = cp[2*j+1];
4865                 if (val >= nextmin)
4866                     nextmin = val + 1;
4867             }
4868             t = uvchr_to_utf8(tmpbuf,nextmin);
4869             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4870             {
4871                 U8 range_mark = ILLEGAL_UTF8_BYTE;
4872                 sv_catpvn(transv, (char *)&range_mark, 1);
4873             }
4874             t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
4875             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4876             t = (const U8*)SvPVX_const(transv);
4877             tlen = SvCUR(transv);
4878             tend = t + tlen;
4879             Safefree(cp);
4880         }
4881         else if (!rlen && !del) {
4882             r = t; rlen = tlen; rend = tend;
4883         }
4884         if (!squash) {
4885                 if ((!rlen && !del) || t == r ||
4886                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
4887                 {
4888                     o->op_private |= OPpTRANS_IDENTICAL;
4889                 }
4890         }
4891
4892         while (t < tend || tfirst <= tlast) {
4893             /* see if we need more "t" chars */
4894             if (tfirst > tlast) {
4895                 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
4896                 t += ulen;
4897                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {      /* illegal utf8 val indicates range */
4898                     t++;
4899                     tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
4900                     t += ulen;
4901                 }
4902                 else
4903                     tlast = tfirst;
4904             }
4905
4906             /* now see if we need more "r" chars */
4907             if (rfirst > rlast) {
4908                 if (r < rend) {
4909                     rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
4910                     r += ulen;
4911                     if (r < rend && *r == ILLEGAL_UTF8_BYTE) {  /* illegal utf8 val indicates range */
4912                         r++;
4913                         rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
4914                         r += ulen;
4915                     }
4916                     else
4917                         rlast = rfirst;
4918                 }
4919                 else {
4920                     if (!havefinal++)
4921                         final = rlast;
4922                     rfirst = rlast = 0xffffffff;
4923                 }
4924             }
4925
4926             /* now see which range will peter our first, if either. */
4927             tdiff = tlast - tfirst;
4928             rdiff = rlast - rfirst;
4929             tcount += tdiff + 1;
4930             rcount += rdiff + 1;
4931
4932             if (tdiff <= rdiff)
4933                 diff = tdiff;
4934             else
4935                 diff = rdiff;
4936
4937             if (rfirst == 0xffffffff) {
4938                 diff = tdiff;   /* oops, pretend rdiff is infinite */
4939                 if (diff > 0)
4940                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
4941                                    (long)tfirst, (long)tlast);
4942                 else
4943                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
4944             }
4945             else {
4946                 if (diff > 0)
4947                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
4948                                    (long)tfirst, (long)(tfirst + diff),
4949                                    (long)rfirst);
4950                 else
4951                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
4952                                    (long)tfirst, (long)rfirst);
4953
4954                 if (rfirst + diff > max)
4955                     max = rfirst + diff;
4956                 if (!grows)
4957                     grows = (tfirst < rfirst &&
4958                              UNISKIP(tfirst) < UNISKIP(rfirst + diff));
4959                 rfirst += diff + 1;
4960             }
4961             tfirst += diff + 1;
4962         }
4963
4964         none = ++max;
4965         if (del)
4966             del = ++max;
4967
4968         if (max > 0xffff)
4969             bits = 32;
4970         else if (max > 0xff)
4971             bits = 16;
4972         else
4973             bits = 8;
4974
4975         swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
4976 #ifdef USE_ITHREADS
4977         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
4978         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
4979         PAD_SETSV(cPADOPo->op_padix, swash);
4980         SvPADTMP_on(swash);
4981         SvREADONLY_on(swash);
4982 #else
4983         cSVOPo->op_sv = swash;
4984 #endif
4985         SvREFCNT_dec(listsv);
4986         SvREFCNT_dec(transv);
4987
4988         if (!del && havefinal && rlen)
4989             (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
4990                            newSVuv((UV)final), 0);
4991
4992         Safefree(tsave);
4993         Safefree(rsave);
4994
4995         tlen = tcount;
4996         rlen = rcount;
4997         if (r < rend)
4998             rlen++;
4999         else if (rlast == 0xffffffff)
5000             rlen = 0;
5001
5002         goto warnins;
5003     }
5004
5005     tbl = (short*)PerlMemShared_calloc(
5006         (o->op_private & OPpTRANS_COMPLEMENT) &&
5007             !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
5008         sizeof(short));
5009     cPVOPo->op_pv = (char*)tbl;
5010     if (complement) {
5011         for (i = 0; i < (I32)tlen; i++)
5012             tbl[t[i]] = -1;
5013         for (i = 0, j = 0; i < 256; i++) {
5014             if (!tbl[i]) {
5015                 if (j >= (I32)rlen) {
5016                     if (del)
5017                         tbl[i] = -2;
5018                     else if (rlen)
5019                         tbl[i] = r[j-1];
5020                     else
5021                         tbl[i] = (short)i;
5022                 }
5023                 else {
5024                     if (i < 128 && r[j] >= 128)
5025                         grows = 1;
5026                     tbl[i] = r[j++];
5027                 }
5028             }
5029         }
5030         if (!del) {
5031             if (!rlen) {
5032                 j = rlen;
5033                 if (!squash)
5034                     o->op_private |= OPpTRANS_IDENTICAL;
5035             }
5036             else if (j >= (I32)rlen)
5037                 j = rlen - 1;
5038             else {
5039                 tbl =
5040                     (short *)
5041                     PerlMemShared_realloc(tbl,
5042                                           (0x101+rlen-j) * sizeof(short));
5043                 cPVOPo->op_pv = (char*)tbl;
5044             }
5045             tbl[0x100] = (short)(rlen - j);
5046             for (i=0; i < (I32)rlen - j; i++)
5047                 tbl[0x101+i] = r[j+i];
5048         }
5049     }
5050     else {
5051         if (!rlen && !del) {
5052             r = t; rlen = tlen;
5053             if (!squash)
5054                 o->op_private |= OPpTRANS_IDENTICAL;
5055         }
5056         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
5057             o->op_private |= OPpTRANS_IDENTICAL;
5058         }
5059         for (i = 0; i < 256; i++)
5060             tbl[i] = -1;
5061         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
5062             if (j >= (I32)rlen) {
5063                 if (del) {
5064                     if (tbl[t[i]] == -1)
5065                         tbl[t[i]] = -2;
5066                     continue;
5067                 }
5068                 --j;
5069             }
5070             if (tbl[t[i]] == -1) {
5071                 if (t[i] < 128 && r[j] >= 128)
5072                     grows = 1;
5073                 tbl[t[i]] = r[j];
5074             }
5075         }
5076     }
5077
5078   warnins:
5079     if(del && rlen == tlen) {
5080         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
5081     } else if(rlen > tlen && !complement) {
5082         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
5083     }
5084
5085     if (grows)
5086         o->op_private |= OPpTRANS_GROWS;
5087     op_free(expr);
5088     op_free(repl);
5089
5090     return o;
5091 }
5092
5093 /*
5094 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
5095
5096 Constructs, checks, and returns an op of any pattern matching type.
5097 I<type> is the opcode.  I<flags> gives the eight bits of C<op_flags>
5098 and, shifted up eight bits, the eight bits of C<op_private>.
5099
5100 =cut
5101 */
5102
5103 OP *
5104 Perl_newPMOP(pTHX_ I32 type, I32 flags)
5105 {
5106     dVAR;
5107     PMOP *pmop;
5108
5109     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
5110
5111     NewOp(1101, pmop, 1, PMOP);
5112     CHANGE_TYPE(pmop, type);
5113     pmop->op_flags = (U8)flags;
5114     pmop->op_private = (U8)(0 | (flags >> 8));
5115
5116     if (PL_hints & HINT_RE_TAINT)
5117         pmop->op_pmflags |= PMf_RETAINT;
5118 #ifdef USE_LOCALE_CTYPE
5119     if (IN_LC_COMPILETIME(LC_CTYPE)) {
5120         set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
5121     }
5122     else
5123 #endif
5124          if (IN_UNI_8_BIT) {
5125         set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
5126     }
5127     if (PL_hints & HINT_RE_FLAGS) {
5128         SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5129          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
5130         );
5131         if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
5132         reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5133          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
5134         );
5135         if (reflags && SvOK(reflags)) {
5136             set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
5137         }
5138     }
5139
5140
5141 #ifdef USE_ITHREADS
5142     assert(SvPOK(PL_regex_pad[0]));
5143     if (SvCUR(PL_regex_pad[0])) {
5144         /* Pop off the "packed" IV from the end.  */
5145         SV *const repointer_list = PL_regex_pad[0];
5146         const char *p = SvEND(repointer_list) - sizeof(IV);
5147         const IV offset = *((IV*)p);
5148
5149         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
5150
5151         SvEND_set(repointer_list, p);
5152
5153         pmop->op_pmoffset = offset;
5154         /* This slot should be free, so assert this:  */
5155         assert(PL_regex_pad[offset] == &PL_sv_undef);
5156     } else {
5157         SV * const repointer = &PL_sv_undef;
5158         av_push(PL_regex_padav, repointer);
5159         pmop->op_pmoffset = av_tindex(PL_regex_padav);
5160         PL_regex_pad = AvARRAY(PL_regex_padav);
5161     }
5162 #endif
5163
5164     return CHECKOP(type, pmop);
5165 }
5166
5167 /* Given some sort of match op o, and an expression expr containing a
5168  * pattern, either compile expr into a regex and attach it to o (if it's
5169  * constant), or convert expr into a runtime regcomp op sequence (if it's
5170  * not)
5171  *
5172  * isreg indicates that the pattern is part of a regex construct, eg
5173  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
5174  * split "pattern", which aren't. In the former case, expr will be a list
5175  * if the pattern contains more than one term (eg /a$b/) or if it contains
5176  * a replacement, ie s/// or tr///.
5177  *
5178  * When the pattern has been compiled within a new anon CV (for
5179  * qr/(?{...})/ ), then floor indicates the savestack level just before
5180  * the new sub was created
5181  */
5182
5183 OP *
5184 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor)
5185 {
5186     dVAR;
5187     PMOP *pm;
5188     LOGOP *rcop;
5189     I32 repl_has_vars = 0;
5190     OP* repl = NULL;
5191     bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
5192     bool is_compiletime;
5193     bool has_code;
5194
5195     PERL_ARGS_ASSERT_PMRUNTIME;
5196
5197     /* for s/// and tr///, last element in list is the replacement; pop it */
5198
5199     if (is_trans || o->op_type == OP_SUBST) {
5200         OP* kid;
5201         repl = cLISTOPx(expr)->op_last;
5202         kid = cLISTOPx(expr)->op_first;
5203         while (OP_SIBLING(kid) != repl)
5204             kid = OP_SIBLING(kid);
5205         op_sibling_splice(expr, kid, 1, NULL);
5206     }
5207
5208     /* for TRANS, convert LIST/PUSH/CONST into CONST, and pass to pmtrans() */
5209
5210     if (is_trans) {
5211         OP *first, *last;
5212
5213         assert(expr->op_type == OP_LIST);
5214         first = cLISTOPx(expr)->op_first;
5215         last  = cLISTOPx(expr)->op_last;
5216         assert(first->op_type == OP_PUSHMARK);
5217         assert(OP_SIBLING(first) == last);
5218
5219         /* cut 'last' from sibling chain, then free everything else */
5220         op_sibling_splice(expr, first, 1, NULL);
5221         op_free(expr);
5222
5223         return pmtrans(o, last, repl);
5224     }
5225
5226     /* find whether we have any runtime or code elements;
5227      * at the same time, temporarily set the op_next of each DO block;
5228      * then when we LINKLIST, this will cause the DO blocks to be excluded
5229      * from the op_next chain (and from having LINKLIST recursively
5230      * applied to them). We fix up the DOs specially later */
5231
5232     is_compiletime = 1;
5233     has_code = 0;
5234     if (expr->op_type == OP_LIST) {
5235         OP *o;
5236         for (o = cLISTOPx(expr)->op_first; o; o = OP_SIBLING(o)) {
5237             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
5238                 has_code = 1;
5239                 assert(!o->op_next);
5240                 if (UNLIKELY(!OP_HAS_SIBLING(o))) {
5241                     assert(PL_parser && PL_parser->error_count);
5242                     /* This can happen with qr/ (?{(^{})/.  Just fake up
5243                        the op we were expecting to see, to avoid crashing
5244                        elsewhere.  */
5245                     op_sibling_splice(expr, o, 0,
5246                                       newSVOP(OP_CONST, 0, &PL_sv_no));
5247                 }
5248                 o->op_next = OP_SIBLING(o);
5249             }
5250             else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
5251                 is_compiletime = 0;
5252         }
5253     }
5254     else if (expr->op_type != OP_CONST)
5255         is_compiletime = 0;
5256
5257     LINKLIST(expr);
5258
5259     /* fix up DO blocks; treat each one as a separate little sub;
5260      * also, mark any arrays as LIST/REF */
5261
5262     if (expr->op_type == OP_LIST) {
5263         OP *o;
5264         for (o = cLISTOPx(expr)->op_first; o; o = OP_SIBLING(o)) {
5265
5266             if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
5267                 assert( !(o->op_flags  & OPf_WANT));
5268                 /* push the array rather than its contents. The regex
5269                  * engine will retrieve and join the elements later */
5270                 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
5271                 continue;
5272             }
5273
5274             if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
5275                 continue;
5276             o->op_next = NULL; /* undo temporary hack from above */
5277             scalar(o);
5278             LINKLIST(o);
5279             if (cLISTOPo->op_first->op_type == OP_LEAVE) {
5280                 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
5281                 /* skip ENTER */
5282                 assert(leaveop->op_first->op_type == OP_ENTER);
5283                 assert(OP_HAS_SIBLING(leaveop->op_first));
5284                 o->op_next = OP_SIBLING(leaveop->op_first);
5285                 /* skip leave */
5286                 assert(leaveop->op_flags & OPf_KIDS);
5287                 assert(leaveop->op_last->op_next == (OP*)leaveop);
5288                 leaveop->op_next = NULL; /* stop on last op */
5289                 op_null((OP*)leaveop);
5290             }
5291             else {
5292                 /* skip SCOPE */
5293                 OP *scope = cLISTOPo->op_first;
5294                 assert(scope->op_type == OP_SCOPE);
5295                 assert(scope->op_flags & OPf_KIDS);
5296                 scope->op_next = NULL; /* stop on last op */
5297                 op_null(scope);
5298             }
5299             /* have to peep the DOs individually as we've removed it from
5300              * the op_next chain */
5301             CALL_PEEP(o);
5302             S_prune_chain_head(&(o->op_next));
5303             if (is_compiletime)
5304                 /* runtime finalizes as part of finalizing whole tree */
5305                 finalize_optree(o);
5306         }
5307     }
5308     else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
5309         assert( !(expr->op_flags  & OPf_WANT));
5310         /* push the array rather than its contents. The regex
5311          * engine will retrieve and join the elements later */
5312         expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
5313     }
5314
5315     PL_hints |= HINT_BLOCK_SCOPE;
5316     pm = (PMOP*)o;
5317     assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
5318
5319     if (is_compiletime) {
5320         U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
5321         regexp_engine const *eng = current_re_engine();
5322
5323         if (o->op_flags & OPf_SPECIAL)
5324             rx_flags |= RXf_SPLIT;
5325
5326         if (!has_code || !eng->op_comp) {
5327             /* compile-time simple constant pattern */
5328
5329             if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
5330                 /* whoops! we guessed that a qr// had a code block, but we
5331                  * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
5332                  * that isn't required now. Note that we have to be pretty
5333                  * confident that nothing used that CV's pad while the
5334                  * regex was parsed */
5335                 assert(AvFILLp(PL_comppad) == 0); /* just @_ */
5336                 /* But we know that one op is using this CV's slab. */
5337                 cv_forget_slab(PL_compcv);
5338                 LEAVE_SCOPE(floor);
5339                 pm->op_pmflags &= ~PMf_HAS_CV;
5340             }
5341
5342             PM_SETRE(pm,
5343                 eng->op_comp
5344                     ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5345                                         rx_flags, pm->op_pmflags)
5346                     : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5347                                         rx_flags, pm->op_pmflags)
5348             );
5349             op_free(expr);
5350         }
5351         else {
5352             /* compile-time pattern that includes literal code blocks */
5353             REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5354                         rx_flags,
5355                         (pm->op_pmflags |
5356                             ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
5357                     );
5358             PM_SETRE(pm, re);
5359             if (pm->op_pmflags & PMf_HAS_CV) {
5360                 CV *cv;
5361                 /* this QR op (and the anon sub we embed it in) is never
5362                  * actually executed. It's just a placeholder where we can
5363                  * squirrel away expr in op_code_list without the peephole
5364                  * optimiser etc processing it for a second time */
5365                 OP *qr = newPMOP(OP_QR, 0);
5366                 ((PMOP*)qr)->op_code_list = expr;
5367
5368                 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
5369                 SvREFCNT_inc_simple_void(PL_compcv);
5370                 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
5371                 ReANY(re)->qr_anoncv = cv;
5372
5373                 /* attach the anon CV to the pad so that
5374                  * pad_fixup_inner_anons() can find it */
5375                 (void)pad_add_anon(cv, o->op_type);
5376                 SvREFCNT_inc_simple_void(cv);
5377             }
5378             else {
5379                 pm->op_code_list = expr;
5380             }
5381         }
5382     }
5383     else {
5384         /* runtime pattern: build chain of regcomp etc ops */
5385         bool reglist;
5386         PADOFFSET cv_targ = 0;
5387
5388         reglist = isreg && expr->op_type == OP_LIST;
5389         if (reglist)
5390             op_null(expr);
5391
5392         if (has_code) {
5393             pm->op_code_list = expr;
5394             /* don't free op_code_list; its ops are embedded elsewhere too */
5395             pm->op_pmflags |= PMf_CODELIST_PRIVATE;
5396         }
5397
5398         if (o->op_flags & OPf_SPECIAL)
5399             pm->op_pmflags |= PMf_SPLIT;
5400
5401         /* the OP_REGCMAYBE is a placeholder in the non-threaded case
5402          * to allow its op_next to be pointed past the regcomp and
5403          * preceding stacking ops;
5404          * OP_REGCRESET is there to reset taint before executing the
5405          * stacking ops */
5406         if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
5407             expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
5408
5409         if (pm->op_pmflags & PMf_HAS_CV) {
5410             /* we have a runtime qr with literal code. This means
5411              * that the qr// has been wrapped in a new CV, which
5412              * means that runtime consts, vars etc will have been compiled
5413              * against a new pad. So... we need to execute those ops
5414              * within the environment of the new CV. So wrap them in a call
5415              * to a new anon sub. i.e. for
5416              *
5417              *     qr/a$b(?{...})/,
5418              *
5419              * we build an anon sub that looks like
5420              *
5421              *     sub { "a", $b, '(?{...})' }
5422              *
5423              * and call it, passing the returned list to regcomp.
5424              * Or to put it another way, the list of ops that get executed
5425              * are:
5426              *
5427              *     normal              PMf_HAS_CV
5428              *     ------              -------------------
5429              *                         pushmark (for regcomp)
5430              *                         pushmark (for entersub)
5431              *                         anoncode
5432              *                         srefgen
5433              *                         entersub
5434              *     regcreset                  regcreset
5435              *     pushmark                   pushmark
5436              *     const("a")                 const("a")
5437              *     gvsv(b)                    gvsv(b)
5438              *     const("(?{...})")          const("(?{...})")
5439              *                                leavesub
5440              *     regcomp             regcomp
5441              */
5442
5443             SvREFCNT_inc_simple_void(PL_compcv);
5444             /* these lines are just an unrolled newANONATTRSUB */
5445             expr = newSVOP(OP_ANONCODE, 0,
5446                     MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
5447             cv_targ = expr->op_targ;
5448             expr = newUNOP(OP_REFGEN, 0, expr);
5449
5450             expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
5451         }
5452
5453         rcop = S_alloc_LOGOP(aTHX_ OP_REGCOMP, scalar(expr), o);
5454         rcop->op_flags |=  ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
5455                            | (reglist ? OPf_STACKED : 0);
5456         rcop->op_targ = cv_targ;
5457
5458         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
5459         if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
5460
5461         /* establish postfix order */
5462         if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
5463             LINKLIST(expr);
5464             rcop->op_next = expr;
5465             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
5466         }
5467         else {
5468             rcop->op_next = LINKLIST(expr);
5469             expr->op_next = (OP*)rcop;
5470         }
5471
5472         op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
5473     }
5474
5475     if (repl) {
5476         OP *curop = repl;
5477         bool konst;
5478         /* If we are looking at s//.../e with a single statement, get past
5479            the implicit do{}. */
5480         if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
5481              && cUNOPx(curop)->op_first->op_type == OP_SCOPE
5482              && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
5483          {
5484             OP *sib;
5485             OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
5486             if (kid->op_type == OP_NULL && (sib = OP_SIBLING(kid))
5487                      && !OP_HAS_SIBLING(sib))
5488                 curop = sib;
5489         }
5490         if (curop->op_type == OP_CONST)
5491             konst = TRUE;
5492         else if (( (curop->op_type == OP_RV2SV ||
5493                     curop->op_type == OP_RV2AV ||
5494                     curop->op_type == OP_RV2HV ||
5495                     curop->op_type == OP_RV2GV)
5496                    && cUNOPx(curop)->op_first
5497                    && cUNOPx(curop)->op_first->op_type == OP_GV )
5498                 || curop->op_type == OP_PADSV
5499                 || curop->op_type == OP_PADAV
5500                 || curop->op_type == OP_PADHV
5501                 || curop->op_type == OP_PADANY) {
5502             repl_has_vars = 1;
5503             konst = TRUE;
5504         }
5505         else konst = FALSE;
5506         if (konst
5507             && !(repl_has_vars
5508                  && (!PM_GETRE(pm)
5509                      || !RX_PRELEN(PM_GETRE(pm))
5510                      || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
5511         {
5512             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
5513             op_prepend_elem(o->op_type, scalar(repl), o);
5514         }
5515         else {
5516             rcop = S_alloc_LOGOP(aTHX_ OP_SUBSTCONT, scalar(repl), o);
5517             rcop->op_private = 1;
5518
5519             /* establish postfix order */
5520             rcop->op_next = LINKLIST(repl);
5521             repl->op_next = (OP*)rcop;
5522
5523             pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
5524             assert(!(pm->op_pmflags & PMf_ONCE));
5525             pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
5526             rcop->op_next = 0;
5527         }
5528     }
5529
5530     return (OP*)pm;
5531 }
5532
5533 /*
5534 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
5535
5536 Constructs, checks, and returns an op of any type that involves an
5537 embedded SV.  I<type> is the opcode.  I<flags> gives the eight bits
5538 of C<op_flags>.  I<sv> gives the SV to embed in the op; this function
5539 takes ownership of one reference to it.
5540
5541 =cut
5542 */
5543
5544 OP *
5545 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
5546 {
5547     dVAR;
5548     SVOP *svop;
5549
5550     PERL_ARGS_ASSERT_NEWSVOP;
5551
5552     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5553         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5554         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
5555
5556     NewOp(1101, svop, 1, SVOP);
5557     CHANGE_TYPE(svop, type);
5558     svop->op_sv = sv;
5559     svop->op_next = (OP*)svop;
5560     svop->op_flags = (U8)flags;
5561     svop->op_private = (U8)(0 | (flags >> 8));
5562     if (PL_opargs[type] & OA_RETSCALAR)
5563         scalar((OP*)svop);
5564     if (PL_opargs[type] & OA_TARGET)
5565         svop->op_targ = pad_alloc(type, SVs_PADTMP);
5566     return CHECKOP(type, svop);
5567 }
5568
5569 /*
5570 =for apidoc Am|OP *|newDEFSVOP|
5571
5572 Constructs and returns an op to access C<$_>, either as a lexical
5573 variable (if declared as C<my $_>) in the current scope, or the
5574 global C<$_>.
5575
5576 =cut
5577 */
5578
5579 OP *
5580 Perl_newDEFSVOP(pTHX)
5581 {
5582     const PADOFFSET offset = pad_findmy_pvs("$_", 0);
5583     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5584         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
5585     }
5586     else {
5587         OP * const o = newOP(OP_PADSV, 0);
5588         o->op_targ = offset;
5589         return o;
5590     }
5591 }
5592
5593 #ifdef USE_ITHREADS
5594
5595 /*
5596 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
5597
5598 Constructs, checks, and returns an op of any type that involves a
5599 reference to a pad element.  I<type> is the opcode.  I<flags> gives the
5600 eight bits of C<op_flags>.  A pad slot is automatically allocated, and
5601 is populated with I<sv>; this function takes ownership of one reference
5602 to it.
5603
5604 This function only exists if Perl has been compiled to use ithreads.
5605
5606 =cut
5607 */
5608
5609 OP *
5610 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
5611 {
5612     dVAR;
5613     PADOP *padop;
5614
5615     PERL_ARGS_ASSERT_NEWPADOP;
5616
5617     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5618         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5619         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
5620
5621     NewOp(1101, padop, 1, PADOP);
5622     CHANGE_TYPE(padop, type);
5623     padop->op_padix =
5624         pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
5625     SvREFCNT_dec(PAD_SVl(padop->op_padix));
5626     PAD_SETSV(padop->op_padix, sv);
5627     assert(sv);
5628     padop->op_next = (OP*)padop;
5629     padop->op_flags = (U8)flags;
5630     if (PL_opargs[type] & OA_RETSCALAR)
5631         scalar((OP*)padop);
5632     if (PL_opargs[type] & OA_TARGET)
5633         padop->op_targ = pad_alloc(type, SVs_PADTMP);
5634     return CHECKOP(type, padop);
5635 }
5636
5637 #endif /* USE_ITHREADS */
5638
5639 /*
5640 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
5641
5642 Constructs, checks, and returns an op of any type that involves an
5643 embedded reference to a GV.  I<type> is the opcode.  I<flags> gives the
5644 eight bits of C<op_flags>.  I<gv> identifies the GV that the op should
5645 reference; calling this function does not transfer ownership of any
5646 reference to it.
5647
5648 =cut
5649 */
5650
5651 OP *
5652 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
5653 {
5654     PERL_ARGS_ASSERT_NEWGVOP;
5655
5656 #ifdef USE_ITHREADS
5657     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5658 #else
5659     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5660 #endif
5661 }
5662
5663 /*
5664 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
5665
5666 Constructs, checks, and returns an op of any type that involves an
5667 embedded C-level pointer (PV).  I<type> is the opcode.  I<flags> gives
5668 the eight bits of C<op_flags>.  I<pv> supplies the C-level pointer, which
5669 must have been allocated using C<PerlMemShared_malloc>; the memory will
5670 be freed when the op is destroyed.
5671
5672 =cut
5673 */
5674
5675 OP *
5676 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
5677 {
5678     dVAR;
5679     const bool utf8 = cBOOL(flags & SVf_UTF8);
5680     PVOP *pvop;
5681
5682     flags &= ~SVf_UTF8;
5683
5684     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5685         || type == OP_RUNCV
5686         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5687
5688     NewOp(1101, pvop, 1, PVOP);
5689     CHANGE_TYPE(pvop, type);
5690     pvop->op_pv = pv;
5691     pvop->op_next = (OP*)pvop;
5692     pvop->op_flags = (U8)flags;
5693     pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
5694     if (PL_opargs[type] & OA_RETSCALAR)
5695         scalar((OP*)pvop);
5696     if (PL_opargs[type] & OA_TARGET)
5697         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
5698     return CHECKOP(type, pvop);
5699 }
5700
5701 void
5702 Perl_package(pTHX_ OP *o)
5703 {
5704     SV *const sv = cSVOPo->op_sv;
5705
5706     PERL_ARGS_ASSERT_PACKAGE;
5707
5708     SAVEGENERICSV(PL_curstash);
5709     save_item(PL_curstname);
5710
5711     PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
5712
5713     sv_setsv(PL_curstname, sv);
5714
5715     PL_hints |= HINT_BLOCK_SCOPE;
5716     PL_parser->copline = NOLINE;
5717
5718     op_free(o);
5719 }
5720
5721 void
5722 Perl_package_version( pTHX_ OP *v )
5723 {
5724     U32 savehints = PL_hints;
5725     PERL_ARGS_ASSERT_PACKAGE_VERSION;
5726     PL_hints &= ~HINT_STRICT_VARS;
5727     sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
5728     PL_hints = savehints;
5729     op_free(v);
5730 }
5731
5732 void
5733 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
5734 {
5735     OP *pack;
5736     OP *imop;
5737     OP *veop;
5738     SV *use_version = NULL;
5739
5740     PERL_ARGS_ASSERT_UTILIZE;
5741
5742     if (idop->op_type != OP_CONST)
5743         Perl_croak(aTHX_ "Module name must be constant");
5744
5745     veop = NULL;
5746
5747     if (version) {
5748         SV * const vesv = ((SVOP*)version)->op_sv;
5749
5750         if (!arg && !SvNIOKp(vesv)) {
5751             arg = version;
5752         }
5753         else {
5754             OP *pack;
5755             SV *meth;
5756
5757             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
5758                 Perl_croak(aTHX_ "Version number must be a constant number");
5759
5760             /* Make copy of idop so we don't free it twice */
5761             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
5762
5763             /* Fake up a method call to VERSION */
5764             meth = newSVpvs_share("VERSION");
5765             veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
5766                             op_append_elem(OP_LIST,
5767                                         op_prepend_elem(OP_LIST, pack, version),
5768                                         newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
5769         }
5770     }
5771
5772     /* Fake up an import/unimport */
5773     if (arg && arg->op_type == OP_STUB) {
5774         imop = arg;             /* no import on explicit () */
5775     }
5776     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
5777         imop = NULL;            /* use 5.0; */
5778         if (aver)
5779             use_version = ((SVOP*)idop)->op_sv;
5780         else
5781             idop->op_private |= OPpCONST_NOVER;
5782     }
5783     else {
5784         SV *meth;
5785
5786         /* Make copy of idop so we don't free it twice */
5787         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
5788
5789         /* Fake up a method call to import/unimport */
5790         meth = aver
5791             ? newSVpvs_share("import") : newSVpvs_share("unimport");
5792         imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
5793                        op_append_elem(OP_LIST,
5794                                    op_prepend_elem(OP_LIST, pack, arg),
5795                                    newMETHOP_named(OP_METHOD_NAMED, 0, meth)
5796                        ));
5797     }
5798
5799     /* Fake up the BEGIN {}, which does its thing immediately. */
5800     newATTRSUB(floor,
5801         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
5802         NULL,
5803         NULL,
5804         op_append_elem(OP_LINESEQ,
5805             op_append_elem(OP_LINESEQ,
5806                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
5807                 newSTATEOP(0, NULL, veop)),
5808             newSTATEOP(0, NULL, imop) ));
5809
5810     if (use_version) {
5811         /* Enable the
5812          * feature bundle that corresponds to the required version. */
5813         use_version = sv_2mortal(new_version(use_version));
5814         S_enable_feature_bundle(aTHX_ use_version);
5815
5816         /* If a version >= 5.11.0 is requested, strictures are on by default! */
5817         if (vcmp(use_version,
5818                  sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
5819             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
5820                 PL_hints |= HINT_STRICT_REFS;
5821             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
5822                 PL_hints |= HINT_STRICT_SUBS;
5823             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
5824                 PL_hints |= HINT_STRICT_VARS;
5825         }
5826         /* otherwise they are off */
5827         else {
5828             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
5829                 PL_hints &= ~HINT_STRICT_REFS;
5830             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
5831                 PL_hints &= ~HINT_STRICT_SUBS;
5832             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
5833                 PL_hints &= ~HINT_STRICT_VARS;
5834         }
5835     }
5836
5837     /* The "did you use incorrect case?" warning used to be here.
5838      * The problem is that on case-insensitive filesystems one
5839      * might get false positives for "use" (and "require"):
5840      * "use Strict" or "require CARP" will work.  This causes
5841      * portability problems for the script: in case-strict
5842      * filesystems the script will stop working.
5843      *
5844      * The "incorrect case" warning checked whether "use Foo"
5845      * imported "Foo" to your namespace, but that is wrong, too:
5846      * there is no requirement nor promise in the language that
5847      * a Foo.pm should or would contain anything in package "Foo".
5848      *
5849      * There is very little Configure-wise that can be done, either:
5850      * the case-sensitivity of the build filesystem of Perl does not
5851      * help in guessing the case-sensitivity of the runtime environment.
5852      */
5853
5854     PL_hints |= HINT_BLOCK_SCOPE;
5855     PL_parser->copline = NOLINE;
5856     PL_cop_seqmax++; /* Purely for B::*'s benefit */
5857     if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
5858         PL_cop_seqmax++;
5859
5860 }
5861
5862 /*
5863 =head1 Embedding Functions
5864
5865 =for apidoc load_module
5866
5867 Loads the module whose name is pointed to by the string part of name.
5868 Note that the actual module name, not its filename, should be given.
5869 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
5870 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
5871 (or 0 for no flags).  ver, if specified
5872 and not NULL, provides version semantics
5873 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
5874 arguments can be used to specify arguments to the module's import()
5875 method, similar to C<use Foo::Bar VERSION LIST>.  They must be
5876 terminated with a final NULL pointer.  Note that this list can only
5877 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
5878 Otherwise at least a single NULL pointer to designate the default
5879 import list is required.
5880
5881 The reference count for each specified C<SV*> parameter is decremented.
5882
5883 =cut */
5884
5885 void
5886 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
5887 {
5888     va_list args;
5889
5890     PERL_ARGS_ASSERT_LOAD_MODULE;
5891
5892     va_start(args, ver);
5893     vload_module(flags, name, ver, &args);
5894     va_end(args);
5895 }
5896
5897 #ifdef PERL_IMPLICIT_CONTEXT
5898 void
5899 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
5900 {
5901     dTHX;
5902     va_list args;
5903     PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
5904     va_start(args, ver);
5905     vload_module(flags, name, ver, &args);
5906     va_end(args);
5907 }
5908 #endif
5909
5910 void
5911 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
5912 {
5913     OP *veop, *imop;
5914     OP * const modname = newSVOP(OP_CONST, 0, name);
5915
5916     PERL_ARGS_ASSERT_VLOAD_MODULE;
5917
5918     modname->op_private |= OPpCONST_BARE;
5919     if (ver) {
5920         veop = newSVOP(OP_CONST, 0, ver);
5921     }
5922     else
5923         veop = NULL;
5924     if (flags & PERL_LOADMOD_NOIMPORT) {
5925         imop = sawparens(newNULLLIST());
5926     }
5927     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
5928         imop = va_arg(*args, OP*);
5929     }
5930     else {
5931         SV *sv;
5932         imop = NULL;
5933         sv = va_arg(*args, SV*);
5934         while (sv) {
5935             imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
5936             sv = va_arg(*args, SV*);
5937         }
5938     }
5939
5940     /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
5941      * that it has a PL_parser to play with while doing that, and also
5942      * that it doesn't mess with any existing parser, by creating a tmp
5943      * new parser with lex_start(). This won't actually be used for much,
5944      * since pp_require() will create another parser for the real work.
5945      * The ENTER/LEAVE pair protect callers from any side effects of use.  */
5946
5947     ENTER;
5948     SAVEVPTR(PL_curcop);
5949     lex_start(NULL, NULL, LEX_START_SAME_FILTER);
5950     utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
5951             veop, modname, imop);
5952     LEAVE;
5953 }
5954
5955 PERL_STATIC_INLINE OP *
5956 S_new_entersubop(pTHX_ GV *gv, OP *arg)
5957 {
5958     return newUNOP(OP_ENTERSUB, OPf_STACKED,
5959                    newLISTOP(OP_LIST, 0, arg,
5960                              newUNOP(OP_RV2CV, 0,
5961                                      newGVOP(OP_GV, 0, gv))));
5962 }
5963
5964 OP *
5965 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
5966 {
5967     OP *doop;
5968     GV *gv;
5969
5970     PERL_ARGS_ASSERT_DOFILE;
5971
5972     if (!force_builtin && (gv = gv_override("do", 2))) {
5973         doop = S_new_entersubop(aTHX_ gv, term);
5974     }
5975     else {
5976         doop = newUNOP(OP_DOFILE, 0, scalar(term));
5977     }
5978     return doop;
5979 }
5980
5981 /*
5982 =head1 Optree construction
5983
5984 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
5985
5986 Constructs, checks, and returns an C<lslice> (list slice) op.  I<flags>
5987 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
5988 be set automatically, and, shifted up eight bits, the eight bits of
5989 C<op_private>, except that the bit with value 1 or 2 is automatically
5990 set as required.  I<listval> and I<subscript> supply the parameters of
5991 the slice; they are consumed by this function and become part of the
5992 constructed op tree.
5993
5994 =cut
5995 */
5996
5997 OP *
5998 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
5999 {
6000     return newBINOP(OP_LSLICE, flags,
6001             list(force_list(subscript, 1)),
6002             list(force_list(listval,   1)) );
6003 }
6004
6005 #define ASSIGN_LIST   1
6006 #define ASSIGN_REF    2
6007
6008 STATIC I32
6009 S_assignment_type(pTHX_ const OP *o)
6010 {
6011     unsigned type;
6012     U8 flags;
6013     U8 ret;
6014
6015     if (!o)
6016         return TRUE;
6017
6018     if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
6019         o = cUNOPo->op_first;
6020
6021     flags = o->op_flags;
6022     type = o->op_type;
6023     if (type == OP_COND_EXPR) {
6024         OP * const sib = OP_SIBLING(cLOGOPo->op_first);
6025         const I32 t = assignment_type(sib);
6026         const I32 f = assignment_type(OP_SIBLING(sib));
6027
6028         if (t == ASSIGN_LIST && f == ASSIGN_LIST)
6029             return ASSIGN_LIST;
6030         if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
6031             yyerror("Assignment to both a list and a scalar");
6032         return FALSE;
6033     }
6034
6035     if (type == OP_SREFGEN)
6036     {
6037         OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
6038         type = kid->op_type;
6039         flags |= kid->op_flags;
6040         if (!(flags & OPf_PARENS)
6041           && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
6042               kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
6043             return ASSIGN_REF;
6044         ret = ASSIGN_REF;
6045     }
6046     else ret = 0;
6047
6048     if (type == OP_LIST &&
6049         (flags & OPf_WANT) == OPf_WANT_SCALAR &&
6050         o->op_private & OPpLVAL_INTRO)
6051         return ret;
6052
6053     if (type == OP_LIST || flags & OPf_PARENS ||
6054         type == OP_RV2AV || type == OP_RV2HV ||
6055         type == OP_ASLICE || type == OP_HSLICE ||
6056         type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
6057         return TRUE;
6058
6059     if (type == OP_PADAV || type == OP_PADHV)
6060         return TRUE;
6061
6062     if (type == OP_RV2SV)
6063         return ret;
6064
6065     return ret;
6066 }
6067
6068 /*
6069   Helper function for newASSIGNOP to detection commonality between the
6070   lhs and the rhs.  (It is actually called very indirectly.  newASSIGNOP
6071   flags the op and the peephole optimizer calls this helper function
6072   if the flag is set.)  Marks all variables with PL_generation.  If it
6073   returns TRUE the assignment must be able to handle common variables.
6074
6075   PL_generation sorcery:
6076   An assignment like ($a,$b) = ($c,$d) is easier than
6077   ($a,$b) = ($c,$a), since there is no need for temporary vars.
6078   To detect whether there are common vars, the global var
6079   PL_generation is incremented for each assign op we compile.
6080   Then, while compiling the assign op, we run through all the
6081   variables on both sides of the assignment, setting a spare slot
6082   in each of them to PL_generation.  If any of them already have
6083   that value, we know we've got commonality.  Also, if the
6084   generation number is already set to PERL_INT_MAX, then
6085   the variable is involved in aliasing, so we also have
6086   potential commonality in that case.  We could use a
6087   single bit marker, but then we'd have to make 2 passes, first
6088   to clear the flag, then to test and set it.  And that
6089   wouldn't help with aliasing, either.  To find somewhere
6090   to store these values, evil chicanery is done with SvUVX().
6091 */
6092 PERL_STATIC_INLINE bool
6093 S_aassign_common_vars(pTHX_ OP* o)
6094 {
6095     OP *curop;
6096     for (curop = cUNOPo->op_first; curop; curop = OP_SIBLING(curop)) {
6097         if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
6098             if (curop->op_type == OP_GV || curop->op_type == OP_GVSV
6099              || curop->op_type == OP_AELEMFAST) {
6100                 GV *gv = cGVOPx_gv(curop);
6101                 if (gv == PL_defgv
6102                     || (int)GvASSIGN_GENERATION(gv) == PL_generation)
6103                     return TRUE;
6104                 GvASSIGN_GENERATION_set(gv, PL_generation);
6105             }
6106             else if (curop->op_type == OP_PADSV ||
6107                 curop->op_type == OP_PADAV ||
6108                 curop->op_type == OP_PADHV ||
6109                 curop->op_type == OP_AELEMFAST_LEX ||
6110                 curop->op_type == OP_PADANY)
6111                 {
6112                   padcheck:
6113                     if (PAD_COMPNAME_GEN(curop->op_targ)
6114                         == (STRLEN)PL_generation
6115                      || PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX)
6116                         return TRUE;
6117                     PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
6118
6119                 }
6120             else if (curop->op_type == OP_RV2CV)
6121                 return TRUE;
6122             else if (curop->op_type == OP_RV2SV ||
6123                 curop->op_type == OP_RV2AV ||
6124                 curop->op_type == OP_RV2HV ||
6125                 curop->op_type == OP_RV2GV) {
6126                 if (cUNOPx(curop)->op_first->op_type != OP_GV)  /* funny deref? */
6127                     return TRUE;
6128             }
6129             else if (curop->op_type == OP_PUSHRE) {
6130                 GV *const gv =
6131 #ifdef USE_ITHREADS
6132                     ((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff
6133                         ? MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff))
6134                         : NULL;
6135 #else
6136                     ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
6137 #endif
6138                 if (gv) {
6139                     if (gv == PL_defgv
6140                         || (int)GvASSIGN_GENERATION(gv) == PL_generation)
6141                         return TRUE;
6142                     GvASSIGN_GENERATION_set(gv, PL_generation);
6143                 }
6144                 else if (curop->op_targ)
6145                     goto padcheck;
6146             }
6147             else if (curop->op_type == OP_PADRANGE)
6148                 /* Ignore padrange; checking its siblings is sufficient. */
6149                 continue;
6150             else
6151                 return TRUE;
6152         }
6153         else if (PL_opargs[curop->op_type] & OA_TARGLEX
6154               && curop->op_private & OPpTARGET_MY)
6155             goto padcheck;
6156
6157         if (curop->op_flags & OPf_KIDS) {
6158             if (aassign_common_vars(curop))
6159                 return TRUE;
6160         }
6161     }
6162     return FALSE;
6163 }
6164
6165 /* This variant only handles lexical aliases.  It is called when
6166    newASSIGNOP decides that we don’t have any common vars, as lexical ali-
6167    ases trump that decision.  */
6168 PERL_STATIC_INLINE bool
6169 S_aassign_common_vars_aliases_only(pTHX_ OP *o)
6170 {
6171     OP *curop;
6172     for (curop = cUNOPo->op_first; curop; curop = OP_SIBLING(curop)) {
6173         if ((curop->op_type == OP_PADSV ||
6174              curop->op_type == OP_PADAV ||
6175              curop->op_type == OP_PADHV ||
6176              curop->op_type == OP_AELEMFAST_LEX ||
6177              curop->op_type == OP_PADANY ||
6178              (  PL_opargs[curop->op_type] & OA_TARGLEX
6179              && curop->op_private & OPpTARGET_MY  ))
6180            && PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX)
6181             return TRUE;
6182
6183         if (curop->op_type == OP_PUSHRE && curop->op_targ
6184          && PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX)
6185             return TRUE;
6186
6187         if (curop->op_flags & OPf_KIDS) {
6188             if (S_aassign_common_vars_aliases_only(aTHX_ curop))
6189                 return TRUE;
6190         }
6191     }
6192     return FALSE;
6193 }
6194
6195 /*
6196 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
6197
6198 Constructs, checks, and returns an assignment op.  I<left> and I<right>
6199 supply the parameters of the assignment; they are consumed by this
6200 function and become part of the constructed op tree.
6201
6202 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
6203 a suitable conditional optree is constructed.  If I<optype> is the opcode
6204 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
6205 performs the binary operation and assigns the result to the left argument.
6206 Either way, if I<optype> is non-zero then I<flags> has no effect.
6207
6208 If I<optype> is zero, then a plain scalar or list assignment is
6209 constructed.  Which type of assignment it is is automatically determined.
6210 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6211 will be set automatically, and, shifted up eight bits, the eight bits
6212 of C<op_private>, except that the bit with value 1 or 2 is automatically
6213 set as required.
6214
6215 =cut
6216 */
6217
6218 OP *
6219 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
6220 {
6221     OP *o;
6222     I32 assign_type;
6223
6224     if (optype) {
6225         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
6226             return newLOGOP(optype, 0,
6227                 op_lvalue(scalar(left), optype),
6228                 newUNOP(OP_SASSIGN, 0, scalar(right)));
6229         }
6230         else {
6231             return newBINOP(optype, OPf_STACKED,
6232                 op_lvalue(scalar(left), optype), scalar(right));
6233         }
6234     }
6235
6236     if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
6237         static const char no_list_state[] = "Initialization of state variables"
6238             " in list context currently forbidden";
6239         OP *curop;
6240         bool maybe_common_vars = TRUE;
6241
6242         if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
6243             left->op_private &= ~ OPpSLICEWARNING;
6244
6245         PL_modcount = 0;
6246         left = op_lvalue(left, OP_AASSIGN);
6247         curop = list(force_list(left, 1));
6248         o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
6249         o->op_private = (U8)(0 | (flags >> 8));
6250
6251         if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
6252         {
6253             OP* lop = ((LISTOP*)left)->op_first;
6254             maybe_common_vars = FALSE;
6255             while (lop) {
6256                 if (lop->op_type == OP_PADSV ||
6257                     lop->op_type == OP_PADAV ||
6258                     lop->op_type == OP_PADHV ||
6259                     lop->op_type == OP_PADANY) {
6260                     if (!(lop->op_private & OPpLVAL_INTRO))
6261                         maybe_common_vars = TRUE;
6262
6263                     if (lop->op_private & OPpPAD_STATE) {
6264                         if (left->op_private & OPpLVAL_INTRO) {
6265                             /* Each variable in state($a, $b, $c) = ... */
6266                         }
6267                         else {
6268                             /* Each state variable in
6269                                (state $a, my $b, our $c, $d, undef) = ... */
6270                         }
6271                         yyerror(no_list_state);
6272                     } else {
6273                         /* Each my variable in
6274                            (state $a, my $b, our $c, $d, undef) = ... */
6275                     }
6276                 } else if (lop->op_type == OP_UNDEF ||
6277                            OP_TYPE_IS_OR_WAS(lop, OP_PUSHMARK)) {
6278                     /* undef may be interesting in
6279                        (state $a, undef, state $c) */
6280                 } else {
6281                     /* Other ops in the list. */
6282                     maybe_common_vars = TRUE;
6283                 }
6284                 lop = OP_SIBLING(lop);
6285             }
6286         }
6287         else if ((left->op_private & OPpLVAL_INTRO)
6288                 && (   left->op_type == OP_PADSV
6289                     || left->op_type == OP_PADAV
6290                     || left->op_type == OP_PADHV
6291                     || left->op_type == OP_PADANY))
6292         {
6293             if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
6294             if (left->op_private & OPpPAD_STATE) {
6295                 /* All single variable list context state assignments, hence
6296                    state ($a) = ...
6297                    (state $a) = ...
6298                    state @a = ...
6299                    state (@a) = ...
6300                    (state @a) = ...
6301                    state %a = ...
6302                    state (%a) = ...
6303                    (state %a) = ...
6304                 */
6305                 yyerror(no_list_state);
6306             }
6307         }
6308
6309         if (maybe_common_vars) {
6310                 /* The peephole optimizer will do the full check and pos-
6311                    sibly turn this off.  */
6312                 o->op_private |= OPpASSIGN_COMMON;
6313         }
6314
6315         if (right && right->op_type == OP_SPLIT
6316          && !(right->op_flags & OPf_STACKED)) {
6317             OP* tmpop = ((LISTOP*)right)->op_first;
6318             PMOP * const pm = (PMOP*)tmpop;
6319             assert (tmpop && (tmpop->op_type == OP_PUSHRE));
6320             if (
6321 #ifdef USE_ITHREADS
6322                     !pm->op_pmreplrootu.op_pmtargetoff
6323 #else
6324                     !pm->op_pmreplrootu.op_pmtargetgv
6325 #endif
6326                  && !pm->op_targ
6327                 ) {
6328                     if (!(left->op_private & OPpLVAL_INTRO) &&
6329                         ( (left->op_type == OP_RV2AV &&
6330                           (tmpop=((UNOP*)left)->op_first)->op_type==OP_GV)
6331                         || left->op_type == OP_PADAV )
6332                         ) {
6333                         if (tmpop != (OP *)pm) {
6334 #ifdef USE_ITHREADS
6335                           pm->op_pmreplrootu.op_pmtargetoff
6336                             = cPADOPx(tmpop)->op_padix;
6337                           cPADOPx(tmpop)->op_padix = 0; /* steal it */
6338 #else
6339                           pm->op_pmreplrootu.op_pmtargetgv
6340                             = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
6341                           cSVOPx(tmpop)->op_sv = NULL;  /* steal it */
6342 #endif
6343                           right->op_private |=
6344                             left->op_private & OPpOUR_INTRO;
6345                         }
6346                         else {
6347                             pm->op_targ = left->op_targ;
6348                             left->op_targ = 0; /* filch it */
6349                         }
6350                       detach_split:
6351                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
6352                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
6353                         /* detach rest of siblings from o subtree,
6354                          * and free subtree */
6355                         op_sibling_splice(cUNOPo->op_first, tmpop, -1, NULL);
6356                         op_free(o);                     /* blow off assign */
6357                         right->op_flags &= ~OPf_WANT;
6358                                 /* "I don't know and I don't care." */
6359                         return right;
6360                     }
6361                     else if (left->op_type == OP_RV2AV
6362                           || left->op_type == OP_PADAV)
6363                     {
6364                         /* Detach the array.  */
6365 #ifdef DEBUGGING
6366                         OP * const ary =
6367 #endif
6368                         op_sibling_splice(cBINOPo->op_last,
6369                                           cUNOPx(cBINOPo->op_last)
6370                                                 ->op_first, 1, NULL);
6371                         assert(ary == left);
6372                         /* Attach it to the split.  */
6373                         op_sibling_splice(right, cLISTOPx(right)->op_last,
6374                                           0, left);
6375                         right->op_flags |= OPf_STACKED;
6376                         /* Detach split and expunge aassign as above.  */
6377                         goto detach_split;
6378                     }
6379                     else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
6380                             ((LISTOP*)right)->op_last->op_type == OP_CONST)
6381                     {
6382                         SV ** const svp =
6383                             &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
6384                         SV * const sv = *svp;
6385                         if (SvIOK(sv) && SvIVX(sv) == 0)
6386                         {
6387                           if (right->op_private & OPpSPLIT_IMPLIM) {
6388                             /* our own SV, created in ck_split */
6389                             SvREADONLY_off(sv);
6390                             sv_setiv(sv, PL_modcount+1);
6391                           }
6392                           else {
6393                             /* SV may belong to someone else */
6394                             SvREFCNT_dec(sv);
6395                             *svp = newSViv(PL_modcount+1);
6396                           }
6397                         }
6398                     }
6399             }
6400         }
6401         return o;
6402     }
6403     if (assign_type == ASSIGN_REF)
6404         return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
6405     if (!right)
6406         right = newOP(OP_UNDEF, 0);
6407     if (right->op_type == OP_READLINE) {
6408         right->op_flags |= OPf_STACKED;
6409         return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
6410                 scalar(right));
6411     }
6412     else {
6413         o = newBINOP(OP_SASSIGN, flags,
6414             scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
6415     }
6416     return o;
6417 }
6418
6419 /*
6420 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
6421
6422 Constructs a state op (COP).  The state op is normally a C<nextstate> op,
6423 but will be a C<dbstate> op if debugging is enabled for currently-compiled
6424 code.  The state op is populated from C<PL_curcop> (or C<PL_compiling>).
6425 If I<label> is non-null, it supplies the name of a label to attach to
6426 the state op; this function takes ownership of the memory pointed at by
6427 I<label>, and will free it.  I<flags> gives the eight bits of C<op_flags>
6428 for the state op.
6429
6430 If I<o> is null, the state op is returned.  Otherwise the state op is
6431 combined with I<o> into a C<lineseq> list op, which is returned.  I<o>
6432 is consumed by this function and becomes part of the returned op tree.
6433
6434 =cut
6435 */
6436
6437 OP *
6438 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
6439 {
6440     dVAR;
6441     const U32 seq = intro_my();
6442     const U32 utf8 = flags & SVf_UTF8;
6443     COP *cop;
6444
6445     flags &= ~SVf_UTF8;
6446
6447     NewOp(1101, cop, 1, COP);
6448     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
6449         CHANGE_TYPE(cop, OP_DBSTATE);
6450     }
6451     else {
6452         CHANGE_TYPE(cop, OP_NEXTSTATE);
6453     }
6454     cop->op_flags = (U8)flags;
6455     CopHINTS_set(cop, PL_hints);
6456 #ifdef VMS
6457     if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
6458 #endif
6459     cop->op_next = (OP*)cop;
6460
6461     cop->cop_seq = seq;
6462     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
6463     CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
6464     if (label) {
6465         Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
6466
6467         PL_hints |= HINT_BLOCK_SCOPE;
6468         /* It seems that we need to defer freeing this pointer, as other parts
6469            of the grammar end up wanting to copy it after this op has been
6470            created. */
6471         SAVEFREEPV(label);
6472     }
6473
6474     if (PL_parser->preambling != NOLINE) {
6475         CopLINE_set(cop, PL_parser->preambling);
6476         PL_parser->copline = NOLINE;
6477     }
6478     else if (PL_parser->copline == NOLINE)
6479         CopLINE_set(cop, CopLINE(PL_curcop));
6480     else {
6481         CopLINE_set(cop, PL_parser->copline);
6482         PL_parser->copline = NOLINE;
6483     }
6484 #ifdef USE_ITHREADS
6485     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
6486 #else
6487     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
6488 #endif
6489     CopSTASH_set(cop, PL_curstash);
6490
6491     if (cop->op_type == OP_DBSTATE) {
6492         /* this line can have a breakpoint - store the cop in IV */
6493         AV *av = CopFILEAVx(PL_curcop);
6494         if (av) {
6495             SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
6496             if (svp && *svp != &PL_sv_undef ) {
6497                 (void)SvIOK_on(*svp);
6498                 SvIV_set(*svp, PTR2IV(cop));
6499             }
6500         }
6501     }
6502
6503     if (flags & OPf_SPECIAL)
6504         op_null((OP*)cop);
6505     return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
6506 }
6507
6508 /*
6509 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
6510
6511 Constructs, checks, and returns a logical (flow control) op.  I<type>
6512 is the opcode.  I<flags> gives the eight bits of C<op_flags>, except
6513 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6514 the eight bits of C<op_private>, except that the bit with value 1 is
6515 automatically set.  I<first> supplies the expression controlling the
6516 flow, and I<other> supplies the side (alternate) chain of ops; they are
6517 consumed by this function and become part of the constructed op tree.
6518
6519 =cut
6520 */
6521
6522 OP *
6523 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
6524 {
6525     PERL_ARGS_ASSERT_NEWLOGOP;
6526
6527     return new_logop(type, flags, &first, &other);
6528 }
6529
6530 STATIC OP *
6531 S_search_const(pTHX_ OP *o)
6532 {
6533     PERL_ARGS_ASSERT_SEARCH_CONST;
6534
6535     switch (o->op_type) {
6536         case OP_CONST:
6537             return o;
6538         case OP_NULL:
6539             if (o->op_flags & OPf_KIDS)
6540                 return search_const(cUNOPo->op_first);
6541             break;
6542         case OP_LEAVE:
6543         case OP_SCOPE:
6544         case OP_LINESEQ:
6545         {
6546             OP *kid;
6547             if (!(o->op_flags & OPf_KIDS))
6548                 return NULL;
6549             kid = cLISTOPo->op_first;
6550             do {
6551                 switch (kid->op_type) {
6552                     case OP_ENTER:
6553                     case OP_NULL:
6554                     case OP_NEXTSTATE:
6555                         kid = OP_SIBLING(kid);
6556                         break;
6557                     default:
6558                         if (kid != cLISTOPo->op_last)
6559                             return NULL;
6560                         goto last;
6561                 }
6562             } while (kid);
6563             if (!kid)
6564                 kid = cLISTOPo->op_last;
6565 last:
6566             return search_const(kid);
6567         }
6568     }
6569
6570     return NULL;
6571 }
6572
6573 STATIC OP *
6574 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
6575 {
6576     dVAR;
6577     LOGOP *logop;
6578     OP *o;
6579     OP *first;
6580     OP *other;
6581     OP *cstop = NULL;
6582     int prepend_not = 0;
6583
6584     PERL_ARGS_ASSERT_NEW_LOGOP;
6585
6586     first = *firstp;
6587     other = *otherp;
6588
6589     /* [perl #59802]: Warn about things like "return $a or $b", which
6590        is parsed as "(return $a) or $b" rather than "return ($a or
6591        $b)".  NB: This also applies to xor, which is why we do it
6592        here.
6593      */
6594     switch (first->op_type) {
6595     case OP_NEXT:
6596     case OP_LAST:
6597     case OP_REDO:
6598         /* XXX: Perhaps we should emit a stronger warning for these.
6599            Even with the high-precedence operator they don't seem to do
6600            anything sensible.
6601
6602            But until we do, fall through here.
6603          */
6604     case OP_RETURN:
6605     case OP_EXIT:
6606     case OP_DIE:
6607     case OP_GOTO:
6608         /* XXX: Currently we allow people to "shoot themselves in the
6609            foot" by explicitly writing "(return $a) or $b".
6610
6611            Warn unless we are looking at the result from folding or if
6612            the programmer explicitly grouped the operators like this.
6613            The former can occur with e.g.
6614
6615                 use constant FEATURE => ( $] >= ... );
6616                 sub { not FEATURE and return or do_stuff(); }
6617          */
6618         if (!first->op_folded && !(first->op_flags & OPf_PARENS))
6619             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6620                            "Possible precedence issue with control flow operator");
6621         /* XXX: Should we optimze this to "return $a;" (i.e. remove
6622            the "or $b" part)?
6623         */
6624         break;
6625     }
6626
6627     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
6628         return newBINOP(type, flags, scalar(first), scalar(other));
6629
6630     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
6631
6632     scalarboolean(first);
6633     /* optimize AND and OR ops that have NOTs as children */
6634     if (first->op_type == OP_NOT
6635         && (first->op_flags & OPf_KIDS)
6636         && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
6637             || (other->op_type == OP_NOT))  /* if (!$x && !$y) { } */
6638         ) {
6639         if (type == OP_AND || type == OP_OR) {
6640             if (type == OP_AND)
6641                 type = OP_OR;
6642             else
6643                 type = OP_AND;
6644             op_null(first);
6645             if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
6646                 op_null(other);
6647                 prepend_not = 1; /* prepend a NOT op later */
6648             }
6649         }
6650     }
6651     /* search for a constant op that could let us fold the test */
6652     if ((cstop = search_const(first))) {
6653         if (cstop->op_private & OPpCONST_STRICT)
6654             no_bareword_allowed(cstop);
6655         else if ((cstop->op_private & OPpCONST_BARE))
6656                 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
6657         if ((type == OP_AND &&  SvTRUE(((SVOP*)cstop)->op_sv)) ||
6658             (type == OP_OR  && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
6659             (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
6660             *firstp = NULL;
6661             if (other->op_type == OP_CONST)
6662                 other->op_private |= OPpCONST_SHORTCIRCUIT;
6663             op_free(first);
6664             if (other->op_type == OP_LEAVE)
6665                 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
6666             else if (other->op_type == OP_MATCH
6667                   || other->op_type == OP_SUBST
6668                   || other->op_type == OP_TRANSR
6669                   || other->op_type == OP_TRANS)
6670                 /* Mark the op as being unbindable with =~ */
6671                 other->op_flags |= OPf_SPECIAL;
6672
6673             other->op_folded = 1;
6674             return other;
6675         }
6676         else {
6677             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
6678             const OP *o2 = other;
6679             if ( ! (o2->op_type == OP_LIST
6680                     && (( o2 = cUNOPx(o2)->op_first))
6681                     && o2->op_type == OP_PUSHMARK
6682                     && (( o2 = OP_SIBLING(o2))) )
6683             )
6684                 o2 = other;
6685             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
6686                         || o2->op_type == OP_PADHV)
6687                 && o2->op_private & OPpLVAL_INTRO
6688                 && !(o2->op_private & OPpPAD_STATE))
6689             {
6690                 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6691                                  "Deprecated use of my() in false conditional");
6692             }
6693
6694             *otherp = NULL;
6695             if (cstop->op_type == OP_CONST)
6696                 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
6697                 op_free(other);
6698             return first;
6699         }
6700     }
6701     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
6702         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
6703     {
6704         const OP * const k1 = ((UNOP*)first)->op_first;
6705         const OP * const k2 = OP_SIBLING(k1);
6706         OPCODE warnop = 0;
6707         switch (first->op_type)
6708         {
6709         case OP_NULL:
6710             if (k2 && k2->op_type == OP_READLINE
6711                   && (k2->op_flags & OPf_STACKED)
6712                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6713             {
6714                 warnop = k2->op_type;
6715             }
6716             break;
6717
6718         case OP_SASSIGN:
6719             if (k1->op_type == OP_READDIR
6720                   || k1->op_type == OP_GLOB
6721                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6722                  || k1->op_type == OP_EACH
6723                  || k1->op_type == OP_AEACH)
6724             {
6725                 warnop = ((k1->op_type == OP_NULL)
6726                           ? (OPCODE)k1->op_targ : k1->op_type);
6727             }
6728             break;
6729         }
6730         if (warnop) {
6731             const line_t oldline = CopLINE(PL_curcop);
6732             /* This ensures that warnings are reported at the first line
6733                of the construction, not the last.  */
6734             CopLINE_set(PL_curcop, PL_parser->copline);
6735             Perl_warner(aTHX_ packWARN(WARN_MISC),
6736                  "Value of %s%s can be \"0\"; test with defined()",
6737                  PL_op_desc[warnop],
6738                  ((warnop == OP_READLINE || warnop == OP_GLOB)
6739                   ? " construct" : "() operator"));
6740             CopLINE_set(PL_curcop, oldline);
6741         }
6742     }
6743
6744     if (!other)
6745         return first;
6746
6747     if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
6748         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
6749
6750     logop = S_alloc_LOGOP(aTHX_ type, first, LINKLIST(other));
6751     logop->op_flags |= (U8)flags;
6752     logop->op_private = (U8)(1 | (flags >> 8));
6753
6754     /* establish postfix order */
6755     logop->op_next = LINKLIST(first);
6756     first->op_next = (OP*)logop;
6757     assert(!OP_HAS_SIBLING(first));
6758     op_sibling_splice((OP*)logop, first, 0, other);
6759
6760     CHECKOP(type,logop);
6761
6762     o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
6763     other->op_next = o;
6764
6765     return o;
6766 }
6767
6768 /*
6769 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
6770
6771 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
6772 op.  I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6773 will be set automatically, and, shifted up eight bits, the eight bits of
6774 C<op_private>, except that the bit with value 1 is automatically set.
6775 I<first> supplies the expression selecting between the two branches,
6776 and I<trueop> and I<falseop> supply the branches; they are consumed by
6777 this function and become part of the constructed op tree.
6778
6779 =cut
6780 */
6781
6782 OP *
6783 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
6784 {
6785     dVAR;
6786     LOGOP *logop;
6787     OP *start;
6788     OP *o;
6789     OP *cstop;
6790
6791     PERL_ARGS_ASSERT_NEWCONDOP;
6792
6793     if (!falseop)
6794         return newLOGOP(OP_AND, 0, first, trueop);
6795     if (!trueop)
6796         return newLOGOP(OP_OR, 0, first, falseop);
6797
6798     scalarboolean(first);
6799     if ((cstop = search_const(first))) {
6800         /* Left or right arm of the conditional?  */
6801         const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
6802         OP *live = left ? trueop : falseop;
6803         OP *const dead = left ? falseop : trueop;
6804         if (cstop->op_private & OPpCONST_BARE &&
6805             cstop->op_private & OPpCONST_STRICT) {
6806             no_bareword_allowed(cstop);
6807         }
6808         op_free(first);
6809         op_free(dead);
6810         if (live->op_type == OP_LEAVE)
6811             live = newUNOP(OP_NULL, OPf_SPECIAL, live);
6812         else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
6813               || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
6814             /* Mark the op as being unbindable with =~ */
6815             live->op_flags |= OPf_SPECIAL;
6816         live->op_folded = 1;
6817         return live;
6818     }
6819     logop = S_alloc_LOGOP(aTHX_ OP_COND_EXPR, first, LINKLIST(trueop));
6820     logop->op_flags |= (U8)flags;
6821     logop->op_private = (U8)(1 | (flags >> 8));
6822     logop->op_next = LINKLIST(falseop);
6823
6824     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
6825             logop);
6826
6827     /* establish postfix order */
6828     start = LINKLIST(first);
6829     first->op_next = (OP*)logop;
6830
6831     /* make first, trueop, falseop siblings */
6832     op_sibling_splice((OP*)logop, first,  0, trueop);
6833     op_sibling_splice((OP*)logop, trueop, 0, falseop);
6834
6835     o = newUNOP(OP_NULL, 0, (OP*)logop);
6836
6837     trueop->op_next = falseop->op_next = o;
6838
6839     o->op_next = start;
6840     return o;
6841 }
6842
6843 /*
6844 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
6845
6846 Constructs and returns a C<range> op, with subordinate C<flip> and
6847 C<flop> ops.  I<flags> gives the eight bits of C<op_flags> for the
6848 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
6849 for both the C<flip> and C<range> ops, except that the bit with value
6850 1 is automatically set.  I<left> and I<right> supply the expressions
6851 controlling the endpoints of the range; they are consumed by this function
6852 and become part of the constructed op tree.
6853
6854 =cut
6855 */
6856
6857 OP *
6858 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
6859 {
6860     dVAR;
6861     LOGOP *range;
6862     OP *flip;
6863     OP *flop;
6864     OP *leftstart;
6865     OP *o;
6866
6867     PERL_ARGS_ASSERT_NEWRANGE;
6868
6869     range = S_alloc_LOGOP(aTHX_ OP_RANGE, left, LINKLIST(right));
6870     range->op_flags = OPf_KIDS;
6871     leftstart = LINKLIST(left);
6872     range->op_private = (U8)(1 | (flags >> 8));
6873
6874     /* make left and right siblings */
6875     op_sibling_splice((OP*)range, left, 0, right);
6876
6877     range->op_next = (OP*)range;
6878     flip = newUNOP(OP_FLIP, flags, (OP*)range);
6879     flop = newUNOP(OP_FLOP, 0, flip);
6880     o = newUNOP(OP_NULL, 0, flop);
6881     LINKLIST(flop);
6882     range->op_next = leftstart;
6883
6884     left->op_next = flip;
6885     right->op_next = flop;
6886
6887     range->op_targ =
6888         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
6889     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
6890     flip->op_targ =
6891         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
6892     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
6893     SvPADTMP_on(PAD_SV(flip->op_targ));
6894
6895     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6896     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6897
6898     /* check barewords before they might be optimized aways */
6899     if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
6900         no_bareword_allowed(left);
6901     if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
6902         no_bareword_allowed(right);
6903
6904     flip->op_next = o;
6905     if (!flip->op_private || !flop->op_private)
6906         LINKLIST(o);            /* blow off optimizer unless constant */
6907
6908     return o;
6909 }
6910
6911 /*
6912 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
6913
6914 Constructs, checks, and returns an op tree expressing a loop.  This is
6915 only a loop in the control flow through the op tree; it does not have
6916 the heavyweight loop structure that allows exiting the loop by C<last>
6917 and suchlike.  I<flags> gives the eight bits of C<op_flags> for the
6918 top-level op, except that some bits will be set automatically as required.
6919 I<expr> supplies the expression controlling loop iteration, and I<block>
6920 supplies the body of the loop; they are consumed by this function and
6921 become part of the constructed op tree.  I<debuggable> is currently
6922 unused and should always be 1.
6923
6924 =cut
6925 */
6926
6927 OP *
6928 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
6929 {
6930     OP* listop;
6931     OP* o;
6932     const bool once = block && block->op_flags & OPf_SPECIAL &&
6933                       block->op_type == OP_NULL;
6934
6935     PERL_UNUSED_ARG(debuggable);
6936
6937     if (expr) {
6938         if (once && (
6939               (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
6940            || (  expr->op_type == OP_NOT
6941               && cUNOPx(expr)->op_first->op_type == OP_CONST
6942               && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
6943               )
6944            ))
6945             /* Return the block now, so that S_new_logop does not try to
6946                fold it away. */
6947             return block;       /* do {} while 0 does once */
6948         if (expr->op_type == OP_READLINE
6949             || expr->op_type == OP_READDIR
6950             || expr->op_type == OP_GLOB
6951             || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
6952             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
6953             expr = newUNOP(OP_DEFINED, 0,
6954                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
6955         } else if (expr->op_flags & OPf_KIDS) {
6956             const OP * const k1 = ((UNOP*)expr)->op_first;
6957             const OP * const k2 = k1 ? OP_SIBLING(k1) : NULL;
6958             switch (expr->op_type) {
6959               case OP_NULL:
6960                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
6961                       && (k2->op_flags & OPf_STACKED)
6962                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6963                     expr = newUNOP(OP_DEFINED, 0, expr);
6964                 break;
6965
6966               case OP_SASSIGN:
6967                 if (k1 && (k1->op_type == OP_READDIR
6968                       || k1->op_type == OP_GLOB
6969                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6970                      || k1->op_type == OP_EACH
6971                      || k1->op_type == OP_AEACH))
6972                     expr = newUNOP(OP_DEFINED, 0, expr);
6973                 break;
6974             }
6975         }
6976     }
6977
6978     /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
6979      * op, in listop. This is wrong. [perl #27024] */
6980     if (!block)
6981         block = newOP(OP_NULL, 0);
6982     listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
6983     o = new_logop(OP_AND, 0, &expr, &listop);
6984
6985     if (once) {
6986         ASSUME(listop);
6987     }
6988
6989     if (listop)
6990         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
6991
6992     if (once && o != listop)
6993     {
6994         assert(cUNOPo->op_first->op_type == OP_AND
6995             || cUNOPo->op_first->op_type == OP_OR);
6996         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
6997     }
6998
6999     if (o == listop)
7000         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
7001
7002     o->op_flags |= flags;
7003     o = op_scope(o);
7004     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
7005     return o;
7006 }
7007
7008 /*
7009 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
7010
7011 Constructs, checks, and returns an op tree expressing a C<while> loop.
7012 This is a heavyweight loop, with structure that allows exiting the loop
7013 by C<last> and suchlike.
7014
7015 I<loop> is an optional preconstructed C<enterloop> op to use in the
7016 loop; if it is null then a suitable op will be constructed automatically.
7017 I<expr> supplies the loop's controlling expression.  I<block> supplies the
7018 main body of the loop, and I<cont> optionally supplies a C<continue> block
7019 that operates as a second half of the body.  All of these optree inputs
7020 are consumed by this function and become part of the constructed op tree.
7021
7022 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7023 op and, shifted up eight bits, the eight bits of C<op_private> for
7024 the C<leaveloop> op, except that (in both cases) some bits will be set
7025 automatically.  I<debuggable> is currently unused and should always be 1.
7026 I<has_my> can be supplied as true to force the
7027 loop body to be enclosed in its own scope.
7028
7029 =cut
7030 */
7031
7032 OP *
7033 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
7034         OP *expr, OP *block, OP *cont, I32 has_my)
7035 {
7036     dVAR;
7037     OP *redo;
7038     OP *next = NULL;
7039     OP *listop;
7040     OP *o;
7041     U8 loopflags = 0;
7042
7043     PERL_UNUSED_ARG(debuggable);
7044
7045     if (expr) {
7046         if (expr->op_type == OP_READLINE
7047          || expr->op_type == OP_READDIR
7048          || expr->op_type == OP_GLOB
7049          || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
7050                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
7051             expr = newUNOP(OP_DEFINED, 0,
7052                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
7053         } else if (expr->op_flags & OPf_KIDS) {
7054             const OP * const k1 = ((UNOP*)expr)->op_first;
7055             const OP * const k2 = (k1) ? OP_SIBLING(k1) : NULL;
7056             switch (expr->op_type) {
7057               case OP_NULL:
7058                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
7059                       && (k2->op_flags & OPf_STACKED)
7060                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7061                     expr = newUNOP(OP_DEFINED, 0, expr);
7062                 break;
7063
7064               case OP_SASSIGN:
7065                 if (k1 && (k1->op_type == OP_READDIR
7066                       || k1->op_type == OP_GLOB
7067                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7068                      || k1->op_type == OP_EACH
7069                      || k1->op_type == OP_AEACH))
7070                     expr = newUNOP(OP_DEFINED, 0, expr);
7071                 break;
7072             }
7073         }
7074     }
7075
7076     if (!block)
7077         block = newOP(OP_NULL, 0);
7078     else if (cont || has_my) {
7079         block = op_scope(block);
7080     }
7081
7082     if (cont) {
7083         next = LINKLIST(cont);
7084     }
7085     if (expr) {
7086         OP * const unstack = newOP(OP_UNSTACK, 0);
7087         if (!next)
7088             next = unstack;
7089         cont = op_append_elem(OP_LINESEQ, cont, unstack);
7090     }
7091
7092     assert(block);
7093     listop = op_append_list(OP_LINESEQ, block, cont);
7094     assert(listop);
7095     redo = LINKLIST(listop);
7096
7097     if (expr) {
7098         scalar(listop);
7099         o = new_logop(OP_AND, 0, &expr, &listop);
7100         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
7101             op_free((OP*)loop);
7102             return expr;                /* listop already freed by new_logop */
7103         }
7104         if (listop)
7105             ((LISTOP*)listop)->op_last->op_next =
7106                 (o == listop ? redo : LINKLIST(o));
7107     }
7108     else
7109         o = listop;
7110
7111     if (!loop) {
7112         NewOp(1101,loop,1,LOOP);
7113         CHANGE_TYPE(loop, OP_ENTERLOOP);
7114         loop->op_private = 0;
7115         loop->op_next = (OP*)loop;
7116     }
7117
7118     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
7119
7120     loop->op_redoop = redo;
7121     loop->op_lastop = o;
7122     o->op_private |= loopflags;
7123
7124     if (next)
7125         loop->op_nextop = next;
7126     else
7127         loop->op_nextop = o;
7128
7129     o->op_flags |= flags;
7130     o->op_private |= (flags >> 8);
7131     return o;
7132 }
7133
7134 /*
7135 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
7136
7137 Constructs, checks, and returns an op tree expressing a C<foreach>
7138 loop (iteration through a list of values).  This is a heavyweight loop,
7139 with structure that allows exiting the loop by C<last> and suchlike.
7140
7141 I<sv> optionally supplies the variable that will be aliased to each
7142 item in turn; if null, it defaults to C<$_> (either lexical or global).
7143 I<expr> supplies the list of values to iterate over.  I<block> supplies
7144 the main body of the loop, and I<cont> optionally supplies a C<continue>
7145 block that operates as a second half of the body.  All of these optree
7146 inputs are consumed by this function and become part of the constructed
7147 op tree.
7148
7149 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7150 op and, shifted up eight bits, the eight bits of C<op_private> for
7151 the C<leaveloop> op, except that (in both cases) some bits will be set
7152 automatically.
7153
7154 =cut
7155 */
7156
7157 OP *
7158 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
7159 {
7160     dVAR;
7161     LOOP *loop;
7162     OP *wop;
7163     PADOFFSET padoff = 0;
7164     I32 iterflags = 0;
7165     I32 iterpflags = 0;
7166
7167     PERL_ARGS_ASSERT_NEWFOROP;
7168
7169     if (sv) {
7170         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
7171             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
7172             CHANGE_TYPE(sv, OP_RV2GV);
7173
7174             /* The op_type check is needed to prevent a possible segfault
7175              * if the loop variable is undeclared and 'strict vars' is in
7176              * effect. This is illegal but is nonetheless parsed, so we
7177              * may reach this point with an OP_CONST where we're expecting
7178              * an OP_GV.
7179              */
7180             if (cUNOPx(sv)->op_first->op_type == OP_GV
7181              && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
7182                 iterpflags |= OPpITER_DEF;
7183         }
7184         else if (sv->op_type == OP_PADSV) { /* private variable */
7185             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
7186             padoff = sv->op_targ;
7187             sv->op_targ = 0;
7188             op_free(sv);
7189             sv = NULL;
7190             PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
7191         }
7192         else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
7193             NOOP;
7194         else
7195             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
7196         if (padoff) {
7197             SV *const namesv = PAD_COMPNAME_SV(padoff);
7198             STRLEN len;
7199             const char *const name = SvPV_const(namesv, len);
7200
7201             if (len == 2 && name[0] == '$' && name[1] == '_')
7202                 iterpflags |= OPpITER_DEF;
7203         }
7204     }
7205     else {
7206         const PADOFFSET offset = pad_findmy_pvs("$_", 0);
7207         if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7208             sv = newGVOP(OP_GV, 0, PL_defgv);
7209         }
7210         else {
7211             padoff = offset;
7212         }
7213         iterpflags |= OPpITER_DEF;
7214     }
7215
7216     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
7217         expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
7218         iterflags |= OPf_STACKED;
7219     }
7220     else if (expr->op_type == OP_NULL &&
7221              (expr->op_flags & OPf_KIDS) &&
7222              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
7223     {
7224         /* Basically turn for($x..$y) into the same as for($x,$y), but we
7225          * set the STACKED flag to indicate that these values are to be
7226          * treated as min/max values by 'pp_enteriter'.
7227          */
7228         const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
7229         LOGOP* const range = (LOGOP*) flip->op_first;
7230         OP* const left  = range->op_first;
7231         OP* const right = OP_SIBLING(left);
7232         LISTOP* listop;
7233
7234         range->op_flags &= ~OPf_KIDS;
7235         /* detach range's children */
7236         op_sibling_splice((OP*)range, NULL, -1, NULL);
7237
7238         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
7239         listop->op_first->op_next = range->op_next;
7240         left->op_next = range->op_other;
7241         right->op_next = (OP*)listop;
7242         listop->op_next = listop->op_first;
7243
7244         op_free(expr);
7245         expr = (OP*)(listop);
7246         op_null(expr);
7247         iterflags |= OPf_STACKED;
7248     }
7249     else {
7250         expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
7251     }
7252
7253     loop = (LOOP*)list(op_convert_list(OP_ENTERITER, iterflags,
7254                                op_append_elem(OP_LIST, expr, scalar(sv))));
7255     assert(!loop->op_next);
7256     /* for my  $x () sets OPpLVAL_INTRO;
7257      * for our $x () sets OPpOUR_INTRO */
7258     loop->op_private = (U8)iterpflags;
7259     if (loop->op_slabbed
7260      && DIFF(loop, OpSLOT(loop)->opslot_next)
7261          < SIZE_TO_PSIZE(sizeof(LOOP)))
7262     {
7263         LOOP *tmp;
7264         NewOp(1234,tmp,1,LOOP);
7265         Copy(loop,tmp,1,LISTOP);
7266 #ifdef PERL_OP_PARENT
7267         assert(loop->op_last->op_sibling == (OP*)loop);
7268         loop->op_last->op_sibling = (OP*)tmp; /*point back to new parent */
7269 #endif
7270         S_op_destroy(aTHX_ (OP*)loop);
7271         loop = tmp;
7272     }
7273     else if (!loop->op_slabbed)
7274         loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
7275     loop->op_targ = padoff;
7276     wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
7277     return wop;
7278 }
7279
7280 /*
7281 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
7282
7283 Constructs, checks, and returns a loop-exiting op (such as C<goto>
7284 or C<last>).  I<type> is the opcode.  I<label> supplies the parameter
7285 determining the target of the op; it is consumed by this function and
7286 becomes part of the constructed op tree.
7287
7288 =cut
7289 */
7290
7291 OP*
7292 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
7293 {
7294     OP *o = NULL;
7295
7296     PERL_ARGS_ASSERT_NEWLOOPEX;
7297
7298     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
7299
7300     if (type != OP_GOTO) {
7301         /* "last()" means "last" */
7302         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
7303             o = newOP(type, OPf_SPECIAL);
7304         }
7305     }
7306     else {
7307         /* Check whether it's going to be a goto &function */
7308         if (label->op_type == OP_ENTERSUB
7309                 && !(label->op_flags & OPf_STACKED))
7310             label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
7311     }
7312
7313     /* Check for a constant argument */
7314     if (label->op_type == OP_CONST) {
7315             SV * const sv = ((SVOP *)label)->op_sv;
7316             STRLEN l;
7317             const char *s = SvPV_const(sv,l);
7318             if (l == strlen(s)) {
7319                 o = newPVOP(type,
7320                             SvUTF8(((SVOP*)label)->op_sv),
7321                             savesharedpv(
7322                                 SvPV_nolen_const(((SVOP*)label)->op_sv)));
7323             }
7324     }
7325
7326     /* If we have already created an op, we do not need the label. */
7327     if (o)
7328                 op_free(label);
7329     else o = newUNOP(type, OPf_STACKED, label);
7330
7331     PL_hints |= HINT_BLOCK_SCOPE;
7332     return o;
7333 }
7334
7335 /* if the condition is a literal array or hash
7336    (or @{ ... } etc), make a reference to it.
7337  */
7338 STATIC OP *
7339 S_ref_array_or_hash(pTHX_ OP *cond)
7340 {
7341     if (cond
7342     && (cond->op_type == OP_RV2AV
7343     ||  cond->op_type == OP_PADAV
7344     ||  cond->op_type == OP_RV2HV
7345     ||  cond->op_type == OP_PADHV))
7346
7347         return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
7348
7349     else if(cond
7350     && (cond->op_type == OP_ASLICE
7351     ||  cond->op_type == OP_KVASLICE
7352     ||  cond->op_type == OP_HSLICE
7353     ||  cond->op_type == OP_KVHSLICE)) {
7354
7355         /* anonlist now needs a list from this op, was previously used in
7356          * scalar context */
7357         cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
7358         cond->op_flags |= OPf_WANT_LIST;
7359
7360         return newANONLIST(op_lvalue(cond, OP_ANONLIST));
7361     }
7362
7363     else
7364         return cond;
7365 }
7366
7367 /* These construct the optree fragments representing given()
7368    and when() blocks.
7369
7370    entergiven and enterwhen are LOGOPs; the op_other pointer
7371    points up to the associated leave op. We need this so we
7372    can put it in the context and make break/continue work.
7373    (Also, of course, pp_enterwhen will jump straight to
7374    op_other if the match fails.)
7375  */
7376
7377 STATIC OP *
7378 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
7379                    I32 enter_opcode, I32 leave_opcode,
7380                    PADOFFSET entertarg)
7381 {
7382     dVAR;
7383     LOGOP *enterop;
7384     OP *o;
7385
7386     PERL_ARGS_ASSERT_NEWGIVWHENOP;
7387
7388     enterop = S_alloc_LOGOP(aTHX_ enter_opcode, block, NULL);
7389     enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
7390     enterop->op_private = 0;
7391
7392     o = newUNOP(leave_opcode, 0, (OP *) enterop);
7393
7394     if (cond) {
7395         /* prepend cond if we have one */
7396         op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
7397
7398         o->op_next = LINKLIST(cond);
7399         cond->op_next = (OP *) enterop;
7400     }
7401     else {
7402         /* This is a default {} block */
7403         enterop->op_flags |= OPf_SPECIAL;
7404         o      ->op_flags |= OPf_SPECIAL;
7405
7406         o->op_next = (OP *) enterop;
7407     }
7408
7409     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
7410                                        entergiven and enterwhen both
7411                                        use ck_null() */
7412
7413     enterop->op_next = LINKLIST(block);
7414     block->op_next = enterop->op_other = o;
7415
7416     return o;
7417 }
7418
7419 /* Does this look like a boolean operation? For these purposes
7420    a boolean operation is:
7421      - a subroutine call [*]
7422      - a logical connective
7423      - a comparison operator
7424      - a filetest operator, with the exception of -s -M -A -C
7425      - defined(), exists() or eof()
7426      - /$re/ or $foo =~ /$re/
7427
7428    [*] possibly surprising
7429  */
7430 STATIC bool
7431 S_looks_like_bool(pTHX_ const OP *o)
7432 {
7433     PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
7434
7435     switch(o->op_type) {
7436         case OP_OR:
7437         case OP_DOR:
7438             return looks_like_bool(cLOGOPo->op_first);
7439
7440         case OP_AND:
7441         {
7442             OP* sibl = OP_SIBLING(cLOGOPo->op_first);
7443             ASSUME(sibl);
7444             return (
7445                 looks_like_bool(cLOGOPo->op_first)
7446              && looks_like_bool(sibl));
7447         }
7448
7449         case OP_NULL:
7450         case OP_SCALAR:
7451             return (
7452                 o->op_flags & OPf_KIDS
7453             && looks_like_bool(cUNOPo->op_first));
7454
7455         case OP_ENTERSUB:
7456
7457         case OP_NOT:    case OP_XOR:
7458
7459         case OP_EQ:     case OP_NE:     case OP_LT:
7460         case OP_GT:     case OP_LE:     case OP_GE:
7461
7462         case OP_I_EQ:   case OP_I_NE:   case OP_I_LT:
7463         case OP_I_GT:   case OP_I_LE:   case OP_I_GE:
7464
7465         case OP_SEQ:    case OP_SNE:    case OP_SLT:
7466         case OP_SGT:    case OP_SLE:    case OP_SGE:
7467
7468         case OP_SMARTMATCH:
7469
7470         case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
7471         case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
7472         case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
7473         case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
7474         case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
7475         case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
7476         case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
7477         case OP_FTTEXT:   case OP_FTBINARY:
7478
7479         case OP_DEFINED: case OP_EXISTS:
7480         case OP_MATCH:   case OP_EOF:
7481
7482         case OP_FLOP:
7483
7484             return TRUE;
7485
7486         case OP_CONST:
7487             /* Detect comparisons that have been optimized away */
7488             if (cSVOPo->op_sv == &PL_sv_yes
7489             ||  cSVOPo->op_sv == &PL_sv_no)
7490
7491                 return TRUE;
7492             else
7493                 return FALSE;
7494
7495         /* FALLTHROUGH */
7496         default:
7497             return FALSE;
7498     }
7499 }
7500
7501 /*
7502 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
7503
7504 Constructs, checks, and returns an op tree expressing a C<given> block.
7505 I<cond> supplies the expression that will be locally assigned to a lexical
7506 variable, and I<block> supplies the body of the C<given> construct; they
7507 are consumed by this function and become part of the constructed op tree.
7508 I<defsv_off> is the pad offset of the scalar lexical variable that will
7509 be affected.  If it is 0, the global $_ will be used.
7510
7511 =cut
7512 */
7513
7514 OP *
7515 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
7516 {
7517     PERL_ARGS_ASSERT_NEWGIVENOP;
7518     return newGIVWHENOP(
7519         ref_array_or_hash(cond),
7520         block,
7521         OP_ENTERGIVEN, OP_LEAVEGIVEN,
7522         defsv_off);
7523 }
7524
7525 /*
7526 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
7527
7528 Constructs, checks, and returns an op tree expressing a C<when> block.
7529 I<cond> supplies the test expression, and I<block> supplies the block
7530 that will be executed if the test evaluates to true; they are consumed
7531 by this function and become part of the constructed op tree.  I<cond>
7532 will be interpreted DWIMically, often as a comparison against C<$_>,
7533 and may be null to generate a C<default> block.
7534
7535 =cut
7536 */
7537
7538 OP *
7539 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
7540 {
7541     const bool cond_llb = (!cond || looks_like_bool(cond));
7542     OP *cond_op;
7543
7544     PERL_ARGS_ASSERT_NEWWHENOP;
7545
7546     if (cond_llb)
7547         cond_op = cond;
7548     else {
7549         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
7550                 newDEFSVOP(),
7551                 scalar(ref_array_or_hash(cond)));
7552     }
7553
7554     return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
7555 }
7556
7557 /* must not conflict with SVf_UTF8 */
7558 #define CV_CKPROTO_CURSTASH     0x1
7559
7560 void
7561 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
7562                     const STRLEN len, const U32 flags)
7563 {
7564     SV *name = NULL, *msg;
7565     const char * cvp = SvROK(cv)
7566                         ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
7567                            ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
7568                            : ""
7569                         : CvPROTO(cv);
7570     STRLEN clen = CvPROTOLEN(cv), plen = len;
7571
7572     PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
7573
7574     if (p == NULL && cvp == NULL)
7575         return;
7576
7577     if (!ckWARN_d(WARN_PROTOTYPE))
7578         return;
7579
7580     if (p && cvp) {
7581         p = S_strip_spaces(aTHX_ p, &plen);
7582         cvp = S_strip_spaces(aTHX_ cvp, &clen);
7583         if ((flags & SVf_UTF8) == SvUTF8(cv)) {
7584             if (plen == clen && memEQ(cvp, p, plen))
7585                 return;
7586         } else {
7587             if (flags & SVf_UTF8) {
7588                 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
7589                     return;
7590             }
7591             else {
7592                 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
7593                     return;
7594             }
7595         }
7596     }
7597
7598     msg = sv_newmortal();
7599
7600     if (gv)
7601     {
7602         if (isGV(gv))
7603             gv_efullname3(name = sv_newmortal(), gv, NULL);
7604         else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
7605             name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
7606         else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
7607             name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
7608             sv_catpvs(name, "::");
7609             if (SvROK(gv)) {
7610                 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
7611                 assert (CvNAMED(SvRV_const(gv)));
7612                 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
7613             }
7614             else sv_catsv(name, (SV *)gv);
7615         }
7616         else name = (SV *)gv;
7617     }
7618     sv_setpvs(msg, "Prototype mismatch:");
7619     if (name)
7620         Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
7621     if (cvp)
7622         Perl_sv_catpvf(aTHX_ msg, " (%"UTF8f")",
7623             UTF8fARG(SvUTF8(cv),clen,cvp)
7624         );
7625     else
7626         sv_catpvs(msg, ": none");
7627     sv_catpvs(msg, " vs ");
7628     if (p)
7629         Perl_sv_catpvf(aTHX_ msg, "(%"UTF8f")", UTF8fARG(flags & SVf_UTF8,len,p));
7630     else
7631         sv_catpvs(msg, "none");
7632     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
7633 }
7634
7635 static void const_sv_xsub(pTHX_ CV* cv);
7636 static void const_av_xsub(pTHX_ CV* cv);
7637
7638 /*
7639
7640 =head1 Optree Manipulation Functions
7641
7642 =for apidoc cv_const_sv
7643
7644 If C<cv> is a constant sub eligible for inlining, returns the constant
7645 value returned by the sub.  Otherwise, returns NULL.
7646
7647 Constant subs can be created with C<newCONSTSUB> or as described in
7648 L<perlsub/"Constant Functions">.
7649
7650 =cut
7651 */
7652 SV *
7653 Perl_cv_const_sv(const CV *const cv)
7654 {
7655     SV *sv;
7656     if (!cv)
7657         return NULL;
7658     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
7659         return NULL;
7660     sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7661     if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
7662     return sv;
7663 }
7664
7665 SV *
7666 Perl_cv_const_sv_or_av(const CV * const cv)
7667 {
7668     if (!cv)
7669         return NULL;
7670     if (SvROK(cv)) return SvRV((SV *)cv);
7671     assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
7672     return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7673 }
7674
7675 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
7676  * Can be called in 3 ways:
7677  *
7678  * !cv
7679  *      look for a single OP_CONST with attached value: return the value
7680  *
7681  * cv && CvCLONE(cv) && !CvCONST(cv)
7682  *
7683  *      examine the clone prototype, and if contains only a single
7684  *      OP_CONST referencing a pad const, or a single PADSV referencing
7685  *      an outer lexical, return a non-zero value to indicate the CV is
7686  *      a candidate for "constizing" at clone time
7687  *
7688  * cv && CvCONST(cv)
7689  *
7690  *      We have just cloned an anon prototype that was marked as a const
7691  *      candidate. Try to grab the current value, and in the case of
7692  *      PADSV, ignore it if it has multiple references. In this case we
7693  *      return a newly created *copy* of the value.
7694  */
7695
7696 SV *
7697 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
7698 {
7699     SV *sv = NULL;
7700
7701     if (!o)
7702         return NULL;
7703
7704     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
7705         o = OP_SIBLING(cLISTOPo->op_first);
7706
7707     for (; o; o = o->op_next) {
7708         const OPCODE type = o->op_type;
7709
7710         if (sv && o->op_next == o)
7711             return sv;
7712         if (o->op_next != o) {
7713             if (type == OP_NEXTSTATE
7714              || (type == OP_NULL && !(o->op_flags & OPf_KIDS))
7715              || type == OP_PUSHMARK)
7716                 continue;
7717             if (type == OP_DBSTATE)
7718                 continue;
7719         }
7720         if (type == OP_LEAVESUB || type == OP_RETURN)
7721             break;
7722         if (sv)
7723             return NULL;
7724         if (type == OP_CONST && cSVOPo->op_sv)
7725             sv = cSVOPo->op_sv;
7726         else if (type == OP_UNDEF && !o->op_private) {
7727             sv = newSV(0);
7728             SAVEFREESV(sv);
7729         }
7730         else if (cv && type == OP_CONST) {
7731             sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
7732             if (!sv)
7733                 return NULL;
7734         }
7735         else if (cv && type == OP_PADSV) {
7736             if (CvCONST(cv)) { /* newly cloned anon */
7737                 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
7738                 /* the candidate should have 1 ref from this pad and 1 ref
7739                  * from the parent */
7740                 if (!sv || SvREFCNT(sv) != 2)
7741                     return NULL;
7742                 sv = newSVsv(sv);
7743                 SvREADONLY_on(sv);
7744                 return sv;
7745             }
7746             else {
7747                 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
7748                     sv = &PL_sv_undef; /* an arbitrary non-null value */
7749             }
7750         }
7751         else {
7752             return NULL;
7753         }
7754     }
7755     return sv;
7756 }
7757
7758 static bool
7759 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
7760                         PADNAME * const name, SV ** const const_svp)
7761 {
7762     assert (cv);
7763     assert (o || name);
7764     assert (const_svp);
7765     if ((!block
7766          )) {
7767         if (CvFLAGS(PL_compcv)) {
7768             /* might have had built-in attrs applied */
7769             const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
7770             if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
7771              && ckWARN(WARN_MISC))
7772             {
7773                 /* protect against fatal warnings leaking compcv */
7774                 SAVEFREESV(PL_compcv);
7775                 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
7776                 SvREFCNT_inc_simple_void_NN(PL_compcv);
7777             }
7778             CvFLAGS(cv) |=
7779                 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
7780                   & ~(CVf_LVALUE * pureperl));
7781         }
7782         return FALSE;
7783     }
7784
7785     /* redundant check for speed: */
7786     if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
7787         const line_t oldline = CopLINE(PL_curcop);
7788         SV *namesv = o
7789             ? cSVOPo->op_sv
7790             : sv_2mortal(newSVpvn_utf8(
7791                 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
7792               ));
7793         if (PL_parser && PL_parser->copline != NOLINE)
7794             /* This ensures that warnings are reported at the first
7795                line of a redefinition, not the last.  */
7796             CopLINE_set(PL_curcop, PL_parser->copline);
7797         /* protect against fatal warnings leaking compcv */
7798         SAVEFREESV(PL_compcv);
7799         report_redefined_cv(namesv, cv, const_svp);
7800         SvREFCNT_inc_simple_void_NN(PL_compcv);
7801         CopLINE_set(PL_curcop, oldline);
7802     }
7803     SAVEFREESV(cv);
7804     return TRUE;
7805 }
7806
7807 CV *
7808 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
7809 {
7810     CV **spot;
7811     SV **svspot;
7812     const char *ps;
7813     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
7814     U32 ps_utf8 = 0;
7815     CV *cv = NULL;
7816     CV *compcv = PL_compcv;
7817     SV *const_sv;
7818     PADNAME *name;
7819     PADOFFSET pax = o->op_targ;
7820     CV *outcv = CvOUTSIDE(PL_compcv);
7821     CV *clonee = NULL;
7822     HEK *hek = NULL;
7823     bool reusable = FALSE;
7824 #ifdef PERL_DEBUG_READONLY_OPS
7825     OPSLAB *slab = NULL;
7826 #endif
7827
7828     PERL_ARGS_ASSERT_NEWMYSUB;
7829
7830     /* Find the pad slot for storing the new sub.
7831        We cannot use PL_comppad, as it is the pad owned by the new sub.  We
7832        need to look in CvOUTSIDE and find the pad belonging to the enclos-
7833        ing sub.  And then we need to dig deeper if this is a lexical from
7834        outside, as in:
7835            my sub foo; sub { sub foo { } }
7836      */
7837    redo:
7838     name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
7839     if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
7840         pax = PARENT_PAD_INDEX(name);
7841         outcv = CvOUTSIDE(outcv);
7842         assert(outcv);
7843         goto redo;
7844     }
7845     svspot =
7846         &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
7847                         [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
7848     spot = (CV **)svspot;
7849
7850     if (!(PL_parser && PL_parser->error_count))
7851         move_proto_attr(&proto, &attrs, (GV *)name);
7852
7853     if (proto) {
7854         assert(proto->op_type == OP_CONST);
7855         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
7856         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
7857     }
7858     else
7859         ps = NULL;
7860
7861     if (proto)
7862         SAVEFREEOP(proto);
7863     if (attrs)
7864         SAVEFREEOP(attrs);
7865
7866     if (PL_parser && PL_parser->error_count) {
7867         op_free(block);
7868         SvREFCNT_dec(PL_compcv);
7869         PL_compcv = 0;
7870         goto done;
7871     }
7872
7873     if (CvDEPTH(outcv) && CvCLONE(compcv)) {
7874         cv = *spot;
7875         svspot = (SV **)(spot = &clonee);
7876     }
7877     else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
7878         cv = *spot;
7879     else {
7880         MAGIC *mg;
7881         SvUPGRADE(name, SVt_PVMG);
7882         mg = mg_find(name, PERL_MAGIC_proto);
7883         assert (SvTYPE(*spot) == SVt_PVCV);
7884         if (CvNAMED(*spot))
7885             hek = CvNAME_HEK(*spot);
7886         else {
7887             dVAR;
7888             U32 hash;
7889             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
7890             CvNAME_HEK_set(*spot, hek =
7891                 share_hek(
7892                     PadnamePV(name)+1,
7893                     PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1), hash
7894                 )
7895             );
7896             CvLEXICAL_on(*spot);
7897         }
7898         if (mg) {
7899             assert(mg->mg_obj);
7900             cv = (CV *)mg->mg_obj;
7901         }
7902         else {
7903             sv_magic(name, &PL_sv_undef, PERL_MAGIC_proto, NULL, 0);
7904             mg = mg_find(name, PERL_MAGIC_proto);
7905         }
7906         spot = (CV **)(svspot = &mg->mg_obj);
7907     }
7908
7909     if (!block || !ps || *ps || attrs
7910         || (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS)
7911         )
7912         const_sv = NULL;
7913     else
7914         const_sv = op_const_sv(block, NULL);
7915
7916     if (cv) {
7917         const bool exists = CvROOT(cv) || CvXSUB(cv);
7918
7919         /* if the subroutine doesn't exist and wasn't pre-declared
7920          * with a prototype, assume it will be AUTOLOADed,
7921          * skipping the prototype check
7922          */
7923         if (exists || SvPOK(cv))
7924             cv_ckproto_len_flags(cv, (GV *)name, ps, ps_len, ps_utf8);
7925         /* already defined? */
7926         if (exists) {
7927             if (S_already_defined(aTHX_ cv,block,NULL,name,&const_sv))
7928                 cv = NULL;
7929             else {
7930                 if (attrs) goto attrs;
7931                 /* just a "sub foo;" when &foo is already defined */
7932                 SAVEFREESV(compcv);
7933                 goto done;
7934             }
7935         }
7936         else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
7937             cv = NULL;
7938             reusable = TRUE;
7939         }
7940     }
7941     if (const_sv) {
7942         SvREFCNT_inc_simple_void_NN(const_sv);
7943         SvFLAGS(const_sv) |= SVs_PADTMP;
7944         if (cv) {
7945             assert(!CvROOT(cv) && !CvCONST(cv));
7946             cv_forget_slab(cv);
7947         }
7948         else {
7949             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
7950             CvFILE_set_from_cop(cv, PL_curcop);
7951             CvSTASH_set(cv, PL_curstash);
7952             *spot = cv;
7953         }
7954         sv_setpvs(MUTABLE_SV(cv), "");  /* prototype is "" */
7955         CvXSUBANY(cv).any_ptr = const_sv;
7956         CvXSUB(cv) = const_sv_xsub;
7957         CvCONST_on(cv);
7958         CvISXSUB_on(cv);
7959         PoisonPADLIST(cv);
7960         op_free(block);
7961         SvREFCNT_dec(compcv);
7962         PL_compcv = NULL;
7963         goto setname;
7964     }
7965     /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
7966        determine whether this sub definition is in the same scope as its
7967        declaration.  If this sub definition is inside an inner named pack-
7968        age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
7969        the package sub.  So check PadnameOUTER(name) too.
7970      */
7971     if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
7972         assert(!CvWEAKOUTSIDE(compcv));
7973         SvREFCNT_dec(CvOUTSIDE(compcv));
7974         CvWEAKOUTSIDE_on(compcv);
7975     }
7976     /* XXX else do we have a circular reference? */
7977     if (cv) {   /* must reuse cv in case stub is referenced elsewhere */
7978         /* transfer PL_compcv to cv */
7979         if (block
7980         ) {
7981             cv_flags_t preserved_flags =
7982                 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
7983             PADLIST *const temp_padl = CvPADLIST(cv);
7984             CV *const temp_cv = CvOUTSIDE(cv);
7985             const cv_flags_t other_flags =
7986                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
7987             OP * const cvstart = CvSTART(cv);
7988
7989             SvPOK_off(cv);
7990             CvFLAGS(cv) =
7991                 CvFLAGS(compcv) | preserved_flags;
7992             CvOUTSIDE(cv) = CvOUTSIDE(compcv);
7993             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
7994             CvPADLIST_set(cv, CvPADLIST(compcv));
7995             CvOUTSIDE(compcv) = temp_cv;
7996             CvPADLIST_set(compcv, temp_padl);
7997             CvSTART(cv) = CvSTART(compcv);
7998             CvSTART(compcv) = cvstart;
7999             CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8000             CvFLAGS(compcv) |= other_flags;
8001
8002             if (CvFILE(cv) && CvDYNFILE(cv)) {
8003                 Safefree(CvFILE(cv));
8004             }
8005
8006             /* inner references to compcv must be fixed up ... */
8007             pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
8008             if (PERLDB_INTER)/* Advice debugger on the new sub. */
8009               ++PL_sub_generation;
8010         }
8011         else {
8012             /* Might have had built-in attributes applied -- propagate them. */
8013             CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
8014         }
8015         /* ... before we throw it away */
8016         SvREFCNT_dec(compcv);
8017         PL_compcv = compcv = cv;
8018     }
8019     else {
8020         cv = compcv;
8021         *spot = cv;
8022     }
8023    setname:
8024     CvLEXICAL_on(cv);
8025     if (!CvNAME_HEK(cv)) {
8026         if (hek) (void)share_hek_hek(hek);
8027         else {
8028             dVAR;
8029             U32 hash;
8030             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
8031             hek = share_hek(PadnamePV(name)+1,
8032                       PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1),
8033                       hash);
8034         }
8035         CvNAME_HEK_set(cv, hek);
8036     }
8037     if (const_sv) goto clone;
8038
8039     CvFILE_set_from_cop(cv, PL_curcop);
8040     CvSTASH_set(cv, PL_curstash);
8041
8042     if (ps) {
8043         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8044         if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
8045     }
8046
8047     if (!block)
8048         goto attrs;
8049
8050     /* If we assign an optree to a PVCV, then we've defined a subroutine that
8051        the debugger could be able to set a breakpoint in, so signal to
8052        pp_entereval that it should not throw away any saved lines at scope
8053        exit.  */
8054
8055     PL_breakable_sub_gen++;
8056     /* This makes sub {}; work as expected.  */
8057     if (block->op_type == OP_STUB) {
8058             OP* const newblock = newSTATEOP(0, NULL, 0);
8059             op_free(block);
8060             block = newblock;
8061     }
8062     CvROOT(cv) = CvLVALUE(cv)
8063                    ? newUNOP(OP_LEAVESUBLV, 0,
8064                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
8065                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
8066     CvROOT(cv)->op_private |= OPpREFCOUNTED;
8067     OpREFCNT_set(CvROOT(cv), 1);
8068     /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8069        itself has a refcount. */
8070     CvSLABBED_off(cv);
8071     OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8072 #ifdef PERL_DEBUG_READONLY_OPS
8073     slab = (OPSLAB *)CvSTART(cv);
8074 #endif
8075     CvSTART(cv) = LINKLIST(CvROOT(cv));
8076     CvROOT(cv)->op_next = 0;
8077     CALL_PEEP(CvSTART(cv));
8078     finalize_optree(CvROOT(cv));
8079     S_prune_chain_head(&CvSTART(cv));
8080
8081     /* now that optimizer has done its work, adjust pad values */
8082
8083     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8084
8085     if (CvCLONE(cv)) {
8086         assert(!CvCONST(cv));
8087         if (ps && !*ps && op_const_sv(block, cv))
8088             CvCONST_on(cv);
8089     }
8090
8091   attrs:
8092     if (attrs) {
8093         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8094         apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
8095     }
8096
8097     if (block) {
8098         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8099             SV * const tmpstr = sv_newmortal();
8100             GV * const db_postponed = gv_fetchpvs("DB::postponed",
8101                                                   GV_ADDMULTI, SVt_PVHV);
8102             HV *hv;
8103             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8104                                           CopFILE(PL_curcop),
8105                                           (long)PL_subline,
8106                                           (long)CopLINE(PL_curcop));
8107             if (HvNAME_HEK(PL_curstash)) {
8108                 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
8109                 sv_catpvs(tmpstr, "::");
8110             }
8111             else sv_setpvs(tmpstr, "__ANON__::");
8112             sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
8113                             PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
8114             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8115                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8116             hv = GvHVn(db_postponed);
8117             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8118                 CV * const pcv = GvCV(db_postponed);
8119                 if (pcv) {
8120                     dSP;
8121                     PUSHMARK(SP);
8122                     XPUSHs(tmpstr);
8123                     PUTBACK;
8124                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
8125                 }
8126             }
8127         }
8128     }
8129
8130   clone:
8131     if (clonee) {
8132         assert(CvDEPTH(outcv));
8133         spot = (CV **)
8134             &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
8135         if (reusable) cv_clone_into(clonee, *spot);
8136         else *spot = cv_clone(clonee);
8137         SvREFCNT_dec_NN(clonee);
8138         cv = *spot;
8139     }
8140     if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
8141         PADOFFSET depth = CvDEPTH(outcv);
8142         while (--depth) {
8143             SV *oldcv;
8144             svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
8145             oldcv = *svspot;
8146             *svspot = SvREFCNT_inc_simple_NN(cv);
8147             SvREFCNT_dec(oldcv);
8148         }
8149     }
8150
8151   done:
8152     if (PL_parser)
8153         PL_parser->copline = NOLINE;
8154     LEAVE_SCOPE(floor);
8155 #ifdef PERL_DEBUG_READONLY_OPS
8156     if (slab)
8157         Slab_to_ro(slab);
8158 #endif
8159     if (o) op_free(o);
8160     return cv;
8161 }
8162
8163 /* _x = extended */
8164 CV *
8165 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
8166                             OP *block, bool o_is_gv)
8167 {
8168     GV *gv;
8169     const char *ps;
8170     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
8171     U32 ps_utf8 = 0;
8172     CV *cv = NULL;
8173     SV *const_sv;
8174     const bool ec = PL_parser && PL_parser->error_count;
8175     /* If the subroutine has no body, no attributes, and no builtin attributes
8176        then it's just a sub declaration, and we may be able to get away with
8177        storing with a placeholder scalar in the symbol table, rather than a
8178        full CV.  If anything is present then it will take a full CV to
8179        store it.  */
8180     const I32 gv_fetch_flags
8181         = ec ? GV_NOADD_NOINIT :
8182         (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
8183         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
8184     STRLEN namlen = 0;
8185     const char * const name =
8186          o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
8187     bool has_name;
8188     bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
8189 #ifdef PERL_DEBUG_READONLY_OPS
8190     OPSLAB *slab = NULL;
8191     bool special = FALSE;
8192 #endif
8193
8194     if (o_is_gv) {
8195         gv = (GV*)o;
8196         o = NULL;
8197         has_name = TRUE;
8198     } else if (name) {
8199         /* Try to optimise and avoid creating a GV.  Instead, the CV’s name
8200            hek and CvSTASH pointer together can imply the GV.  If the name
8201            contains a package name, then GvSTASH(CvGV(cv)) may differ from
8202            CvSTASH, so forego the optimisation if we find any.
8203            Also, we may be called from load_module at run time, so
8204            PL_curstash (which sets CvSTASH) may not point to the stash the
8205            sub is stored in.  */
8206         const I32 flags =
8207            ec ? GV_NOADD_NOINIT
8208               :   PL_curstash != CopSTASH(PL_curcop)
8209                || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
8210                     ? gv_fetch_flags
8211                     : GV_ADDMULTI | GV_NOINIT;
8212         gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
8213         has_name = TRUE;
8214     } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
8215         SV * const sv = sv_newmortal();
8216         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
8217                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
8218                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
8219         gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
8220         has_name = TRUE;
8221     } else if (PL_curstash) {
8222         gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
8223         has_name = FALSE;
8224     } else {
8225         gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
8226         has_name = FALSE;
8227     }
8228     if (!ec)
8229         move_proto_attr(&proto, &attrs,
8230                         isGV(gv) ? gv : (GV *)cSVOPo->op_sv);
8231
8232     if (proto) {
8233         assert(proto->op_type == OP_CONST);
8234         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
8235         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
8236     }
8237     else
8238         ps = NULL;
8239
8240     if (o)
8241         SAVEFREEOP(o);
8242     if (proto)
8243         SAVEFREEOP(proto);
8244     if (attrs)
8245         SAVEFREEOP(attrs);
8246
8247     if (ec) {
8248         op_free(block);
8249         if (name) SvREFCNT_dec(PL_compcv);
8250         else cv = PL_compcv;
8251         PL_compcv = 0;
8252         if (name && block) {
8253             const char *s = strrchr(name, ':');
8254             s = s ? s+1 : name;
8255             if (strEQ(s, "BEGIN")) {
8256                 if (PL_in_eval & EVAL_KEEPERR)
8257                     Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
8258                 else {
8259                     SV * const errsv = ERRSV;
8260                     /* force display of errors found but not reported */
8261                     sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
8262                     Perl_croak_nocontext("%"SVf, SVfARG(errsv));
8263                 }
8264             }
8265         }
8266         goto done;
8267     }
8268
8269     if (!block && SvTYPE(gv) != SVt_PVGV) {
8270       /* If we are not defining a new sub and the existing one is not a
8271          full GV + CV... */
8272       if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
8273         /* We are applying attributes to an existing sub, so we need it
8274            upgraded if it is a constant.  */
8275         if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
8276             gv_init_pvn(gv, PL_curstash, name, namlen,
8277                         SVf_UTF8 * name_is_utf8);
8278       }
8279       else {                    /* Maybe prototype now, and had at maximum
8280                                    a prototype or const/sub ref before.  */
8281         if (SvTYPE(gv) > SVt_NULL) {
8282             cv_ckproto_len_flags((const CV *)gv,
8283                                  o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8284                                  ps_len, ps_utf8);
8285         }
8286         if (!SvROK(gv)) {
8287           if (ps) {
8288             sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
8289             if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
8290           }
8291           else
8292             sv_setiv(MUTABLE_SV(gv), -1);
8293         }
8294
8295         SvREFCNT_dec(PL_compcv);
8296         cv = PL_compcv = NULL;
8297         goto done;
8298       }
8299     }
8300
8301     cv = (!name || (isGV(gv) && GvCVGEN(gv)))
8302         ? NULL
8303         : isGV(gv)
8304             ? GvCV(gv)
8305             : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
8306                 ? (CV *)SvRV(gv)
8307                 : NULL;
8308
8309
8310     if (!block || !ps || *ps || attrs
8311         || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
8312         )
8313         const_sv = NULL;
8314     else
8315         const_sv = op_const_sv(block, NULL);
8316
8317     if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
8318         assert (block);
8319         cv_ckproto_len_flags((const CV *)gv,
8320                              o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8321                              ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
8322         if (SvROK(gv)) {
8323             /* All the other code for sub redefinition warnings expects the
8324                clobbered sub to be a CV.  Instead of making all those code
8325                paths more complex, just inline the RV version here.  */
8326             const line_t oldline = CopLINE(PL_curcop);
8327             assert(IN_PERL_COMPILETIME);
8328             if (PL_parser && PL_parser->copline != NOLINE)
8329                 /* This ensures that warnings are reported at the first
8330                    line of a redefinition, not the last.  */
8331                 CopLINE_set(PL_curcop, PL_parser->copline);
8332             /* protect against fatal warnings leaking compcv */
8333             SAVEFREESV(PL_compcv);
8334
8335             if (ckWARN(WARN_REDEFINE)
8336              || (  ckWARN_d(WARN_REDEFINE)
8337                 && (  !const_sv || SvRV(gv) == const_sv
8338                    || sv_cmp(SvRV(gv), const_sv)  )))
8339                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8340                           "Constant subroutine %"SVf" redefined",
8341                           SVfARG(cSVOPo->op_sv));
8342
8343             SvREFCNT_inc_simple_void_NN(PL_compcv);
8344             CopLINE_set(PL_curcop, oldline);
8345             SvREFCNT_dec(SvRV(gv));
8346         }
8347     }
8348
8349     if (cv) {
8350         const bool exists = CvROOT(cv) || CvXSUB(cv);
8351
8352         /* if the subroutine doesn't exist and wasn't pre-declared
8353          * with a prototype, assume it will be AUTOLOADed,
8354          * skipping the prototype check
8355          */
8356         if (exists || SvPOK(cv))
8357             cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
8358         /* already defined (or promised)? */
8359         if (exists || (isGV(gv) && GvASSUMECV(gv))) {
8360             if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv))
8361                 cv = NULL;
8362             else {
8363                 if (attrs) goto attrs;
8364                 /* just a "sub foo;" when &foo is already defined */
8365                 SAVEFREESV(PL_compcv);
8366                 goto done;
8367             }
8368         }
8369     }
8370     if (const_sv) {
8371         SvREFCNT_inc_simple_void_NN(const_sv);
8372         SvFLAGS(const_sv) |= SVs_PADTMP;
8373         if (cv) {
8374             assert(!CvROOT(cv) && !CvCONST(cv));
8375             cv_forget_slab(cv);
8376             sv_setpvs(MUTABLE_SV(cv), "");  /* prototype is "" */
8377             CvXSUBANY(cv).any_ptr = const_sv;
8378             CvXSUB(cv) = const_sv_xsub;
8379             CvCONST_on(cv);
8380             CvISXSUB_on(cv);
8381             PoisonPADLIST(cv);
8382         }
8383         else {
8384             if (isGV(gv)) {
8385                 if (name) GvCV_set(gv, NULL);
8386                 cv = newCONSTSUB_flags(
8387                     NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
8388                     const_sv
8389                 );
8390             }
8391             else {
8392                 if (!SvROK(gv)) {
8393                     SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8394                     prepare_SV_for_RV((SV *)gv);
8395                     SvOK_off((SV *)gv);
8396                     SvROK_on(gv);
8397                 }
8398                 SvRV_set(gv, const_sv);
8399             }
8400         }
8401         op_free(block);
8402         SvREFCNT_dec(PL_compcv);
8403         PL_compcv = NULL;
8404         goto done;
8405     }
8406     if (cv) {                           /* must reuse cv if autoloaded */
8407         /* transfer PL_compcv to cv */
8408         if (block
8409         ) {
8410             cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
8411             PADLIST *const temp_av = CvPADLIST(cv);
8412             CV *const temp_cv = CvOUTSIDE(cv);
8413             const cv_flags_t other_flags =
8414                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8415             OP * const cvstart = CvSTART(cv);
8416
8417             if (isGV(gv)) {
8418                 CvGV_set(cv,gv);
8419                 assert(!CvCVGV_RC(cv));
8420                 assert(CvGV(cv) == gv);
8421             }
8422             else {
8423                 dVAR;
8424                 U32 hash;
8425                 PERL_HASH(hash, name, namlen);
8426                 CvNAME_HEK_set(cv,
8427                                share_hek(name,
8428                                          name_is_utf8
8429                                             ? -(SSize_t)namlen
8430                                             :  (SSize_t)namlen,
8431                                          hash));
8432             }
8433
8434             SvPOK_off(cv);
8435             CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
8436                                              | CvNAMED(cv);
8437             CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
8438             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
8439             CvPADLIST_set(cv,CvPADLIST(PL_compcv));
8440             CvOUTSIDE(PL_compcv) = temp_cv;
8441             CvPADLIST_set(PL_compcv, temp_av);
8442             CvSTART(cv) = CvSTART(PL_compcv);
8443             CvSTART(PL_compcv) = cvstart;
8444             CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8445             CvFLAGS(PL_compcv) |= other_flags;
8446
8447             if (CvFILE(cv) && CvDYNFILE(cv)) {
8448                 Safefree(CvFILE(cv));
8449     }
8450             CvFILE_set_from_cop(cv, PL_curcop);
8451             CvSTASH_set(cv, PL_curstash);
8452
8453             /* inner references to PL_compcv must be fixed up ... */
8454             pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
8455             if (PERLDB_INTER)/* Advice debugger on the new sub. */
8456               ++PL_sub_generation;
8457         }
8458         else {
8459             /* Might have had built-in attributes applied -- propagate them. */
8460             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
8461         }
8462         /* ... before we throw it away */
8463         SvREFCNT_dec(PL_compcv);
8464         PL_compcv = cv;
8465     }
8466     else {
8467         cv = PL_compcv;
8468         if (name && isGV(gv)) {
8469             GvCV_set(gv, cv);
8470             GvCVGEN(gv) = 0;
8471             if (HvENAME_HEK(GvSTASH(gv)))
8472                 /* sub Foo::bar { (shift)+1 } */
8473                 gv_method_changed(gv);
8474         }
8475         else if (name) {
8476             if (!SvROK(gv)) {
8477                 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8478                 prepare_SV_for_RV((SV *)gv);
8479                 SvOK_off((SV *)gv);
8480                 SvROK_on(gv);
8481             }
8482             SvRV_set(gv, (SV *)cv);
8483         }
8484     }
8485     if (!CvHASGV(cv)) {
8486         if (isGV(gv)) CvGV_set(cv, gv);
8487         else {
8488             dVAR;
8489             U32 hash;
8490             PERL_HASH(hash, name, namlen);
8491             CvNAME_HEK_set(cv, share_hek(name,
8492                                          name_is_utf8
8493                                             ? -(SSize_t)namlen
8494                                             :  (SSize_t)namlen,
8495                                          hash));
8496         }
8497         CvFILE_set_from_cop(cv, PL_curcop);
8498         CvSTASH_set(cv, PL_curstash);
8499     }
8500
8501     if (ps) {
8502         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8503         if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
8504     }
8505
8506     if (!block)
8507         goto attrs;
8508
8509     /* If we assign an optree to a PVCV, then we've defined a subroutine that
8510        the debugger could be able to set a breakpoint in, so signal to
8511        pp_entereval that it should not throw away any saved lines at scope
8512        exit.  */
8513
8514     PL_breakable_sub_gen++;
8515     /* This makes sub {}; work as expected.  */
8516     if (block->op_type == OP_STUB) {
8517             OP* const newblock = newSTATEOP(0, NULL, 0);
8518             op_free(block);
8519             block = newblock;
8520     }
8521     CvROOT(cv) = CvLVALUE(cv)
8522                    ? newUNOP(OP_LEAVESUBLV, 0,
8523                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
8524                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
8525     CvROOT(cv)->op_private |= OPpREFCOUNTED;
8526     OpREFCNT_set(CvROOT(cv), 1);
8527     /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8528        itself has a refcount. */
8529     CvSLABBED_off(cv);
8530     OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8531 #ifdef PERL_DEBUG_READONLY_OPS
8532     slab = (OPSLAB *)CvSTART(cv);
8533 #endif
8534     CvSTART(cv) = LINKLIST(CvROOT(cv));
8535     CvROOT(cv)->op_next = 0;
8536     CALL_PEEP(CvSTART(cv));
8537     finalize_optree(CvROOT(cv));
8538     S_prune_chain_head(&CvSTART(cv));
8539
8540     /* now that optimizer has done its work, adjust pad values */
8541
8542     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8543
8544     if (CvCLONE(cv)) {
8545         assert(!CvCONST(cv));
8546         if (ps && !*ps && op_const_sv(block, cv))
8547             CvCONST_on(cv);
8548     }
8549
8550   attrs:
8551     if (attrs) {
8552         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8553         HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
8554                         ? GvSTASH(CvGV(cv))
8555                         : PL_curstash;
8556         if (!name) SAVEFREESV(cv);
8557         apply_attrs(stash, MUTABLE_SV(cv), attrs);
8558         if (!name) SvREFCNT_inc_simple_void_NN(cv);
8559     }
8560
8561     if (block && has_name) {
8562         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8563             SV * const tmpstr = cv_name(cv,NULL,0);
8564             GV * const db_postponed = gv_fetchpvs("DB::postponed",
8565                                                   GV_ADDMULTI, SVt_PVHV);
8566             HV *hv;
8567             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8568                                           CopFILE(PL_curcop),
8569                                           (long)PL_subline,
8570                                           (long)CopLINE(PL_curcop));
8571             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8572                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8573             hv = GvHVn(db_postponed);
8574             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8575                 CV * const pcv = GvCV(db_postponed);
8576                 if (pcv) {
8577                     dSP;
8578                     PUSHMARK(SP);
8579                     XPUSHs(tmpstr);
8580                     PUTBACK;
8581                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
8582                 }
8583             }
8584         }
8585
8586         if (name) {
8587             if (PL_parser && PL_parser->error_count)
8588                 clear_special_blocks(name, gv, cv);
8589             else
8590 #ifdef PERL_DEBUG_READONLY_OPS
8591                 special =
8592 #endif
8593                     process_special_blocks(floor, name, gv, cv);
8594         }
8595     }
8596
8597   done:
8598     if (PL_parser)
8599         PL_parser->copline = NOLINE;
8600     LEAVE_SCOPE(floor);
8601 #ifdef PERL_DEBUG_READONLY_OPS
8602     /* Watch out for BEGIN blocks */
8603     if (!special && slab)
8604         Slab_to_ro(slab);
8605 #endif
8606     return cv;
8607 }
8608
8609 STATIC void
8610 S_clear_special_blocks(pTHX_ const char *const fullname,
8611                        GV *const gv, CV *const cv) {
8612     const char *colon;
8613     const char *name;
8614
8615     PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
8616
8617     colon = strrchr(fullname,':');
8618     name = colon ? colon + 1 : fullname;
8619
8620     if ((*name == 'B' && strEQ(name, "BEGIN"))
8621         || (*name == 'E' && strEQ(name, "END"))
8622         || (*name == 'U' && strEQ(name, "UNITCHECK"))
8623         || (*name == 'C' && strEQ(name, "CHECK"))
8624         || (*name == 'I' && strEQ(name, "INIT"))) {
8625         if (!isGV(gv)) {
8626             (void)CvGV(cv);
8627             assert(isGV(gv));
8628         }
8629         GvCV_set(gv, NULL);
8630         SvREFCNT_dec_NN(MUTABLE_SV(cv));
8631     }
8632 }
8633
8634 STATIC bool
8635 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
8636                          GV *const gv,
8637                          CV *const cv)
8638 {
8639     const char *const colon = strrchr(fullname,':');
8640     const char *const name = colon ? colon + 1 : fullname;
8641
8642     PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
8643
8644     if (*name == 'B') {
8645         if (strEQ(name, "BEGIN")) {
8646             const I32 oldscope = PL_scopestack_ix;
8647             dSP;
8648             (void)CvGV(cv);
8649             if (floor) LEAVE_SCOPE(floor);
8650             ENTER;
8651             PUSHSTACKi(PERLSI_REQUIRE);
8652             SAVECOPFILE(&PL_compiling);
8653             SAVECOPLINE(&PL_compiling);
8654             SAVEVPTR(PL_curcop);
8655
8656             DEBUG_x( dump_sub(gv) );
8657             Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
8658             GvCV_set(gv,0);             /* cv has been hijacked */
8659             call_list(oldscope, PL_beginav);
8660
8661             POPSTACK;
8662             LEAVE;
8663             return TRUE;
8664         }
8665         else
8666             return FALSE;
8667     } else {
8668         if (*name == 'E') {
8669             if strEQ(name, "END") {
8670                 DEBUG_x( dump_sub(gv) );
8671                 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
8672             } else
8673                 return FALSE;
8674         } else if (*name == 'U') {
8675             if (strEQ(name, "UNITCHECK")) {
8676                 /* It's never too late to run a unitcheck block */
8677                 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
8678             }
8679             else
8680                 return FALSE;
8681         } else if (*name == 'C') {
8682             if (strEQ(name, "CHECK")) {
8683                 if (PL_main_start)
8684                     /* diag_listed_as: Too late to run %s block */
8685                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8686                                    "Too late to run CHECK block");
8687                 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
8688             }
8689             else
8690                 return FALSE;
8691         } else if (*name == 'I') {
8692             if (strEQ(name, "INIT")) {
8693                 if (PL_main_start)
8694                     /* diag_listed_as: Too late to run %s block */
8695                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8696                                    "Too late to run INIT block");
8697                 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
8698             }
8699             else
8700                 return FALSE;
8701         } else
8702             return FALSE;
8703         DEBUG_x( dump_sub(gv) );
8704         (void)CvGV(cv);
8705         GvCV_set(gv,0);         /* cv has been hijacked */
8706         return TRUE;
8707     }
8708 }
8709
8710 /*
8711 =for apidoc newCONSTSUB
8712
8713 See L</newCONSTSUB_flags>.
8714
8715 =cut
8716 */
8717
8718 CV *
8719 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
8720 {
8721     return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
8722 }
8723
8724 /*
8725 =for apidoc newCONSTSUB_flags
8726
8727 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
8728 eligible for inlining at compile-time.
8729
8730 Currently, the only useful value for C<flags> is SVf_UTF8.
8731
8732 The newly created subroutine takes ownership of a reference to the passed in
8733 SV.
8734
8735 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
8736 which won't be called if used as a destructor, but will suppress the overhead
8737 of a call to C<AUTOLOAD>.  (This form, however, isn't eligible for inlining at
8738 compile time.)
8739
8740 =cut
8741 */
8742
8743 CV *
8744 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
8745                              U32 flags, SV *sv)
8746 {
8747     CV* cv;
8748     const char *const file = CopFILE(PL_curcop);
8749
8750     ENTER;
8751
8752     if (IN_PERL_RUNTIME) {
8753         /* at runtime, it's not safe to manipulate PL_curcop: it may be
8754          * an op shared between threads. Use a non-shared COP for our
8755          * dirty work */
8756          SAVEVPTR(PL_curcop);
8757          SAVECOMPILEWARNINGS();
8758          PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
8759          PL_curcop = &PL_compiling;
8760     }
8761     SAVECOPLINE(PL_curcop);
8762     CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
8763
8764     SAVEHINTS();
8765     PL_hints &= ~HINT_BLOCK_SCOPE;
8766
8767     if (stash) {
8768         SAVEGENERICSV(PL_curstash);
8769         PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
8770     }
8771
8772     /* Protect sv against leakage caused by fatal warnings. */
8773     if (sv) SAVEFREESV(sv);
8774
8775     /* file becomes the CvFILE. For an XS, it's usually static storage,
8776        and so doesn't get free()d.  (It's expected to be from the C pre-
8777        processor __FILE__ directive). But we need a dynamically allocated one,
8778        and we need it to get freed.  */
8779     cv = newXS_len_flags(name, len,
8780                          sv && SvTYPE(sv) == SVt_PVAV
8781                              ? const_av_xsub
8782                              : const_sv_xsub,
8783                          file ? file : "", "",
8784                          &sv, XS_DYNAMIC_FILENAME | flags);
8785     CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
8786     CvCONST_on(cv);
8787
8788     LEAVE;
8789
8790     return cv;
8791 }
8792
8793 CV *
8794 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
8795                  const char *const filename, const char *const proto,
8796                  U32 flags)
8797 {
8798     PERL_ARGS_ASSERT_NEWXS_FLAGS;
8799     return newXS_len_flags(
8800        name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
8801     );
8802 }
8803
8804 CV *
8805 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
8806                            XSUBADDR_t subaddr, const char *const filename,
8807                            const char *const proto, SV **const_svp,
8808                            U32 flags)
8809 {
8810     CV *cv;
8811     bool interleave = FALSE;
8812
8813     PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
8814
8815     {
8816         GV * const gv = gv_fetchpvn(
8817                             name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
8818                             name ? len : PL_curstash ? sizeof("__ANON__") - 1:
8819                                 sizeof("__ANON__::__ANON__") - 1,
8820                             GV_ADDMULTI | flags, SVt_PVCV);
8821
8822         if (!subaddr)
8823             Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
8824
8825         if ((cv = (name ? GvCV(gv) : NULL))) {
8826             if (GvCVGEN(gv)) {
8827                 /* just a cached method */
8828                 SvREFCNT_dec(cv);
8829                 cv = NULL;
8830             }
8831             else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
8832                 /* already defined (or promised) */
8833                 /* Redundant check that allows us to avoid creating an SV
8834                    most of the time: */
8835                 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
8836                     report_redefined_cv(newSVpvn_flags(
8837                                          name,len,(flags&SVf_UTF8)|SVs_TEMP
8838                                         ),
8839                                         cv, const_svp);
8840                 }
8841                 interleave = TRUE;
8842                 ENTER;
8843                 SAVEFREESV(cv);
8844                 cv = NULL;
8845             }
8846         }
8847
8848         if (cv)                         /* must reuse cv if autoloaded */
8849             cv_undef(cv);
8850         else {
8851             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8852             if (name) {
8853                 GvCV_set(gv,cv);
8854                 GvCVGEN(gv) = 0;
8855                 if (HvENAME_HEK(GvSTASH(gv)))
8856                     gv_method_changed(gv); /* newXS */
8857             }
8858         }
8859         if (!name)
8860             CvANON_on(cv);
8861         CvGV_set(cv, gv);
8862         (void)gv_fetchfile(filename);
8863         CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
8864                                     an external constant string */
8865         assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
8866         CvISXSUB_on(cv);
8867         CvXSUB(cv) = subaddr;
8868 #ifndef PERL_IMPLICIT_CONTEXT
8869         CvHSCXT(cv) = &PL_stack_sp;
8870 #else
8871         PoisonPADLIST(cv);
8872 #endif
8873
8874         if (name)
8875             process_special_blocks(0, name, gv, cv);
8876     }
8877
8878     if (flags & XS_DYNAMIC_FILENAME) {
8879         CvFILE(cv) = savepv(filename);
8880         CvDYNFILE_on(cv);
8881     }
8882     sv_setpv(MUTABLE_SV(cv), proto);
8883     if (interleave) LEAVE;
8884     return cv;
8885 }
8886
8887 CV *
8888 Perl_newSTUB(pTHX_ GV *gv, bool fake)
8889 {
8890     CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8891     GV *cvgv;
8892     PERL_ARGS_ASSERT_NEWSTUB;
8893     assert(!GvCVu(gv));
8894     GvCV_set(gv, cv);
8895     GvCVGEN(gv) = 0;
8896     if (!fake && HvENAME_HEK(GvSTASH(gv)))
8897         gv_method_changed(gv);
8898     if (SvFAKE(gv)) {
8899         cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
8900         SvFAKE_off(cvgv);
8901     }
8902     else cvgv = gv;
8903     CvGV_set(cv, cvgv);
8904     CvFILE_set_from_cop(cv, PL_curcop);
8905     CvSTASH_set(cv, PL_curstash);
8906     GvMULTI_on(gv);
8907     return cv;
8908 }
8909
8910 /*
8911 =for apidoc U||newXS
8912
8913 Used by C<xsubpp> to hook up XSUBs as Perl subs.  I<filename> needs to be
8914 static storage, as it is used directly as CvFILE(), without a copy being made.
8915
8916 =cut
8917 */
8918
8919 CV *
8920 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
8921 {
8922     PERL_ARGS_ASSERT_NEWXS;
8923     return newXS_len_flags(
8924         name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
8925     );
8926 }
8927
8928 void
8929 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
8930 {
8931     CV *cv;
8932
8933     GV *gv;
8934
8935     if (PL_parser && PL_parser->error_count) {
8936         op_free(block);
8937         goto finish;
8938     }
8939
8940     gv = o
8941         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
8942         : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
8943
8944     GvMULTI_on(gv);
8945     if ((cv = GvFORM(gv))) {
8946         if (ckWARN(WARN_REDEFINE)) {
8947             const line_t oldline = CopLINE(PL_curcop);
8948             if (PL_parser && PL_parser->copline != NOLINE)
8949                 CopLINE_set(PL_curcop, PL_parser->copline);
8950             if (o) {
8951                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8952                             "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
8953             } else {
8954                 /* diag_listed_as: Format %s redefined */
8955                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8956                             "Format STDOUT redefined");
8957             }
8958             CopLINE_set(PL_curcop, oldline);
8959         }
8960         SvREFCNT_dec(cv);
8961     }
8962     cv = PL_compcv;
8963     GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
8964     CvGV_set(cv, gv);
8965     CvFILE_set_from_cop(cv, PL_curcop);
8966
8967
8968     pad_tidy(padtidy_FORMAT);
8969     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
8970     CvROOT(cv)->op_private |= OPpREFCOUNTED;
8971     OpREFCNT_set(CvROOT(cv), 1);
8972     CvSTART(cv) = LINKLIST(CvROOT(cv));
8973     CvROOT(cv)->op_next = 0;
8974     CALL_PEEP(CvSTART(cv));
8975     finalize_optree(CvROOT(cv));
8976     S_prune_chain_head(&CvSTART(cv));
8977     cv_forget_slab(cv);
8978
8979   finish:
8980     op_free(o);
8981     if (PL_parser)
8982         PL_parser->copline = NOLINE;
8983     LEAVE_SCOPE(floor);
8984 }
8985
8986 OP *
8987 Perl_newANONLIST(pTHX_ OP *o)
8988 {
8989     return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
8990 }
8991
8992 OP *
8993 Perl_newANONHASH(pTHX_ OP *o)
8994 {
8995     return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
8996 }
8997
8998 OP *
8999 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
9000 {
9001     return newANONATTRSUB(floor, proto, NULL, block);
9002 }
9003
9004 OP *
9005 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
9006 {
9007     return newUNOP(OP_REFGEN, 0,
9008         newSVOP(OP_ANONCODE, 0,
9009                 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
9010 }
9011
9012 OP *
9013 Perl_oopsAV(pTHX_ OP *o)
9014 {
9015     dVAR;
9016
9017     PERL_ARGS_ASSERT_OOPSAV;
9018
9019     switch (o->op_type) {
9020     case OP_PADSV:
9021     case OP_PADHV:
9022         CHANGE_TYPE(o, OP_PADAV);
9023         return ref(o, OP_RV2AV);
9024
9025     case OP_RV2SV:
9026     case OP_RV2HV:
9027         CHANGE_TYPE(o, OP_RV2AV);
9028         ref(o, OP_RV2AV);
9029         break;
9030
9031     default:
9032         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
9033         break;
9034     }
9035     return o;
9036 }
9037
9038 OP *
9039 Perl_oopsHV(pTHX_ OP *o)
9040 {
9041     dVAR;
9042
9043     PERL_ARGS_ASSERT_OOPSHV;
9044
9045     switch (o->op_type) {
9046     case OP_PADSV:
9047     case OP_PADAV:
9048         CHANGE_TYPE(o, OP_PADHV);
9049         return ref(o, OP_RV2HV);
9050
9051     case OP_RV2SV:
9052     case OP_RV2AV:
9053         CHANGE_TYPE(o, OP_RV2HV);
9054         ref(o, OP_RV2HV);
9055         break;
9056
9057     default:
9058         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
9059         break;
9060     }
9061     return o;
9062 }
9063
9064 OP *
9065 Perl_newAVREF(pTHX_ OP *o)
9066 {
9067     dVAR;
9068
9069     PERL_ARGS_ASSERT_NEWAVREF;
9070
9071     if (o->op_type == OP_PADANY) {
9072         CHANGE_TYPE(o, OP_PADAV);
9073         return o;
9074     }
9075     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
9076         Perl_croak(aTHX_ "Can't use an array as a reference");
9077     }
9078     return newUNOP(OP_RV2AV, 0, scalar(o));
9079 }
9080
9081 OP *
9082 Perl_newGVREF(pTHX_ I32 type, OP *o)
9083 {
9084     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
9085         return newUNOP(OP_NULL, 0, o);
9086     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
9087 }
9088
9089 OP *
9090 Perl_newHVREF(pTHX_ OP *o)
9091 {
9092     dVAR;
9093
9094     PERL_ARGS_ASSERT_NEWHVREF;
9095
9096     if (o->op_type == OP_PADANY) {
9097         CHANGE_TYPE(o, OP_PADHV);
9098         return o;
9099     }
9100     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
9101         Perl_croak(aTHX_ "Can't use a hash as a reference");
9102     }
9103     return newUNOP(OP_RV2HV, 0, scalar(o));
9104 }
9105
9106 OP *
9107 Perl_newCVREF(pTHX_ I32 flags, OP *o)
9108 {
9109     if (o->op_type == OP_PADANY) {
9110         dVAR;
9111         CHANGE_TYPE(o, OP_PADCV);
9112     }
9113     return newUNOP(OP_RV2CV, flags, scalar(o));
9114 }
9115
9116 OP *
9117 Perl_newSVREF(pTHX_ OP *o)
9118 {
9119     dVAR;
9120
9121     PERL_ARGS_ASSERT_NEWSVREF;
9122
9123     if (o->op_type == OP_PADANY) {
9124         CHANGE_TYPE(o, OP_PADSV);
9125         return o;
9126     }
9127     return newUNOP(OP_RV2SV, 0, scalar(o));
9128 }
9129
9130 /* Check routines. See the comments at the top of this file for details
9131  * on when these are called */
9132
9133 OP *
9134 Perl_ck_anoncode(pTHX_ OP *o)
9135 {
9136     PERL_ARGS_ASSERT_CK_ANONCODE;
9137
9138     cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
9139     cSVOPo->op_sv = NULL;
9140     return o;
9141 }
9142
9143 static void
9144 S_io_hints(pTHX_ OP *o)
9145 {
9146 #if O_BINARY != 0 || O_TEXT != 0
9147     HV * const table =
9148         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
9149     if (table) {
9150         SV **svp = hv_fetchs(table, "open_IN", FALSE);
9151         if (svp && *svp) {
9152             STRLEN len = 0;
9153             const char *d = SvPV_const(*svp, len);
9154             const I32 mode = mode_from_discipline(d, len);
9155             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9156 #  if O_BINARY != 0
9157             if (mode & O_BINARY)
9158                 o->op_private |= OPpOPEN_IN_RAW;
9159 #  endif
9160 #  if O_TEXT != 0
9161             if (mode & O_TEXT)
9162                 o->op_private |= OPpOPEN_IN_CRLF;
9163 #  endif
9164         }
9165
9166         svp = hv_fetchs(table, "open_OUT", FALSE);
9167         if (svp && *svp) {
9168             STRLEN len = 0;
9169             const char *d = SvPV_const(*svp, len);
9170             const I32 mode = mode_from_discipline(d, len);
9171             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9172 #  if O_BINARY != 0
9173             if (mode & O_BINARY)
9174                 o->op_private |= OPpOPEN_OUT_RAW;
9175 #  endif
9176 #  if O_TEXT != 0
9177             if (mode & O_TEXT)
9178                 o->op_private |= OPpOPEN_OUT_CRLF;
9179 #  endif
9180         }
9181     }
9182 #else
9183     PERL_UNUSED_CONTEXT;
9184     PERL_UNUSED_ARG(o);
9185 #endif
9186 }
9187
9188 OP *
9189 Perl_ck_backtick(pTHX_ OP *o)
9190 {
9191     GV *gv;
9192     OP *newop = NULL;
9193     OP *sibl;
9194     PERL_ARGS_ASSERT_CK_BACKTICK;
9195     /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
9196     if (o->op_flags & OPf_KIDS && (sibl = OP_SIBLING(cUNOPo->op_first))
9197      && (gv = gv_override("readpipe",8)))
9198     {
9199         /* detach rest of siblings from o and its first child */
9200         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
9201         newop = S_new_entersubop(aTHX_ gv, sibl);
9202     }
9203     else if (!(o->op_flags & OPf_KIDS))
9204         newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
9205     if (newop) {
9206         op_free(o);
9207         return newop;
9208     }
9209     S_io_hints(aTHX_ o);
9210     return o;
9211 }
9212
9213 OP *
9214 Perl_ck_bitop(pTHX_ OP *o)
9215 {
9216     PERL_ARGS_ASSERT_CK_BITOP;
9217
9218     o->op_private = (U8)(PL_hints & HINT_INTEGER);
9219     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
9220             && (o->op_type == OP_BIT_OR
9221              || o->op_type == OP_BIT_AND
9222              || o->op_type == OP_BIT_XOR))
9223     {
9224         const OP * const left = cBINOPo->op_first;
9225         const OP * const right = OP_SIBLING(left);
9226         if ((OP_IS_NUMCOMPARE(left->op_type) &&
9227                 (left->op_flags & OPf_PARENS) == 0) ||
9228             (OP_IS_NUMCOMPARE(right->op_type) &&
9229                 (right->op_flags & OPf_PARENS) == 0))
9230             Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
9231                            "Possible precedence problem on bitwise %c operator",
9232                            o->op_type == OP_BIT_OR ? '|'
9233                            : o->op_type == OP_BIT_AND ? '&' : '^'
9234                            );
9235     }
9236     return o;
9237 }
9238
9239 PERL_STATIC_INLINE bool
9240 is_dollar_bracket(pTHX_ const OP * const o)
9241 {
9242     const OP *kid;
9243     PERL_UNUSED_CONTEXT;
9244     return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
9245         && (kid = cUNOPx(o)->op_first)
9246         && kid->op_type == OP_GV
9247         && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
9248 }
9249
9250 OP *
9251 Perl_ck_cmp(pTHX_ OP *o)
9252 {
9253     PERL_ARGS_ASSERT_CK_CMP;
9254     if (ckWARN(WARN_SYNTAX)) {
9255         const OP *kid = cUNOPo->op_first;
9256         if (kid &&
9257             (
9258                 (   is_dollar_bracket(aTHX_ kid)
9259                  && OP_SIBLING(kid) && OP_SIBLING(kid)->op_type == OP_CONST
9260                 )
9261              || (   kid->op_type == OP_CONST
9262                  && (kid = OP_SIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
9263                 )
9264            )
9265         )
9266             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9267                         "$[ used in %s (did you mean $] ?)", OP_DESC(o));
9268     }
9269     return o;
9270 }
9271
9272 OP *
9273 Perl_ck_concat(pTHX_ OP *o)
9274 {
9275     const OP * const kid = cUNOPo->op_first;
9276
9277     PERL_ARGS_ASSERT_CK_CONCAT;
9278     PERL_UNUSED_CONTEXT;
9279
9280     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
9281             !(kUNOP->op_first->op_flags & OPf_MOD))
9282         o->op_flags |= OPf_STACKED;
9283     return o;
9284 }
9285
9286 OP *
9287 Perl_ck_spair(pTHX_ OP *o)
9288 {
9289     dVAR;
9290
9291     PERL_ARGS_ASSERT_CK_SPAIR;
9292
9293     if (o->op_flags & OPf_KIDS) {
9294         OP* newop;
9295         OP* kid;
9296         OP* kidkid;
9297         const OPCODE type = o->op_type;
9298         o = modkids(ck_fun(o), type);
9299         kid    = cUNOPo->op_first;
9300         kidkid = kUNOP->op_first;
9301         newop = OP_SIBLING(kidkid);
9302         if (newop) {
9303             const OPCODE type = newop->op_type;
9304             if (OP_HAS_SIBLING(newop))
9305                 return o;
9306             if (o->op_type == OP_REFGEN && !(newop->op_flags & OPf_PARENS)
9307                 && (type == OP_RV2AV || type == OP_PADAV
9308                  || type == OP_RV2HV || type == OP_PADHV
9309                  || type == OP_RV2CV))
9310                 NOOP; /* OK (allow srefgen for \@a and \%h) */
9311             else if (!(PL_opargs[type] & OA_RETSCALAR))
9312                 return o;
9313         }
9314         /* excise first sibling */
9315         op_sibling_splice(kid, NULL, 1, NULL);
9316         op_free(kidkid);
9317     }
9318     /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
9319      * and OP_CHOMP into OP_SCHOMP */
9320     o->op_ppaddr = PL_ppaddr[++o->op_type];
9321     return ck_fun(o);
9322 }
9323
9324 OP *
9325 Perl_ck_delete(pTHX_ OP *o)
9326 {
9327     PERL_ARGS_ASSERT_CK_DELETE;
9328
9329     o = ck_fun(o);
9330     o->op_private = 0;
9331     if (o->op_flags & OPf_KIDS) {
9332         OP * const kid = cUNOPo->op_first;
9333         switch (kid->op_type) {
9334         case OP_ASLICE:
9335             o->op_flags |= OPf_SPECIAL;
9336             /* FALLTHROUGH */
9337         case OP_HSLICE:
9338             o->op_private |= OPpSLICE;
9339             break;
9340         case OP_AELEM:
9341             o->op_flags |= OPf_SPECIAL;
9342             /* FALLTHROUGH */
9343         case OP_HELEM:
9344             break;
9345         case OP_KVASLICE:
9346             Perl_croak(aTHX_ "delete argument is index/value array slice,"
9347                              " use array slice");
9348         case OP_KVHSLICE:
9349             Perl_croak(aTHX_ "delete argument is key/value hash slice, use"
9350                              " hash slice");
9351         default:
9352             Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
9353                              "element or slice");
9354         }
9355         if (kid->op_private & OPpLVAL_INTRO)
9356             o->op_private |= OPpLVAL_INTRO;
9357         op_null(kid);
9358     }
9359     return o;
9360 }
9361
9362 OP *
9363 Perl_ck_eof(pTHX_ OP *o)
9364 {
9365     PERL_ARGS_ASSERT_CK_EOF;
9366
9367     if (o->op_flags & OPf_KIDS) {
9368         OP *kid;
9369         if (cLISTOPo->op_first->op_type == OP_STUB) {
9370             OP * const newop
9371                 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
9372             op_free(o);
9373             o = newop;
9374         }
9375         o = ck_fun(o);
9376         kid = cLISTOPo->op_first;
9377         if (kid->op_type == OP_RV2GV)
9378             kid->op_private |= OPpALLOW_FAKE;
9379     }
9380     return o;
9381 }
9382
9383 OP *
9384 Perl_ck_eval(pTHX_ OP *o)
9385 {
9386     dVAR;
9387
9388     PERL_ARGS_ASSERT_CK_EVAL;
9389
9390     PL_hints |= HINT_BLOCK_SCOPE;
9391     if (o->op_flags & OPf_KIDS) {
9392         SVOP * const kid = (SVOP*)cUNOPo->op_first;
9393         assert(kid);
9394
9395         if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
9396             LOGOP *enter;
9397
9398             /* cut whole sibling chain free from o */
9399             op_sibling_splice(o, NULL, -1, NULL);
9400             op_free(o);
9401
9402             enter = S_alloc_LOGOP(aTHX_ OP_ENTERTRY, NULL, NULL);
9403
9404             /* establish postfix order */
9405             enter->op_next = (OP*)enter;
9406
9407             o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
9408             CHANGE_TYPE(o, OP_LEAVETRY);
9409             enter->op_other = o;
9410             return o;
9411         }
9412         else {
9413             scalar((OP*)kid);
9414             PL_cv_has_eval = 1;
9415         }
9416     }
9417     else {
9418         const U8 priv = o->op_private;
9419         op_free(o);
9420         /* the newUNOP will recursively call ck_eval(), which will handle
9421          * all the stuff at the end of this function, like adding
9422          * OP_HINTSEVAL
9423          */
9424         return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
9425     }
9426     o->op_targ = (PADOFFSET)PL_hints;
9427     if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
9428     if ((PL_hints & HINT_LOCALIZE_HH) != 0
9429      && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
9430         /* Store a copy of %^H that pp_entereval can pick up. */
9431         OP *hhop = newSVOP(OP_HINTSEVAL, 0,
9432                            MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
9433         /* append hhop to only child  */
9434         op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
9435
9436         o->op_private |= OPpEVAL_HAS_HH;
9437     }
9438     if (!(o->op_private & OPpEVAL_BYTES)
9439          && FEATURE_UNIEVAL_IS_ENABLED)
9440             o->op_private |= OPpEVAL_UNICODE;
9441     return o;
9442 }
9443
9444 OP *
9445 Perl_ck_exec(pTHX_ OP *o)
9446 {
9447     PERL_ARGS_ASSERT_CK_EXEC;
9448
9449     if (o->op_flags & OPf_STACKED) {
9450         OP *kid;
9451         o = ck_fun(o);
9452         kid = OP_SIBLING(cUNOPo->op_first);
9453         if (kid->op_type == OP_RV2GV)
9454             op_null(kid);
9455     }
9456     else
9457         o = listkids(o);
9458     return o;
9459 }
9460
9461 OP *
9462 Perl_ck_exists(pTHX_ OP *o)
9463 {
9464     PERL_ARGS_ASSERT_CK_EXISTS;
9465
9466     o = ck_fun(o);
9467     if (o->op_flags & OPf_KIDS) {
9468         OP * const kid = cUNOPo->op_first;
9469         if (kid->op_type == OP_ENTERSUB) {
9470             (void) ref(kid, o->op_type);
9471             if (kid->op_type != OP_RV2CV
9472                         && !(PL_parser && PL_parser->error_count))
9473                 Perl_croak(aTHX_
9474                           "exists argument is not a subroutine name");
9475             o->op_private |= OPpEXISTS_SUB;
9476         }
9477         else if (kid->op_type == OP_AELEM)
9478             o->op_flags |= OPf_SPECIAL;
9479         else if (kid->op_type != OP_HELEM)
9480             Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
9481                              "element or a subroutine");
9482         op_null(kid);
9483     }
9484     return o;
9485 }
9486
9487 OP *
9488 Perl_ck_rvconst(pTHX_ OP *o)
9489 {
9490     dVAR;
9491     SVOP * const kid = (SVOP*)cUNOPo->op_first;
9492
9493     PERL_ARGS_ASSERT_CK_RVCONST;
9494
9495     o->op_private |= (PL_hints & HINT_STRICT_REFS);
9496
9497     if (kid->op_type == OP_CONST) {
9498         int iscv;
9499         GV *gv;
9500         SV * const kidsv = kid->op_sv;
9501
9502         /* Is it a constant from cv_const_sv()? */
9503         if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
9504             return o;
9505         }
9506         if (SvTYPE(kidsv) == SVt_PVAV) return o;
9507         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
9508             const char *badthing;
9509             switch (o->op_type) {
9510             case OP_RV2SV:
9511                 badthing = "a SCALAR";
9512                 break;
9513             case OP_RV2AV:
9514                 badthing = "an ARRAY";
9515                 break;
9516             case OP_RV2HV:
9517                 badthing = "a HASH";
9518                 break;
9519             default:
9520                 badthing = NULL;
9521                 break;
9522             }
9523             if (badthing)
9524                 Perl_croak(aTHX_
9525                            "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
9526                            SVfARG(kidsv), badthing);
9527         }
9528         /*
9529          * This is a little tricky.  We only want to add the symbol if we
9530          * didn't add it in the lexer.  Otherwise we get duplicate strict
9531          * warnings.  But if we didn't add it in the lexer, we must at
9532          * least pretend like we wanted to add it even if it existed before,
9533          * or we get possible typo warnings.  OPpCONST_ENTERED says
9534          * whether the lexer already added THIS instance of this symbol.
9535          */
9536         iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
9537         gv = gv_fetchsv(kidsv,
9538                 o->op_type == OP_RV2CV
9539                         && o->op_private & OPpMAY_RETURN_CONSTANT
9540                     ? GV_NOEXPAND
9541                     : iscv | !(kid->op_private & OPpCONST_ENTERED),
9542                 iscv
9543                     ? SVt_PVCV
9544                     : o->op_type == OP_RV2SV
9545                         ? SVt_PV
9546                         : o->op_type == OP_RV2AV
9547                             ? SVt_PVAV
9548                             : o->op_type == OP_RV2HV
9549                                 ? SVt_PVHV
9550                                 : SVt_PVGV);
9551         if (gv) {
9552             if (!isGV(gv)) {
9553                 assert(iscv);
9554                 assert(SvROK(gv));
9555                 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
9556                   && SvTYPE(SvRV(gv)) != SVt_PVCV)
9557                     gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
9558             }
9559             CHANGE_TYPE(kid, OP_GV);
9560             SvREFCNT_dec(kid->op_sv);
9561 #ifdef USE_ITHREADS
9562             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
9563             assert (sizeof(PADOP) <= sizeof(SVOP));
9564             kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
9565             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
9566             PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
9567 #else
9568             kid->op_sv = SvREFCNT_inc_simple_NN(gv);
9569 #endif
9570             kid->op_private = 0;
9571             /* FAKE globs in the symbol table cause weird bugs (#77810) */
9572             SvFAKE_off(gv);
9573         }
9574     }
9575     return o;
9576 }
9577
9578 OP *
9579 Perl_ck_ftst(pTHX_ OP *o)
9580 {
9581     dVAR;
9582     const I32 type = o->op_type;
9583
9584     PERL_ARGS_ASSERT_CK_FTST;
9585
9586     if (o->op_flags & OPf_REF) {
9587         NOOP;
9588     }
9589     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
9590         SVOP * const kid = (SVOP*)cUNOPo->op_first;
9591         const OPCODE kidtype = kid->op_type;
9592
9593         if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
9594          && !kid->op_folded) {
9595             OP * const newop = newGVOP(type, OPf_REF,
9596                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
9597             op_free(o);
9598             return newop;
9599         }
9600         if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
9601             o->op_private |= OPpFT_ACCESS;
9602         if (PL_check[kidtype] == Perl_ck_ftst
9603                 && kidtype != OP_STAT && kidtype != OP_LSTAT) {
9604             o->op_private |= OPpFT_STACKED;
9605             kid->op_private |= OPpFT_STACKING;
9606             if (kidtype == OP_FTTTY && (
9607                    !(kid->op_private & OPpFT_STACKED)
9608                 || kid->op_private & OPpFT_AFTER_t
9609                ))
9610                 o->op_private |= OPpFT_AFTER_t;
9611         }
9612     }
9613     else {
9614         op_free(o);
9615         if (type == OP_FTTTY)
9616             o = newGVOP(type, OPf_REF, PL_stdingv);
9617         else
9618             o = newUNOP(type, 0, newDEFSVOP());
9619     }
9620     return o;
9621 }
9622
9623 OP *
9624 Perl_ck_fun(pTHX_ OP *o)
9625 {
9626     const int type = o->op_type;
9627     I32 oa = PL_opargs[type] >> OASHIFT;
9628
9629     PERL_ARGS_ASSERT_CK_FUN;
9630
9631     if (o->op_flags & OPf_STACKED) {
9632         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
9633             oa &= ~OA_OPTIONAL;
9634         else
9635             return no_fh_allowed(o);
9636     }
9637
9638     if (o->op_flags & OPf_KIDS) {
9639         OP *prev_kid = NULL;
9640         OP *kid = cLISTOPo->op_first;
9641         I32 numargs = 0;
9642         bool seen_optional = FALSE;
9643
9644         if (kid->op_type == OP_PUSHMARK ||
9645             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
9646         {
9647             prev_kid = kid;
9648             kid = OP_SIBLING(kid);
9649         }
9650         if (kid && kid->op_type == OP_COREARGS) {
9651             bool optional = FALSE;
9652             while (oa) {
9653                 numargs++;
9654                 if (oa & OA_OPTIONAL) optional = TRUE;
9655                 oa = oa >> 4;
9656             }
9657             if (optional) o->op_private |= numargs;
9658             return o;
9659         }
9660
9661         while (oa) {
9662             if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
9663                 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
9664                     kid = newDEFSVOP();
9665                     /* append kid to chain */
9666                     op_sibling_splice(o, prev_kid, 0, kid);
9667                 }
9668                 seen_optional = TRUE;
9669             }
9670             if (!kid) break;
9671
9672             numargs++;
9673             switch (oa & 7) {
9674             case OA_SCALAR:
9675                 /* list seen where single (scalar) arg expected? */
9676                 if (numargs == 1 && !(oa >> 4)
9677                     && kid->op_type == OP_LIST && type != OP_SCALAR)
9678                 {
9679                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
9680                 }
9681                 if (type != OP_DELETE) scalar(kid);
9682                 break;
9683             case OA_LIST:
9684                 if (oa < 16) {
9685                     kid = 0;
9686                     continue;
9687                 }
9688                 else
9689                     list(kid);
9690                 break;
9691             case OA_AVREF:
9692                 if ((type == OP_PUSH || type == OP_UNSHIFT)
9693                     && !OP_HAS_SIBLING(kid))
9694                     Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
9695                                    "Useless use of %s with no values",
9696                                    PL_op_desc[type]);
9697
9698                 if (kid->op_type == OP_CONST
9699                       && (  !SvROK(cSVOPx_sv(kid))
9700                          || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV  )
9701                         )
9702                     bad_type_pv(numargs, "array", PL_op_desc[type], 0, kid);
9703                 /* Defer checks to run-time if we have a scalar arg */
9704                 if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
9705                     op_lvalue(kid, type);
9706                 else {
9707                     scalar(kid);
9708                     /* diag_listed_as: push on reference is experimental */
9709                     Perl_ck_warner_d(aTHX_
9710                                      packWARN(WARN_EXPERIMENTAL__AUTODEREF),
9711                                     "%s on reference is experimental",
9712                                      PL_op_desc[type]);
9713                 }
9714                 break;
9715             case OA_HVREF:
9716                 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
9717                     bad_type_pv(numargs, "hash", PL_op_desc[type], 0, kid);
9718                 op_lvalue(kid, type);
9719                 break;
9720             case OA_CVREF:
9721                 {
9722                     /* replace kid with newop in chain */
9723                     OP * const newop =
9724                         S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
9725                     newop->op_next = newop;
9726                     kid = newop;
9727                 }
9728                 break;
9729             case OA_FILEREF:
9730                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
9731                     if (kid->op_type == OP_CONST &&
9732                         (kid->op_private & OPpCONST_BARE))
9733                     {
9734                         OP * const newop = newGVOP(OP_GV, 0,
9735                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
9736                         /* replace kid with newop in chain */
9737                         op_sibling_splice(o, prev_kid, 1, newop);
9738                         op_free(kid);
9739                         kid = newop;
9740                     }
9741                     else if (kid->op_type == OP_READLINE) {
9742                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
9743                         bad_type_pv(numargs, "HANDLE", OP_DESC(o), 0, kid);
9744                     }
9745                     else {
9746                         I32 flags = OPf_SPECIAL;
9747                         I32 priv = 0;
9748                         PADOFFSET targ = 0;
9749
9750                         /* is this op a FH constructor? */
9751                         if (is_handle_constructor(o,numargs)) {
9752                             const char *name = NULL;
9753                             STRLEN len = 0;
9754                             U32 name_utf8 = 0;
9755                             bool want_dollar = TRUE;
9756
9757                             flags = 0;
9758                             /* Set a flag to tell rv2gv to vivify
9759                              * need to "prove" flag does not mean something
9760                              * else already - NI-S 1999/05/07
9761                              */
9762                             priv = OPpDEREF;
9763                             if (kid->op_type == OP_PADSV) {
9764                                 SV *const namesv
9765                                     = PAD_COMPNAME_SV(kid->op_targ);
9766                                 name = SvPV_const(namesv, len);
9767                                 name_utf8 = SvUTF8(namesv);
9768                             }
9769                             else if (kid->op_type == OP_RV2SV
9770                                      && kUNOP->op_first->op_type == OP_GV)
9771                             {
9772                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
9773                                 name = GvNAME(gv);
9774                                 len = GvNAMELEN(gv);
9775                                 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
9776                             }
9777                             else if (kid->op_type == OP_AELEM
9778                                      || kid->op_type == OP_HELEM)
9779                             {
9780                                  OP *firstop;
9781                                  OP *op = ((BINOP*)kid)->op_first;
9782                                  name = NULL;
9783                                  if (op) {
9784                                       SV *tmpstr = NULL;
9785                                       const char * const a =
9786                                            kid->op_type == OP_AELEM ?
9787                                            "[]" : "{}";
9788                                       if (((op->op_type == OP_RV2AV) ||
9789                                            (op->op_type == OP_RV2HV)) &&
9790                                           (firstop = ((UNOP*)op)->op_first) &&
9791                                           (firstop->op_type == OP_GV)) {
9792                                            /* packagevar $a[] or $h{} */
9793                                            GV * const gv = cGVOPx_gv(firstop);
9794                                            if (gv)
9795                                                 tmpstr =
9796                                                      Perl_newSVpvf(aTHX_
9797                                                                    "%s%c...%c",
9798                                                                    GvNAME(gv),
9799                                                                    a[0], a[1]);
9800                                       }
9801                                       else if (op->op_type == OP_PADAV
9802                                                || op->op_type == OP_PADHV) {
9803                                            /* lexicalvar $a[] or $h{} */
9804                                            const char * const padname =
9805                                                 PAD_COMPNAME_PV(op->op_targ);
9806                                            if (padname)
9807                                                 tmpstr =
9808                                                      Perl_newSVpvf(aTHX_
9809                                                                    "%s%c...%c",
9810                                                                    padname + 1,
9811                                                                    a[0], a[1]);
9812                                       }
9813                                       if (tmpstr) {
9814                                            name = SvPV_const(tmpstr, len);
9815                                            name_utf8 = SvUTF8(tmpstr);
9816                                            sv_2mortal(tmpstr);
9817                                       }
9818                                  }
9819                                  if (!name) {
9820                                       name = "__ANONIO__";
9821                                       len = 10;
9822                                       want_dollar = FALSE;
9823                                  }
9824                                  op_lvalue(kid, type);
9825                             }
9826                             if (name) {
9827                                 SV *namesv;
9828                                 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
9829                                 namesv = PAD_SVl(targ);
9830                                 if (want_dollar && *name != '$')
9831                                     sv_setpvs(namesv, "$");
9832                                 else
9833                                     sv_setpvs(namesv, "");
9834                                 sv_catpvn(namesv, name, len);
9835                                 if ( name_utf8 ) SvUTF8_on(namesv);
9836                             }
9837                         }
9838                         scalar(kid);
9839                         kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
9840                                     OP_RV2GV, flags);
9841                         kid->op_targ = targ;
9842                         kid->op_private |= priv;
9843                     }
9844                 }
9845                 scalar(kid);
9846                 break;
9847             case OA_SCALARREF:
9848                 if ((type == OP_UNDEF || type == OP_POS)
9849                     && numargs == 1 && !(oa >> 4)
9850                     && kid->op_type == OP_LIST)
9851                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
9852                 op_lvalue(scalar(kid), type);
9853                 break;
9854             }
9855             oa >>= 4;
9856             prev_kid = kid;
9857             kid = OP_SIBLING(kid);
9858         }
9859         /* FIXME - should the numargs or-ing move after the too many
9860          * arguments check? */
9861         o->op_private |= numargs;
9862         if (kid)
9863             return too_many_arguments_pv(o,OP_DESC(o), 0);
9864         listkids(o);
9865     }
9866     else if (PL_opargs[type] & OA_DEFGV) {
9867         /* Ordering of these two is important to keep f_map.t passing.  */
9868         op_free(o);
9869         return newUNOP(type, 0, newDEFSVOP());
9870     }
9871
9872     if (oa) {
9873         while (oa & OA_OPTIONAL)
9874             oa >>= 4;
9875         if (oa && oa != OA_LIST)
9876             return too_few_arguments_pv(o,OP_DESC(o), 0);
9877     }
9878     return o;
9879 }
9880
9881 OP *
9882 Perl_ck_glob(pTHX_ OP *o)
9883 {
9884     GV *gv;
9885
9886     PERL_ARGS_ASSERT_CK_GLOB;
9887
9888     o = ck_fun(o);
9889     if ((o->op_flags & OPf_KIDS) && !OP_HAS_SIBLING(cLISTOPo->op_first))
9890         op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
9891
9892     if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
9893     {
9894         /* convert
9895          *     glob
9896          *       \ null - const(wildcard)
9897          * into
9898          *     null
9899          *       \ enter
9900          *            \ list
9901          *                 \ mark - glob - rv2cv
9902          *                             |        \ gv(CORE::GLOBAL::glob)
9903          *                             |
9904          *                              \ null - const(wildcard)
9905          */
9906         o->op_flags |= OPf_SPECIAL;
9907         o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
9908         o = S_new_entersubop(aTHX_ gv, o);
9909         o = newUNOP(OP_NULL, 0, o);
9910         o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
9911         return o;
9912     }
9913     else o->op_flags &= ~OPf_SPECIAL;
9914 #if !defined(PERL_EXTERNAL_GLOB)
9915     if (!PL_globhook) {
9916         ENTER;
9917         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
9918                                newSVpvs("File::Glob"), NULL, NULL, NULL);
9919         LEAVE;
9920     }
9921 #endif /* !PERL_EXTERNAL_GLOB */
9922     gv = (GV *)newSV(0);
9923     gv_init(gv, 0, "", 0, 0);
9924     gv_IOadd(gv);
9925     op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
9926     SvREFCNT_dec_NN(gv); /* newGVOP increased it */
9927     scalarkids(o);
9928     return o;
9929 }
9930
9931 OP *
9932 Perl_ck_grep(pTHX_ OP *o)
9933 {
9934     dVAR;
9935     LOGOP *gwop;
9936     OP *kid;
9937     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
9938     PADOFFSET offset;
9939
9940     PERL_ARGS_ASSERT_CK_GREP;
9941
9942     /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
9943
9944     if (o->op_flags & OPf_STACKED) {
9945         kid = cUNOPx(OP_SIBLING(cLISTOPo->op_first))->op_first;
9946         if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
9947             return no_fh_allowed(o);
9948         o->op_flags &= ~OPf_STACKED;
9949     }
9950     kid = OP_SIBLING(cLISTOPo->op_first);
9951     if (type == OP_MAPWHILE)
9952         list(kid);
9953     else
9954         scalar(kid);
9955     o = ck_fun(o);
9956     if (PL_parser && PL_parser->error_count)
9957         return o;
9958     kid = OP_SIBLING(cLISTOPo->op_first);
9959     if (kid->op_type != OP_NULL)
9960         Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
9961     kid = kUNOP->op_first;
9962
9963     gwop = S_alloc_LOGOP(aTHX_ type, o, LINKLIST(kid));
9964     kid->op_next = (OP*)gwop;
9965     offset = pad_findmy_pvs("$_", 0);
9966     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
9967         o->op_private = gwop->op_private = 0;
9968         gwop->op_targ = pad_alloc(type, SVs_PADTMP);
9969     }
9970     else {
9971         o->op_private = gwop->op_private = OPpGREP_LEX;
9972         gwop->op_targ = o->op_targ = offset;
9973     }
9974
9975     kid = OP_SIBLING(cLISTOPo->op_first);
9976     for (kid = OP_SIBLING(kid); kid; kid = OP_SIBLING(kid))
9977         op_lvalue(kid, OP_GREPSTART);
9978
9979     return (OP*)gwop;
9980 }
9981
9982 OP *
9983 Perl_ck_index(pTHX_ OP *o)
9984 {
9985     PERL_ARGS_ASSERT_CK_INDEX;
9986
9987     if (o->op_flags & OPf_KIDS) {
9988         OP *kid = OP_SIBLING(cLISTOPo->op_first);       /* get past pushmark */
9989         if (kid)
9990             kid = OP_SIBLING(kid);                      /* get past "big" */
9991         if (kid && kid->op_type == OP_CONST) {
9992             const bool save_taint = TAINT_get;
9993             SV *sv = kSVOP->op_sv;
9994             if ((!SvPOK(sv) || SvNIOKp(sv)) && SvOK(sv) && !SvROK(sv)) {
9995                 sv = newSV(0);
9996                 sv_copypv(sv, kSVOP->op_sv);
9997                 SvREFCNT_dec_NN(kSVOP->op_sv);
9998                 kSVOP->op_sv = sv;
9999             }
10000             if (SvOK(sv)) fbm_compile(sv, 0);
10001             TAINT_set(save_taint);
10002 #ifdef NO_TAINT_SUPPORT
10003             PERL_UNUSED_VAR(save_taint);
10004 #endif
10005         }
10006     }
10007     return ck_fun(o);
10008 }
10009
10010 OP *
10011 Perl_ck_lfun(pTHX_ OP *o)
10012 {
10013     const OPCODE type = o->op_type;
10014
10015     PERL_ARGS_ASSERT_CK_LFUN;
10016
10017     return modkids(ck_fun(o), type);
10018 }
10019
10020 OP *
10021 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
10022 {
10023     PERL_ARGS_ASSERT_CK_DEFINED;
10024
10025     if ((o->op_flags & OPf_KIDS)) {
10026         switch (cUNOPo->op_first->op_type) {
10027         case OP_RV2AV:
10028         case OP_PADAV:
10029             Perl_croak(aTHX_ "Can't use 'defined(@array)'"
10030                              " (Maybe you should just omit the defined()?)");
10031         break;
10032         case OP_RV2HV:
10033         case OP_PADHV:
10034             Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
10035                              " (Maybe you should just omit the defined()?)");
10036             break;
10037         default:
10038             /* no warning */
10039             break;
10040         }
10041     }
10042     return ck_rfun(o);
10043 }
10044
10045 OP *
10046 Perl_ck_readline(pTHX_ OP *o)
10047 {
10048     PERL_ARGS_ASSERT_CK_READLINE;
10049
10050     if (o->op_flags & OPf_KIDS) {
10051          OP *kid = cLISTOPo->op_first;
10052          if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
10053     }
10054     else {
10055         OP * const newop
10056             = newUNOP(OP_READLINE, o->op_flags | OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
10057         op_free(o);
10058         return newop;
10059     }
10060     return o;
10061 }
10062
10063 OP *
10064 Perl_ck_rfun(pTHX_ OP *o)
10065 {
10066     const OPCODE type = o->op_type;
10067
10068     PERL_ARGS_ASSERT_CK_RFUN;
10069
10070     return refkids(ck_fun(o), type);
10071 }
10072
10073 OP *
10074 Perl_ck_listiob(pTHX_ OP *o)
10075 {
10076     OP *kid;
10077
10078     PERL_ARGS_ASSERT_CK_LISTIOB;
10079
10080     kid = cLISTOPo->op_first;
10081     if (!kid) {
10082         o = force_list(o, 1);
10083         kid = cLISTOPo->op_first;
10084     }
10085     if (kid->op_type == OP_PUSHMARK)
10086         kid = OP_SIBLING(kid);
10087     if (kid && o->op_flags & OPf_STACKED)
10088         kid = OP_SIBLING(kid);
10089     else if (kid && !OP_HAS_SIBLING(kid)) {             /* print HANDLE; */
10090         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
10091          && !kid->op_folded) {
10092             o->op_flags |= OPf_STACKED; /* make it a filehandle */
10093             scalar(kid);
10094             /* replace old const op with new OP_RV2GV parent */
10095             kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
10096                                         OP_RV2GV, OPf_REF);
10097             kid = OP_SIBLING(kid);
10098         }
10099     }
10100
10101     if (!kid)
10102         op_append_elem(o->op_type, o, newDEFSVOP());
10103
10104     if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
10105     return listkids(o);
10106 }
10107
10108 OP *
10109 Perl_ck_smartmatch(pTHX_ OP *o)
10110 {
10111     dVAR;
10112     PERL_ARGS_ASSERT_CK_SMARTMATCH;
10113     if (0 == (o->op_flags & OPf_SPECIAL)) {
10114         OP *first  = cBINOPo->op_first;
10115         OP *second = OP_SIBLING(first);
10116
10117         /* Implicitly take a reference to an array or hash */
10118
10119         /* remove the original two siblings, then add back the
10120          * (possibly different) first and second sibs.
10121          */
10122         op_sibling_splice(o, NULL, 1, NULL);
10123         op_sibling_splice(o, NULL, 1, NULL);
10124         first  = ref_array_or_hash(first);
10125         second = ref_array_or_hash(second);
10126         op_sibling_splice(o, NULL, 0, second);
10127         op_sibling_splice(o, NULL, 0, first);
10128
10129         /* Implicitly take a reference to a regular expression */
10130         if (first->op_type == OP_MATCH) {
10131             CHANGE_TYPE(first, OP_QR);
10132         }
10133         if (second->op_type == OP_MATCH) {
10134             CHANGE_TYPE(second, OP_QR);
10135         }
10136     }
10137
10138     return o;
10139 }
10140
10141
10142 static OP *
10143 S_maybe_targlex(pTHX_ OP *o)
10144 {
10145     dVAR;
10146     OP * const kid = cLISTOPo->op_first;
10147     /* has a disposable target? */
10148     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
10149         && !(kid->op_flags & OPf_STACKED)
10150         /* Cannot steal the second time! */
10151         && !(kid->op_private & OPpTARGET_MY)
10152         )
10153     {
10154         OP * const kkid = OP_SIBLING(kid);
10155
10156         /* Can just relocate the target. */
10157         if (kkid && kkid->op_type == OP_PADSV
10158             && (!(kkid->op_private & OPpLVAL_INTRO)
10159                || kkid->op_private & OPpPAD_STATE))
10160         {
10161             kid->op_targ = kkid->op_targ;
10162             kkid->op_targ = 0;
10163             /* Now we do not need PADSV and SASSIGN.
10164              * Detach kid and free the rest. */
10165             op_sibling_splice(o, NULL, 1, NULL);
10166             op_free(o);
10167             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
10168             return kid;
10169         }
10170     }
10171     return o;
10172 }
10173
10174 OP *
10175 Perl_ck_sassign(pTHX_ OP *o)
10176 {
10177     dVAR;
10178     OP * const kid = cLISTOPo->op_first;
10179
10180     PERL_ARGS_ASSERT_CK_SASSIGN;
10181
10182     if (OP_HAS_SIBLING(kid)) {
10183         OP *kkid = OP_SIBLING(kid);
10184         /* For state variable assignment with attributes, kkid is a list op
10185            whose op_last is a padsv. */
10186         if ((kkid->op_type == OP_PADSV ||
10187              (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
10188               (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
10189              )
10190             )
10191                 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
10192                     == (OPpLVAL_INTRO|OPpPAD_STATE)) {
10193             const PADOFFSET target = kkid->op_targ;
10194             OP *const other = newOP(OP_PADSV,
10195                                     kkid->op_flags
10196                                     | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
10197             OP *const first = newOP(OP_NULL, 0);
10198             OP *const nullop =
10199                 newCONDOP(0, first, S_maybe_targlex(aTHX_ o), other);
10200             OP *const condop = first->op_next;
10201
10202             CHANGE_TYPE(condop, OP_ONCE);
10203             other->op_targ = target;
10204
10205             /* Store the initializedness of state vars in a separate
10206                pad entry.  */
10207             condop->op_targ =
10208               pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
10209             /* hijacking PADSTALE for uninitialized state variables */
10210             SvPADSTALE_on(PAD_SVl(condop->op_targ));
10211
10212             return nullop;
10213         }
10214     }
10215     return S_maybe_targlex(aTHX_ o);
10216 }
10217
10218 OP *
10219 Perl_ck_match(pTHX_ OP *o)
10220 {
10221     PERL_ARGS_ASSERT_CK_MATCH;
10222
10223     if (o->op_type != OP_QR && PL_compcv) {
10224         const PADOFFSET offset = pad_findmy_pvs("$_", 0);
10225         if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
10226             o->op_targ = offset;
10227             o->op_private |= OPpTARGET_MY;
10228         }
10229     }
10230     if (o->op_type == OP_MATCH || o->op_type == OP_QR)
10231         o->op_private |= OPpRUNTIME;
10232     return o;
10233 }
10234
10235 OP *
10236 Perl_ck_method(pTHX_ OP *o)
10237 {
10238     SV* sv;
10239     const char* method;
10240     OP * const kid = cUNOPo->op_first;
10241
10242     PERL_ARGS_ASSERT_CK_METHOD;
10243     if (kid->op_type != OP_CONST) return o;
10244
10245     sv = kSVOP->op_sv;
10246     method = SvPVX_const(sv);
10247     if (!(strchr(method, ':') || strchr(method, '\''))) {
10248         OP *cmop;
10249         if (!SvIsCOW_shared_hash(sv)) {
10250             sv = newSVpvn_share(method, SvUTF8(sv) ? -(I32)SvCUR(sv) : (I32)SvCUR(sv), 0);
10251         }
10252         else {
10253             kSVOP->op_sv = NULL;
10254         }
10255         cmop = newMETHOP_named(OP_METHOD_NAMED, 0, sv);
10256         op_free(o);
10257         return cmop;
10258     }
10259     return o;
10260 }
10261
10262 OP *
10263 Perl_ck_null(pTHX_ OP *o)
10264 {
10265     PERL_ARGS_ASSERT_CK_NULL;
10266     PERL_UNUSED_CONTEXT;
10267     return o;
10268 }
10269
10270 OP *
10271 Perl_ck_open(pTHX_ OP *o)
10272 {
10273     PERL_ARGS_ASSERT_CK_OPEN;
10274
10275     S_io_hints(aTHX_ o);
10276     {
10277          /* In case of three-arg dup open remove strictness
10278           * from the last arg if it is a bareword. */
10279          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
10280          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
10281          OP *oa;
10282          const char *mode;
10283
10284          if ((last->op_type == OP_CONST) &&             /* The bareword. */
10285              (last->op_private & OPpCONST_BARE) &&
10286              (last->op_private & OPpCONST_STRICT) &&
10287              (oa = OP_SIBLING(first)) &&                /* The fh. */
10288              (oa = OP_SIBLING(oa)) &&                   /* The mode. */
10289              (oa->op_type == OP_CONST) &&
10290              SvPOK(((SVOP*)oa)->op_sv) &&
10291              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
10292              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
10293              (last == OP_SIBLING(oa)))                  /* The bareword. */
10294               last->op_private &= ~OPpCONST_STRICT;
10295     }
10296     return ck_fun(o);
10297 }
10298
10299 OP *
10300 Perl_ck_refassign(pTHX_ OP *o)
10301 {
10302     OP * const right = cLISTOPo->op_first;
10303     OP * const left = OP_SIBLING(right);
10304     OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
10305     bool stacked = 0;
10306
10307     PERL_ARGS_ASSERT_CK_REFASSIGN;
10308     assert (left);
10309     assert (left->op_type == OP_SREFGEN);
10310
10311     o->op_private = varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE);
10312
10313     switch (varop->op_type) {
10314     case OP_PADAV:
10315         o->op_private |= OPpLVREF_AV;
10316         goto settarg;
10317     case OP_PADHV:
10318         o->op_private |= OPpLVREF_HV;
10319     case OP_PADSV:
10320       settarg:
10321         o->op_targ = varop->op_targ;
10322         varop->op_targ = 0;
10323         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
10324         break;
10325     case OP_RV2AV:
10326         o->op_private |= OPpLVREF_AV;
10327         goto checkgv;
10328     case OP_RV2HV:
10329         o->op_private |= OPpLVREF_HV;
10330     case OP_RV2SV:
10331       checkgv:
10332         if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
10333       detach_and_stack:
10334         /* Point varop to its GV kid, detached.  */
10335         varop = op_sibling_splice(varop, NULL, -1, NULL);
10336         stacked = TRUE;
10337         break;
10338     case OP_RV2CV: {
10339         OP * const kidparent =
10340             cUNOPx(cUNOPx(varop)->op_first)->op_first->op_sibling;
10341         OP * const kid = cUNOPx(kidparent)->op_first;
10342         o->op_private |= OPpLVREF_CV;
10343         if (kid->op_type == OP_GV) {
10344             varop = kidparent;
10345             goto detach_and_stack;
10346         }
10347         if (kid->op_type != OP_PADCV)   goto bad;
10348         o->op_targ = kid->op_targ;
10349         kid->op_targ = 0;
10350         break;
10351     }
10352     case OP_AELEM:
10353     case OP_HELEM:
10354         o->op_private |= OPpLVREF_ELEM;
10355         op_null(varop);
10356         stacked = TRUE;
10357         /* Detach varop.  */
10358         op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
10359         break;
10360     default:
10361       bad:
10362         /* diag_listed_as: Can't modify reference to %s in %s assignment */
10363         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
10364                                 "assignment",
10365                                  OP_DESC(varop)));
10366         return o;
10367     }
10368     if (!FEATURE_REFALIASING_IS_ENABLED)
10369         Perl_croak(aTHX_
10370                   "Experimental aliasing via reference not enabled");
10371     Perl_ck_warner_d(aTHX_
10372                      packWARN(WARN_EXPERIMENTAL__REFALIASING),
10373                     "Aliasing via reference is experimental");
10374     if (stacked) {
10375         o->op_flags |= OPf_STACKED;
10376         op_sibling_splice(o, right, 1, varop);
10377     }
10378     else {
10379         o->op_flags &=~ OPf_STACKED;
10380         op_sibling_splice(o, right, 1, NULL);
10381     }
10382     op_free(left);
10383     return o;
10384 }
10385
10386 OP *
10387 Perl_ck_repeat(pTHX_ OP *o)
10388 {
10389     PERL_ARGS_ASSERT_CK_REPEAT;
10390
10391     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
10392         OP* kids;
10393         o->op_private |= OPpREPEAT_DOLIST;
10394         kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
10395         kids = force_list(kids, 1); /* promote it to a list */
10396         op_sibling_splice(o, NULL, 0, kids); /* and add back */
10397     }
10398     else
10399         scalar(o);
10400     return o;
10401 }
10402
10403 OP *
10404 Perl_ck_require(pTHX_ OP *o)
10405 {
10406     GV* gv;
10407
10408     PERL_ARGS_ASSERT_CK_REQUIRE;
10409
10410     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
10411         SVOP * const kid = (SVOP*)cUNOPo->op_first;
10412         HEK *hek;
10413         U32 hash;
10414         char *s;
10415         STRLEN len;
10416         if (kid->op_type == OP_CONST) {
10417           SV * const sv = kid->op_sv;
10418           U32 const was_readonly = SvREADONLY(sv);
10419           if (kid->op_private & OPpCONST_BARE) {
10420             dVAR;
10421             const char *end;
10422
10423             if (was_readonly) {
10424                     SvREADONLY_off(sv);
10425             }
10426             if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
10427
10428             s = SvPVX(sv);
10429             len = SvCUR(sv);
10430             end = s + len;
10431             for (; s < end; s++) {
10432                 if (*s == ':' && s[1] == ':') {
10433                     *s = '/';
10434                     Move(s+2, s+1, end - s - 1, char);
10435                     --end;
10436                 }
10437             }
10438             SvEND_set(sv, end);
10439             sv_catpvs(sv, ".pm");
10440             PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
10441             hek = share_hek(SvPVX(sv),
10442                             (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
10443                             hash);
10444             sv_sethek(sv, hek);
10445             unshare_hek(hek);
10446             SvFLAGS(sv) |= was_readonly;
10447           }
10448           else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)) {
10449             s = SvPV(sv, len);
10450             if (SvREFCNT(sv) > 1) {
10451                 kid->op_sv = newSVpvn_share(
10452                     s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
10453                 SvREFCNT_dec_NN(sv);
10454             }
10455             else {
10456                 dVAR;
10457                 if (was_readonly) SvREADONLY_off(sv);
10458                 PERL_HASH(hash, s, len);
10459                 hek = share_hek(s,
10460                                 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
10461                                 hash);
10462                 sv_sethek(sv, hek);
10463                 unshare_hek(hek);
10464                 SvFLAGS(sv) |= was_readonly;
10465             }
10466           }
10467         }
10468     }
10469
10470     if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
10471         /* handle override, if any */
10472      && (gv = gv_override("require", 7))) {
10473         OP *kid, *newop;
10474         if (o->op_flags & OPf_KIDS) {
10475             kid = cUNOPo->op_first;
10476             op_sibling_splice(o, NULL, -1, NULL);
10477         }
10478         else {
10479             kid = newDEFSVOP();
10480         }
10481         op_free(o);
10482         newop = S_new_entersubop(aTHX_ gv, kid);
10483         return newop;
10484     }
10485
10486     return scalar(ck_fun(o));
10487 }
10488
10489 OP *
10490 Perl_ck_return(pTHX_ OP *o)
10491 {
10492     OP *kid;
10493
10494     PERL_ARGS_ASSERT_CK_RETURN;
10495
10496     kid = OP_SIBLING(cLISTOPo->op_first);
10497     if (CvLVALUE(PL_compcv)) {
10498         for (; kid; kid = OP_SIBLING(kid))
10499             op_lvalue(kid, OP_LEAVESUBLV);
10500     }
10501
10502     return o;
10503 }
10504
10505 OP *
10506 Perl_ck_select(pTHX_ OP *o)
10507 {
10508     dVAR;
10509     OP* kid;
10510
10511     PERL_ARGS_ASSERT_CK_SELECT;
10512
10513     if (o->op_flags & OPf_KIDS) {
10514         kid = OP_SIBLING(cLISTOPo->op_first);   /* get past pushmark */
10515         if (kid && OP_HAS_SIBLING(kid)) {
10516             CHANGE_TYPE(o, OP_SSELECT);
10517             o = ck_fun(o);
10518             return fold_constants(op_integerize(op_std_init(o)));
10519         }
10520     }
10521     o = ck_fun(o);
10522     kid = OP_SIBLING(cLISTOPo->op_first);    /* get past pushmark */
10523     if (kid && kid->op_type == OP_RV2GV)
10524         kid->op_private &= ~HINT_STRICT_REFS;
10525     return o;
10526 }
10527
10528 OP *
10529 Perl_ck_shift(pTHX_ OP *o)
10530 {
10531     const I32 type = o->op_type;
10532
10533     PERL_ARGS_ASSERT_CK_SHIFT;
10534
10535     if (!(o->op_flags & OPf_KIDS)) {
10536         OP *argop;
10537
10538         if (!CvUNIQUE(PL_compcv)) {
10539             o->op_flags |= OPf_SPECIAL;
10540             return o;
10541         }
10542
10543         argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
10544         op_free(o);
10545         return newUNOP(type, 0, scalar(argop));
10546     }
10547     return scalar(ck_fun(o));
10548 }
10549
10550 OP *
10551 Perl_ck_sort(pTHX_ OP *o)
10552 {
10553     OP *firstkid;
10554     OP *kid;
10555     HV * const hinthv =
10556         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
10557     U8 stacked;
10558
10559     PERL_ARGS_ASSERT_CK_SORT;
10560
10561     if (hinthv) {
10562             SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
10563             if (svp) {
10564                 const I32 sorthints = (I32)SvIV(*svp);
10565                 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
10566                     o->op_private |= OPpSORT_QSORT;
10567                 if ((sorthints & HINT_SORT_STABLE) != 0)
10568                     o->op_private |= OPpSORT_STABLE;
10569             }
10570     }
10571
10572     if (o->op_flags & OPf_STACKED)
10573         simplify_sort(o);
10574     firstkid = OP_SIBLING(cLISTOPo->op_first);          /* get past pushmark */
10575
10576     if ((stacked = o->op_flags & OPf_STACKED)) {        /* may have been cleared */
10577         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
10578
10579         /* if the first arg is a code block, process it and mark sort as
10580          * OPf_SPECIAL */
10581         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
10582             LINKLIST(kid);
10583             if (kid->op_type == OP_LEAVE)
10584                     op_null(kid);                       /* wipe out leave */
10585             /* Prevent execution from escaping out of the sort block. */
10586             kid->op_next = 0;
10587
10588             /* provide scalar context for comparison function/block */
10589             kid = scalar(firstkid);
10590             kid->op_next = kid;
10591             o->op_flags |= OPf_SPECIAL;
10592         }
10593         else if (kid->op_type == OP_CONST
10594               && kid->op_private & OPpCONST_BARE) {
10595             char tmpbuf[256];
10596             STRLEN len;
10597             PADOFFSET off;
10598             const char * const name = SvPV(kSVOP_sv, len);
10599             *tmpbuf = '&';
10600             assert (len < 256);
10601             Copy(name, tmpbuf+1, len, char);
10602             off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv));
10603             if (off != NOT_IN_PAD) {
10604                 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
10605                     SV * const fq =
10606                         newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
10607                     sv_catpvs(fq, "::");
10608                     sv_catsv(fq, kSVOP_sv);
10609                     SvREFCNT_dec_NN(kSVOP_sv);
10610                     kSVOP->op_sv = fq;
10611                 }
10612                 else {
10613                     OP * const padop = newOP(OP_PADCV, 0);
10614                     padop->op_targ = off;
10615                     cUNOPx(firstkid)->op_first = padop;
10616                     op_free(kid);
10617                 }
10618             }
10619         }
10620
10621         firstkid = OP_SIBLING(firstkid);
10622     }
10623
10624     for (kid = firstkid; kid; kid = OP_SIBLING(kid)) {
10625         /* provide list context for arguments */
10626         list(kid);
10627         if (stacked)
10628             op_lvalue(kid, OP_GREPSTART);
10629     }
10630
10631     return o;
10632 }
10633
10634 /* for sort { X } ..., where X is one of
10635  *   $a <=> $b, $b <= $a, $a cmp $b, $b cmp $a
10636  * elide the second child of the sort (the one containing X),
10637  * and set these flags as appropriate
10638         OPpSORT_NUMERIC;
10639         OPpSORT_INTEGER;
10640         OPpSORT_DESCEND;
10641  * Also, check and warn on lexical $a, $b.
10642  */
10643
10644 STATIC void
10645 S_simplify_sort(pTHX_ OP *o)
10646 {
10647     OP *kid = OP_SIBLING(cLISTOPo->op_first);   /* get past pushmark */
10648     OP *k;
10649     int descending;
10650     GV *gv;
10651     const char *gvname;
10652     bool have_scopeop;
10653
10654     PERL_ARGS_ASSERT_SIMPLIFY_SORT;
10655
10656     kid = kUNOP->op_first;                              /* get past null */
10657     if (!(have_scopeop = kid->op_type == OP_SCOPE)
10658      && kid->op_type != OP_LEAVE)
10659         return;
10660     kid = kLISTOP->op_last;                             /* get past scope */
10661     switch(kid->op_type) {
10662         case OP_NCMP:
10663         case OP_I_NCMP:
10664         case OP_SCMP:
10665             if (!have_scopeop) goto padkids;
10666             break;
10667         default:
10668             return;
10669     }
10670     k = kid;                                            /* remember this node*/
10671     if (kBINOP->op_first->op_type != OP_RV2SV
10672      || kBINOP->op_last ->op_type != OP_RV2SV)
10673     {
10674         /*
10675            Warn about my($a) or my($b) in a sort block, *if* $a or $b is
10676            then used in a comparison.  This catches most, but not
10677            all cases.  For instance, it catches
10678                sort { my($a); $a <=> $b }
10679            but not
10680                sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
10681            (although why you'd do that is anyone's guess).
10682         */
10683
10684        padkids:
10685         if (!ckWARN(WARN_SYNTAX)) return;
10686         kid = kBINOP->op_first;
10687         do {
10688             if (kid->op_type == OP_PADSV) {
10689                 SV * const name = PAD_COMPNAME_SV(kid->op_targ);
10690                 if (SvCUR(name) == 2 && *SvPVX(name) == '$'
10691                  && (SvPVX(name)[1] == 'a' || SvPVX(name)[1] == 'b'))
10692                     /* diag_listed_as: "my %s" used in sort comparison */
10693                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10694                                      "\"%s %s\" used in sort comparison",
10695                                       SvPAD_STATE(name) ? "state" : "my",
10696                                       SvPVX(name));
10697             }
10698         } while ((kid = OP_SIBLING(kid)));
10699         return;
10700     }
10701     kid = kBINOP->op_first;                             /* get past cmp */
10702     if (kUNOP->op_first->op_type != OP_GV)
10703         return;
10704     kid = kUNOP->op_first;                              /* get past rv2sv */
10705     gv = kGVOP_gv;
10706     if (GvSTASH(gv) != PL_curstash)
10707         return;
10708     gvname = GvNAME(gv);
10709     if (*gvname == 'a' && gvname[1] == '\0')
10710         descending = 0;
10711     else if (*gvname == 'b' && gvname[1] == '\0')
10712         descending = 1;
10713     else
10714         return;
10715
10716     kid = k;                                            /* back to cmp */
10717     /* already checked above that it is rv2sv */
10718     kid = kBINOP->op_last;                              /* down to 2nd arg */
10719     if (kUNOP->op_first->op_type != OP_GV)
10720         return;
10721     kid = kUNOP->op_first;                              /* get past rv2sv */
10722     gv = kGVOP_gv;
10723     if (GvSTASH(gv) != PL_curstash)
10724         return;
10725     gvname = GvNAME(gv);
10726     if ( descending
10727          ? !(*gvname == 'a' && gvname[1] == '\0')
10728          : !(*gvname == 'b' && gvname[1] == '\0'))
10729         return;
10730     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
10731     if (descending)
10732         o->op_private |= OPpSORT_DESCEND;
10733     if (k->op_type == OP_NCMP)
10734         o->op_private |= OPpSORT_NUMERIC;
10735     if (k->op_type == OP_I_NCMP)
10736         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
10737     kid = OP_SIBLING(cLISTOPo->op_first);
10738     /* cut out and delete old block (second sibling) */
10739     op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
10740     op_free(kid);
10741 }
10742
10743 OP *
10744 Perl_ck_split(pTHX_ OP *o)
10745 {
10746     dVAR;
10747     OP *kid;
10748
10749     PERL_ARGS_ASSERT_CK_SPLIT;
10750
10751     if (o->op_flags & OPf_STACKED)
10752         return no_fh_allowed(o);
10753
10754     kid = cLISTOPo->op_first;
10755     if (kid->op_type != OP_NULL)
10756         Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
10757     /* delete leading NULL node, then add a CONST if no other nodes */
10758     op_sibling_splice(o, NULL, 1,
10759             OP_HAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
10760     op_free(kid);
10761     kid = cLISTOPo->op_first;
10762
10763     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
10764         /* remove kid, and replace with new optree */
10765         op_sibling_splice(o, NULL, 1, NULL);
10766         /* OPf_SPECIAL is used to trigger split " " behavior */
10767         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0, 0);
10768         op_sibling_splice(o, NULL, 0, kid);
10769     }
10770     CHANGE_TYPE(kid, OP_PUSHRE);
10771     scalar(kid);
10772     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
10773       Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
10774                      "Use of /g modifier is meaningless in split");
10775     }
10776
10777     if (!OP_HAS_SIBLING(kid))
10778         op_append_elem(OP_SPLIT, o, newDEFSVOP());
10779
10780     kid = OP_SIBLING(kid);
10781     assert(kid);
10782     scalar(kid);
10783
10784     if (!OP_HAS_SIBLING(kid))
10785     {
10786         op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
10787         o->op_private |= OPpSPLIT_IMPLIM;
10788     }
10789     assert(OP_HAS_SIBLING(kid));
10790
10791     kid = OP_SIBLING(kid);
10792     scalar(kid);
10793
10794     if (OP_HAS_SIBLING(kid))
10795         return too_many_arguments_pv(o,OP_DESC(o), 0);
10796
10797     return o;
10798 }
10799
10800 OP *
10801 Perl_ck_stringify(pTHX_ OP *o)
10802 {
10803     OP * const kid = OP_SIBLING(cUNOPo->op_first);
10804     PERL_ARGS_ASSERT_CK_STRINGIFY;
10805     if (kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
10806      || kid->op_type == OP_LC   || kid->op_type == OP_LCFIRST
10807      || kid->op_type == OP_UC   || kid->op_type == OP_UCFIRST)
10808     {
10809         assert(!OP_HAS_SIBLING(kid));
10810         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
10811         op_free(o);
10812         return kid;
10813     }
10814     return ck_fun(o);
10815 }
10816
10817 OP *
10818 Perl_ck_join(pTHX_ OP *o)
10819 {
10820     OP * const kid = OP_SIBLING(cLISTOPo->op_first);
10821
10822     PERL_ARGS_ASSERT_CK_JOIN;
10823
10824     if (kid && kid->op_type == OP_MATCH) {
10825         if (ckWARN(WARN_SYNTAX)) {
10826             const REGEXP *re = PM_GETRE(kPMOP);
10827             const SV *msg = re
10828                     ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
10829                                             SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
10830                     : newSVpvs_flags( "STRING", SVs_TEMP );
10831             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10832                         "/%"SVf"/ should probably be written as \"%"SVf"\"",
10833                         SVfARG(msg), SVfARG(msg));
10834         }
10835     }
10836     if (kid
10837      && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
10838         || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
10839         || (  kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
10840            && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
10841     {
10842         const OP * const bairn = OP_SIBLING(kid); /* the list */
10843         if (bairn && !OP_HAS_SIBLING(bairn) /* single-item list */
10844          && PL_opargs[bairn->op_type] & OA_RETSCALAR)
10845         {
10846             OP * const ret = op_convert_list(OP_STRINGIFY, 0,
10847                                      op_sibling_splice(o, kid, 1, NULL));
10848             op_free(o);
10849             ret->op_folded = 1;
10850             return ret;
10851         }
10852     }
10853
10854     return ck_fun(o);
10855 }
10856
10857 /*
10858 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
10859
10860 Examines an op, which is expected to identify a subroutine at runtime,
10861 and attempts to determine at compile time which subroutine it identifies.
10862 This is normally used during Perl compilation to determine whether
10863 a prototype can be applied to a function call.  I<cvop> is the op
10864 being considered, normally an C<rv2cv> op.  A pointer to the identified
10865 subroutine is returned, if it could be determined statically, and a null
10866 pointer is returned if it was not possible to determine statically.
10867
10868 Currently, the subroutine can be identified statically if the RV that the
10869 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
10870 A C<gv> op is suitable if the GV's CV slot is populated.  A C<const> op is
10871 suitable if the constant value must be an RV pointing to a CV.  Details of
10872 this process may change in future versions of Perl.  If the C<rv2cv> op
10873 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
10874 the subroutine statically: this flag is used to suppress compile-time
10875 magic on a subroutine call, forcing it to use default runtime behaviour.
10876
10877 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
10878 of a GV reference is modified.  If a GV was examined and its CV slot was
10879 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
10880 If the op is not optimised away, and the CV slot is later populated with
10881 a subroutine having a prototype, that flag eventually triggers the warning
10882 "called too early to check prototype".
10883
10884 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
10885 of returning a pointer to the subroutine it returns a pointer to the
10886 GV giving the most appropriate name for the subroutine in this context.
10887 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
10888 (C<CvANON>) subroutine that is referenced through a GV it will be the
10889 referencing GV.  The resulting C<GV*> is cast to C<CV*> to be returned.
10890 A null pointer is returned as usual if there is no statically-determinable
10891 subroutine.
10892
10893 =cut
10894 */
10895
10896 /* shared by toke.c:yylex */
10897 CV *
10898 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
10899 {
10900     PADNAME *name = PAD_COMPNAME(off);
10901     CV *compcv = PL_compcv;
10902     while (PadnameOUTER(name)) {
10903         assert(PARENT_PAD_INDEX(name));
10904         compcv = CvOUTSIDE(PL_compcv);
10905         name = PadlistNAMESARRAY(CvPADLIST(compcv))
10906                 [off = PARENT_PAD_INDEX(name)];
10907     }
10908     assert(!PadnameIsOUR(name));
10909     if (!PadnameIsSTATE(name) && SvMAGICAL(name)) {
10910         MAGIC * mg = mg_find(name, PERL_MAGIC_proto);
10911         assert(mg);
10912         assert(mg->mg_obj);
10913         return (CV *)mg->mg_obj;
10914     }
10915     return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
10916 }
10917
10918 CV *
10919 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
10920 {
10921     OP *rvop;
10922     CV *cv;
10923     GV *gv;
10924     PERL_ARGS_ASSERT_RV2CV_OP_CV;
10925     if (flags & ~RV2CVOPCV_FLAG_MASK)
10926         Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
10927     if (cvop->op_type != OP_RV2CV)
10928         return NULL;
10929     if (cvop->op_private & OPpENTERSUB_AMPER)
10930         return NULL;
10931     if (!(cvop->op_flags & OPf_KIDS))
10932         return NULL;
10933     rvop = cUNOPx(cvop)->op_first;
10934     switch (rvop->op_type) {
10935         case OP_GV: {
10936             gv = cGVOPx_gv(rvop);
10937             if (!isGV(gv)) {
10938                 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
10939                     cv = MUTABLE_CV(SvRV(gv));
10940                     gv = NULL;
10941                     break;
10942                 }
10943                 if (flags & RV2CVOPCV_RETURN_STUB)
10944                     return (CV *)gv;
10945                 else return NULL;
10946             }
10947             cv = GvCVu(gv);
10948             if (!cv) {
10949                 if (flags & RV2CVOPCV_MARK_EARLY)
10950                     rvop->op_private |= OPpEARLY_CV;
10951                 return NULL;
10952             }
10953         } break;
10954         case OP_CONST: {
10955             SV *rv = cSVOPx_sv(rvop);
10956             if (!SvROK(rv))
10957                 return NULL;
10958             cv = (CV*)SvRV(rv);
10959             gv = NULL;
10960         } break;
10961         case OP_PADCV: {
10962             cv = find_lexical_cv(rvop->op_targ);
10963             gv = NULL;
10964         } break;
10965         default: {
10966             return NULL;
10967         } NOT_REACHED; /* NOTREACHED */
10968     }
10969     if (SvTYPE((SV*)cv) != SVt_PVCV)
10970         return NULL;
10971     if (flags & (RV2CVOPCV_RETURN_NAME_GV|RV2CVOPCV_MAYBE_NAME_GV)) {
10972         if ((!CvANON(cv) || !gv) && !CvLEXICAL(cv)
10973          && ((flags & RV2CVOPCV_RETURN_NAME_GV) || !CvNAMED(cv)))
10974             gv = CvGV(cv);
10975         return (CV*)gv;
10976     } else {
10977         return cv;
10978     }
10979 }
10980
10981 /*
10982 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
10983
10984 Performs the default fixup of the arguments part of an C<entersub>
10985 op tree.  This consists of applying list context to each of the
10986 argument ops.  This is the standard treatment used on a call marked
10987 with C<&>, or a method call, or a call through a subroutine reference,
10988 or any other call where the callee can't be identified at compile time,
10989 or a call where the callee has no prototype.
10990
10991 =cut
10992 */
10993
10994 OP *
10995 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
10996 {
10997     OP *aop;
10998     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
10999     aop = cUNOPx(entersubop)->op_first;
11000     if (!OP_HAS_SIBLING(aop))
11001         aop = cUNOPx(aop)->op_first;
11002     for (aop = OP_SIBLING(aop); OP_HAS_SIBLING(aop); aop = OP_SIBLING(aop)) {
11003         list(aop);
11004         op_lvalue(aop, OP_ENTERSUB);
11005     }
11006     return entersubop;
11007 }
11008
11009 /*
11010 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
11011
11012 Performs the fixup of the arguments part of an C<entersub> op tree
11013 based on a subroutine prototype.  This makes various modifications to
11014 the argument ops, from applying context up to inserting C<refgen> ops,
11015 and checking the number and syntactic types of arguments, as directed by
11016 the prototype.  This is the standard treatment used on a subroutine call,
11017 not marked with C<&>, where the callee can be identified at compile time
11018 and has a prototype.
11019
11020 I<protosv> supplies the subroutine prototype to be applied to the call.
11021 It may be a normal defined scalar, of which the string value will be used.
11022 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11023 that has been cast to C<SV*>) which has a prototype.  The prototype
11024 supplied, in whichever form, does not need to match the actual callee
11025 referenced by the op tree.
11026
11027 If the argument ops disagree with the prototype, for example by having
11028 an unacceptable number of arguments, a valid op tree is returned anyway.
11029 The error is reflected in the parser state, normally resulting in a single
11030 exception at the top level of parsing which covers all the compilation
11031 errors that occurred.  In the error message, the callee is referred to
11032 by the name defined by the I<namegv> parameter.
11033
11034 =cut
11035 */
11036
11037 OP *
11038 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11039 {
11040     STRLEN proto_len;
11041     const char *proto, *proto_end;
11042     OP *aop, *prev, *cvop, *parent;
11043     int optional = 0;
11044     I32 arg = 0;
11045     I32 contextclass = 0;
11046     const char *e = NULL;
11047     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
11048     if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
11049         Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
11050                    "flags=%lx", (unsigned long) SvFLAGS(protosv));
11051     if (SvTYPE(protosv) == SVt_PVCV)
11052          proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
11053     else proto = SvPV(protosv, proto_len);
11054     proto = S_strip_spaces(aTHX_ proto, &proto_len);
11055     proto_end = proto + proto_len;
11056     parent = entersubop;
11057     aop = cUNOPx(entersubop)->op_first;
11058     if (!OP_HAS_SIBLING(aop)) {
11059         parent = aop;
11060         aop = cUNOPx(aop)->op_first;
11061     }
11062     prev = aop;
11063     aop = OP_SIBLING(aop);
11064     for (cvop = aop; OP_HAS_SIBLING(cvop); cvop = OP_SIBLING(cvop)) ;
11065     while (aop != cvop) {
11066         OP* o3 = aop;
11067
11068         if (proto >= proto_end)
11069         {
11070             SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11071             yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf,
11072                                         SVfARG(namesv)), SvUTF8(namesv));
11073             return entersubop;
11074         }
11075
11076         switch (*proto) {
11077             case ';':
11078                 optional = 1;
11079                 proto++;
11080                 continue;
11081             case '_':
11082                 /* _ must be at the end */
11083                 if (proto[1] && !strchr(";@%", proto[1]))
11084                     goto oops;
11085                 /* FALLTHROUGH */
11086             case '$':
11087                 proto++;
11088                 arg++;
11089                 scalar(aop);
11090                 break;
11091             case '%':
11092             case '@':
11093                 list(aop);
11094                 arg++;
11095                 break;
11096             case '&':
11097                 proto++;
11098                 arg++;
11099                 if (o3->op_type != OP_REFGEN && o3->op_type != OP_SREFGEN
11100                  && o3->op_type != OP_UNDEF)
11101                     bad_type_gv(arg,
11102                             arg == 1 ? "block or sub {}" : "sub {}",
11103                             namegv, 0, o3);
11104                 break;
11105             case '*':
11106                 /* '*' allows any scalar type, including bareword */
11107                 proto++;
11108                 arg++;
11109                 if (o3->op_type == OP_RV2GV)
11110                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
11111                 else if (o3->op_type == OP_CONST)
11112                     o3->op_private &= ~OPpCONST_STRICT;
11113                 scalar(aop);
11114                 break;
11115             case '+':
11116                 proto++;
11117                 arg++;
11118                 if (o3->op_type == OP_RV2AV ||
11119                     o3->op_type == OP_PADAV ||
11120                     o3->op_type == OP_RV2HV ||
11121                     o3->op_type == OP_PADHV
11122                 ) {
11123                     goto wrapref;
11124                 }
11125                 scalar(aop);
11126                 break;
11127             case '[': case ']':
11128                 goto oops;
11129
11130             case '\\':
11131                 proto++;
11132                 arg++;
11133             again:
11134                 switch (*proto++) {
11135                     case '[':
11136                         if (contextclass++ == 0) {
11137                             e = strchr(proto, ']');
11138                             if (!e || e == proto)
11139                                 goto oops;
11140                         }
11141                         else
11142                             goto oops;
11143                         goto again;
11144
11145                     case ']':
11146                         if (contextclass) {
11147                             const char *p = proto;
11148                             const char *const end = proto;
11149                             contextclass = 0;
11150                             while (*--p != '[')
11151                                 /* \[$] accepts any scalar lvalue */
11152                                 if (*p == '$'
11153                                  && Perl_op_lvalue_flags(aTHX_
11154                                      scalar(o3),
11155                                      OP_READ, /* not entersub */
11156                                      OP_LVALUE_NO_CROAK
11157                                     )) goto wrapref;
11158                             bad_type_gv(arg, Perl_form(aTHX_ "one of %.*s",
11159                                         (int)(end - p), p),
11160                                     namegv, 0, o3);
11161                         } else
11162                             goto oops;
11163                         break;
11164                     case '*':
11165                         if (o3->op_type == OP_RV2GV)
11166                             goto wrapref;
11167                         if (!contextclass)
11168                             bad_type_gv(arg, "symbol", namegv, 0, o3);
11169                         break;
11170                     case '&':
11171                         if (o3->op_type == OP_ENTERSUB)
11172                             goto wrapref;
11173                         if (!contextclass)
11174                             bad_type_gv(arg, "subroutine entry", namegv, 0,
11175                                     o3);
11176                         break;
11177                     case '$':
11178                         if (o3->op_type == OP_RV2SV ||
11179                                 o3->op_type == OP_PADSV ||
11180                                 o3->op_type == OP_HELEM ||
11181                                 o3->op_type == OP_AELEM)
11182                             goto wrapref;
11183                         if (!contextclass) {
11184                             /* \$ accepts any scalar lvalue */
11185                             if (Perl_op_lvalue_flags(aTHX_
11186                                     scalar(o3),
11187                                     OP_READ,  /* not entersub */
11188                                     OP_LVALUE_NO_CROAK
11189                                )) goto wrapref;
11190                             bad_type_gv(arg, "scalar", namegv, 0, o3);
11191                         }
11192                         break;
11193                     case '@':
11194                         if (o3->op_type == OP_RV2AV ||
11195                                 o3->op_type == OP_PADAV)
11196                             goto wrapref;
11197                         if (!contextclass)
11198                             bad_type_gv(arg, "array", namegv, 0, o3);
11199                         break;
11200                     case '%':
11201                         if (o3->op_type == OP_RV2HV ||
11202                                 o3->op_type == OP_PADHV)
11203                             goto wrapref;
11204                         if (!contextclass)
11205                             bad_type_gv(arg, "hash", namegv, 0, o3);
11206                         break;
11207                     wrapref:
11208                             aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
11209                                                 OP_REFGEN, 0);
11210                         if (contextclass && e) {
11211                             proto = e + 1;
11212                             contextclass = 0;
11213                         }
11214                         break;
11215                     default: goto oops;
11216                 }
11217                 if (contextclass)
11218                     goto again;
11219                 break;
11220             case ' ':
11221                 proto++;
11222                 continue;
11223             default:
11224             oops: {
11225                 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
11226                                   SVfARG(cv_name((CV *)namegv, NULL, 0)),
11227                                   SVfARG(protosv));
11228             }
11229         }
11230
11231         op_lvalue(aop, OP_ENTERSUB);
11232         prev = aop;
11233         aop = OP_SIBLING(aop);
11234     }
11235     if (aop == cvop && *proto == '_') {
11236         /* generate an access to $_ */
11237         op_sibling_splice(parent, prev, 0, newDEFSVOP());
11238     }
11239     if (!optional && proto_end > proto &&
11240         (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
11241     {
11242         SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11243         yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf,
11244                                     SVfARG(namesv)), SvUTF8(namesv));
11245     }
11246     return entersubop;
11247 }
11248
11249 /*
11250 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
11251
11252 Performs the fixup of the arguments part of an C<entersub> op tree either
11253 based on a subroutine prototype or using default list-context processing.
11254 This is the standard treatment used on a subroutine call, not marked
11255 with C<&>, where the callee can be identified at compile time.
11256
11257 I<protosv> supplies the subroutine prototype to be applied to the call,
11258 or indicates that there is no prototype.  It may be a normal scalar,
11259 in which case if it is defined then the string value will be used
11260 as a prototype, and if it is undefined then there is no prototype.
11261 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11262 that has been cast to C<SV*>), of which the prototype will be used if it
11263 has one.  The prototype (or lack thereof) supplied, in whichever form,
11264 does not need to match the actual callee referenced by the op tree.
11265
11266 If the argument ops disagree with the prototype, for example by having
11267 an unacceptable number of arguments, a valid op tree is returned anyway.
11268 The error is reflected in the parser state, normally resulting in a single
11269 exception at the top level of parsing which covers all the compilation
11270 errors that occurred.  In the error message, the callee is referred to
11271 by the name defined by the I<namegv> parameter.
11272
11273 =cut
11274 */
11275
11276 OP *
11277 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
11278         GV *namegv, SV *protosv)
11279 {
11280     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
11281     if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
11282         return ck_entersub_args_proto(entersubop, namegv, protosv);
11283     else
11284         return ck_entersub_args_list(entersubop);
11285 }
11286
11287 OP *
11288 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11289 {
11290     int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
11291     OP *aop = cUNOPx(entersubop)->op_first;
11292
11293     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
11294
11295     if (!opnum) {
11296         OP *cvop;
11297         if (!OP_HAS_SIBLING(aop))
11298             aop = cUNOPx(aop)->op_first;
11299         aop = OP_SIBLING(aop);
11300         for (cvop = aop; OP_SIBLING(cvop); cvop = OP_SIBLING(cvop)) ;
11301         if (aop != cvop)
11302             (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
11303
11304         op_free(entersubop);
11305         switch(GvNAME(namegv)[2]) {
11306         case 'F': return newSVOP(OP_CONST, 0,
11307                                         newSVpv(CopFILE(PL_curcop),0));
11308         case 'L': return newSVOP(
11309                            OP_CONST, 0,
11310                            Perl_newSVpvf(aTHX_
11311                              "%"IVdf, (IV)CopLINE(PL_curcop)
11312                            )
11313                          );
11314         case 'P': return newSVOP(OP_CONST, 0,
11315                                    (PL_curstash
11316                                      ? newSVhek(HvNAME_HEK(PL_curstash))
11317                                      : &PL_sv_undef
11318                                    )
11319                                 );
11320         }
11321         NOT_REACHED;
11322     }
11323     else {
11324         OP *prev, *cvop, *first, *parent;
11325         U32 flags = 0;
11326
11327         parent = entersubop;
11328         if (!OP_HAS_SIBLING(aop)) {
11329             parent = aop;
11330             aop = cUNOPx(aop)->op_first;
11331         }
11332
11333         first = prev = aop;
11334         aop = OP_SIBLING(aop);
11335         /* find last sibling */
11336         for (cvop = aop;
11337              OP_HAS_SIBLING(cvop);
11338              prev = cvop, cvop = OP_SIBLING(cvop))
11339             ;
11340         if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
11341             /* Usually, OPf_SPECIAL on a UNOP means that its arg had no
11342              * parens, but these have their own meaning for that flag: */
11343             && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
11344             && opnum != OP_DELETE && opnum != OP_EXISTS)
11345                 flags |= OPf_SPECIAL;
11346         /* excise cvop from end of sibling chain */
11347         op_sibling_splice(parent, prev, 1, NULL);
11348         op_free(cvop);
11349         if (aop == cvop) aop = NULL;
11350
11351         /* detach remaining siblings from the first sibling, then
11352          * dispose of original optree */
11353
11354         if (aop)
11355             op_sibling_splice(parent, first, -1, NULL);
11356         op_free(entersubop);
11357
11358         if (opnum == OP_ENTEREVAL
11359          && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
11360             flags |= OPpEVAL_BYTES <<8;
11361
11362         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
11363         case OA_UNOP:
11364         case OA_BASEOP_OR_UNOP:
11365         case OA_FILESTATOP:
11366             return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
11367         case OA_BASEOP:
11368             if (aop) {
11369                     (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
11370                 op_free(aop);
11371             }
11372             return opnum == OP_RUNCV
11373                 ? newPVOP(OP_RUNCV,0,NULL)
11374                 : newOP(opnum,0);
11375         default:
11376             return op_convert_list(opnum,0,aop);
11377         }
11378     }
11379     assert(0);
11380     return entersubop;
11381 }
11382
11383 /*
11384 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
11385
11386 Retrieves the function that will be used to fix up a call to I<cv>.
11387 Specifically, the function is applied to an C<entersub> op tree for a
11388 subroutine call, not marked with C<&>, where the callee can be identified
11389 at compile time as I<cv>.
11390
11391 The C-level function pointer is returned in I<*ckfun_p>, and an SV
11392 argument for it is returned in I<*ckobj_p>.  The function is intended
11393 to be called in this manner:
11394
11395     entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
11396
11397 In this call, I<entersubop> is a pointer to the C<entersub> op,
11398 which may be replaced by the check function, and I<namegv> is a GV
11399 supplying the name that should be used by the check function to refer
11400 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11401 It is permitted to apply the check function in non-standard situations,
11402 such as to a call to a different subroutine or to a method call.
11403
11404 By default, the function is
11405 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
11406 and the SV parameter is I<cv> itself.  This implements standard
11407 prototype processing.  It can be changed, for a particular subroutine,
11408 by L</cv_set_call_checker>.
11409
11410 =cut
11411 */
11412
11413 static void
11414 S_cv_get_call_checker(CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p,
11415                       U8 *flagsp)
11416 {
11417     MAGIC *callmg;
11418     callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
11419     if (callmg) {
11420         *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
11421         *ckobj_p = callmg->mg_obj;
11422         if (flagsp) *flagsp = callmg->mg_flags;
11423     } else {
11424         *ckfun_p = Perl_ck_entersub_args_proto_or_list;
11425         *ckobj_p = (SV*)cv;
11426         if (flagsp) *flagsp = 0;
11427     }
11428 }
11429
11430 void
11431 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
11432 {
11433     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
11434     PERL_UNUSED_CONTEXT;
11435     S_cv_get_call_checker(cv, ckfun_p, ckobj_p, NULL);
11436 }
11437
11438 /*
11439 =for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 flags
11440
11441 Sets the function that will be used to fix up a call to I<cv>.
11442 Specifically, the function is applied to an C<entersub> op tree for a
11443 subroutine call, not marked with C<&>, where the callee can be identified
11444 at compile time as I<cv>.
11445
11446 The C-level function pointer is supplied in I<ckfun>, and an SV argument
11447 for it is supplied in I<ckobj>.  The function should be defined like this:
11448
11449     STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
11450
11451 It is intended to be called in this manner:
11452
11453     entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
11454
11455 In this call, I<entersubop> is a pointer to the C<entersub> op,
11456 which may be replaced by the check function, and I<namegv> supplies
11457 the name that should be used by the check function to refer
11458 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11459 It is permitted to apply the check function in non-standard situations,
11460 such as to a call to a different subroutine or to a method call.
11461
11462 I<namegv> may not actually be a GV.  For efficiency, perl may pass a
11463 CV or other SV instead.  Whatever is passed can be used as the first
11464 argument to L</cv_name>.  You can force perl to pass a GV by including
11465 C<CALL_CHECKER_REQUIRE_GV> in the I<flags>.
11466
11467 The current setting for a particular CV can be retrieved by
11468 L</cv_get_call_checker>.
11469
11470 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
11471
11472 The original form of L</cv_set_call_checker_flags>, which passes it the
11473 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.
11474
11475 =cut
11476 */
11477
11478 void
11479 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
11480 {
11481     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
11482     cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
11483 }
11484
11485 void
11486 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
11487                                      SV *ckobj, U32 flags)
11488 {
11489     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
11490     if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
11491         if (SvMAGICAL((SV*)cv))
11492             mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
11493     } else {
11494         MAGIC *callmg;
11495         sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
11496         callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
11497         assert(callmg);
11498         if (callmg->mg_flags & MGf_REFCOUNTED) {
11499             SvREFCNT_dec(callmg->mg_obj);
11500             callmg->mg_flags &= ~MGf_REFCOUNTED;
11501         }
11502         callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
11503         callmg->mg_obj = ckobj;
11504         if (ckobj != (SV*)cv) {
11505             SvREFCNT_inc_simple_void_NN(ckobj);
11506             callmg->mg_flags |= MGf_REFCOUNTED;
11507         }
11508         callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
11509                          | (U8)(flags & MGf_REQUIRE_GV) | MGf_COPY;
11510     }
11511 }
11512
11513 OP *
11514 Perl_ck_subr(pTHX_ OP *o)
11515 {
11516     OP *aop, *cvop;
11517     CV *cv;
11518     GV *namegv;
11519
11520     PERL_ARGS_ASSERT_CK_SUBR;
11521
11522     aop = cUNOPx(o)->op_first;
11523     if (!OP_HAS_SIBLING(aop))
11524         aop = cUNOPx(aop)->op_first;
11525     aop = OP_SIBLING(aop);
11526     for (cvop = aop; OP_HAS_SIBLING(cvop); cvop = OP_SIBLING(cvop)) ;
11527     cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
11528     namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
11529
11530     o->op_private &= ~1;
11531     o->op_private |= OPpENTERSUB_HASTARG;
11532     o->op_private |= (PL_hints & HINT_STRICT_REFS);
11533     if (PERLDB_SUB && PL_curstash != PL_debstash)
11534         o->op_private |= OPpENTERSUB_DB;
11535     if (cvop->op_type == OP_RV2CV) {
11536         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
11537         op_null(cvop);
11538     } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
11539         if (aop->op_type == OP_CONST)
11540             aop->op_private &= ~OPpCONST_STRICT;
11541         else if (aop->op_type == OP_LIST) {
11542             OP * const sib = OP_SIBLING(((UNOP*)aop)->op_first);
11543             if (sib && sib->op_type == OP_CONST)
11544                 sib->op_private &= ~OPpCONST_STRICT;
11545         }
11546     }
11547
11548     if (!cv) {
11549         return ck_entersub_args_list(o);
11550     } else {
11551         Perl_call_checker ckfun;
11552         SV *ckobj;
11553         U8 flags;
11554         S_cv_get_call_checker(cv, &ckfun, &ckobj, &flags);
11555         if (!namegv) {
11556             /* The original call checker API guarantees that a GV will be
11557                be provided with the right name.  So, if the old API was
11558                used (or the REQUIRE_GV flag was passed), we have to reify
11559                the CV’s GV, unless this is an anonymous sub.  This is not
11560                ideal for lexical subs, as its stringification will include
11561                the package.  But it is the best we can do.  */
11562             if (flags & MGf_REQUIRE_GV) {
11563                 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
11564                     namegv = CvGV(cv);
11565             }
11566             else namegv = MUTABLE_GV(cv);
11567             /* After a syntax error in a lexical sub, the cv that
11568                rv2cv_op_cv returns may be a nameless stub. */
11569             if (!namegv) return ck_entersub_args_list(o);
11570
11571         }
11572         return ckfun(aTHX_ o, namegv, ckobj);
11573     }
11574 }
11575
11576 OP *
11577 Perl_ck_svconst(pTHX_ OP *o)
11578 {
11579     SV * const sv = cSVOPo->op_sv;
11580     PERL_ARGS_ASSERT_CK_SVCONST;
11581     PERL_UNUSED_CONTEXT;
11582 #ifdef PERL_OLD_COPY_ON_WRITE
11583     if (SvIsCOW(sv)) sv_force_normal(sv);
11584 #elif defined(PERL_NEW_COPY_ON_WRITE)
11585     /* Since the read-only flag may be used to protect a string buffer, we
11586        cannot do copy-on-write with existing read-only scalars that are not
11587        already copy-on-write scalars.  To allow $_ = "hello" to do COW with
11588        that constant, mark the constant as COWable here, if it is not
11589        already read-only. */
11590     if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
11591         SvIsCOW_on(sv);
11592         CowREFCNT(sv) = 0;
11593 # ifdef PERL_DEBUG_READONLY_COW
11594         sv_buf_to_ro(sv);
11595 # endif
11596     }
11597 #endif
11598     SvREADONLY_on(sv);
11599     return o;
11600 }
11601
11602 OP *
11603 Perl_ck_trunc(pTHX_ OP *o)
11604 {
11605     PERL_ARGS_ASSERT_CK_TRUNC;
11606
11607     if (o->op_flags & OPf_KIDS) {
11608         SVOP *kid = (SVOP*)cUNOPo->op_first;
11609
11610         if (kid->op_type == OP_NULL)
11611             kid = (SVOP*)OP_SIBLING(kid);
11612         if (kid && kid->op_type == OP_CONST &&
11613             (kid->op_private & OPpCONST_BARE) &&
11614             !kid->op_folded)
11615         {
11616             o->op_flags |= OPf_SPECIAL;
11617             kid->op_private &= ~OPpCONST_STRICT;
11618         }
11619     }
11620     return ck_fun(o);
11621 }
11622
11623 OP *
11624 Perl_ck_substr(pTHX_ OP *o)
11625 {
11626     PERL_ARGS_ASSERT_CK_SUBSTR;
11627
11628     o = ck_fun(o);
11629     if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
11630         OP *kid = cLISTOPo->op_first;
11631
11632         if (kid->op_type == OP_NULL)
11633             kid = OP_SIBLING(kid);
11634         if (kid)
11635             kid->op_flags |= OPf_MOD;
11636
11637     }
11638     return o;
11639 }
11640
11641 OP *
11642 Perl_ck_tell(pTHX_ OP *o)
11643 {
11644     PERL_ARGS_ASSERT_CK_TELL;
11645     o = ck_fun(o);
11646     if (o->op_flags & OPf_KIDS) {
11647      OP *kid = cLISTOPo->op_first;
11648      if (kid->op_type == OP_NULL && OP_HAS_SIBLING(kid)) kid = OP_SIBLING(kid);
11649      if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
11650     }
11651     return o;
11652 }
11653
11654 OP *
11655 Perl_ck_each(pTHX_ OP *o)
11656 {
11657     dVAR;
11658     OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
11659     const unsigned orig_type  = o->op_type;
11660     const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
11661                               : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
11662     const unsigned ref_type   = orig_type == OP_EACH ? OP_REACH
11663                               : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
11664
11665     PERL_ARGS_ASSERT_CK_EACH;
11666
11667     if (kid) {
11668         switch (kid->op_type) {
11669             case OP_PADHV:
11670             case OP_RV2HV:
11671                 break;
11672             case OP_PADAV:
11673             case OP_RV2AV:
11674                 CHANGE_TYPE(o, array_type);
11675                 break;
11676             case OP_CONST:
11677                 if (kid->op_private == OPpCONST_BARE
11678                  || !SvROK(cSVOPx_sv(kid))
11679                  || (  SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
11680                     && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV  )
11681                    )
11682                     /* we let ck_fun handle it */
11683                     break;
11684             default:
11685                 CHANGE_TYPE(o, ref_type);
11686                 scalar(kid);
11687         }
11688     }
11689     /* if treating as a reference, defer additional checks to runtime */
11690     if (o->op_type == ref_type) {
11691         /* diag_listed_as: keys on reference is experimental */
11692         Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__AUTODEREF),
11693                               "%s is experimental", PL_op_desc[ref_type]);
11694         return o;
11695     }
11696     return ck_fun(o);
11697 }
11698
11699 OP *
11700 Perl_ck_length(pTHX_ OP *o)
11701 {
11702     PERL_ARGS_ASSERT_CK_LENGTH;
11703
11704     o = ck_fun(o);
11705
11706     if (ckWARN(WARN_SYNTAX)) {
11707         const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
11708
11709         if (kid) {
11710             SV *name = NULL;
11711             const bool hash = kid->op_type == OP_PADHV
11712                            || kid->op_type == OP_RV2HV;
11713             switch (kid->op_type) {
11714                 case OP_PADHV:
11715                 case OP_PADAV:
11716                 case OP_RV2HV:
11717                 case OP_RV2AV:
11718                     name = S_op_varname(aTHX_ kid);
11719                     break;
11720                 default:
11721                     return o;
11722             }
11723             if (name)
11724                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11725                     "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
11726                     ")\"?)",
11727                     SVfARG(name), hash ? "keys " : "", SVfARG(name)
11728                 );
11729             else if (hash)
11730      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
11731                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11732                     "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
11733             else
11734      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
11735                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11736                     "length() used on @array (did you mean \"scalar(@array)\"?)");
11737         }
11738     }
11739
11740     return o;
11741 }
11742
11743 /* Check for in place reverse and sort assignments like "@a = reverse @a"
11744    and modify the optree to make them work inplace */
11745
11746 STATIC void
11747 S_inplace_aassign(pTHX_ OP *o) {
11748
11749     OP *modop, *modop_pushmark;
11750     OP *oright;
11751     OP *oleft, *oleft_pushmark;
11752
11753     PERL_ARGS_ASSERT_INPLACE_AASSIGN;
11754
11755     assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
11756
11757     assert(cUNOPo->op_first->op_type == OP_NULL);
11758     modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
11759     assert(modop_pushmark->op_type == OP_PUSHMARK);
11760     modop = OP_SIBLING(modop_pushmark);
11761
11762     if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
11763         return;
11764
11765     /* no other operation except sort/reverse */
11766     if (OP_HAS_SIBLING(modop))
11767         return;
11768
11769     assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
11770     if (!(oright = OP_SIBLING(cUNOPx(modop)->op_first))) return;
11771
11772     if (modop->op_flags & OPf_STACKED) {
11773         /* skip sort subroutine/block */
11774         assert(oright->op_type == OP_NULL);
11775         oright = OP_SIBLING(oright);
11776     }
11777
11778     assert(OP_SIBLING(cUNOPo->op_first)->op_type == OP_NULL);
11779     oleft_pushmark = cUNOPx(OP_SIBLING(cUNOPo->op_first))->op_first;
11780     assert(oleft_pushmark->op_type == OP_PUSHMARK);
11781     oleft = OP_SIBLING(oleft_pushmark);
11782
11783     /* Check the lhs is an array */
11784     if (!oleft ||
11785         (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
11786         || OP_HAS_SIBLING(oleft)
11787         || (oleft->op_private & OPpLVAL_INTRO)
11788     )
11789         return;
11790
11791     /* Only one thing on the rhs */
11792     if (OP_HAS_SIBLING(oright))
11793         return;
11794
11795     /* check the array is the same on both sides */
11796     if (oleft->op_type == OP_RV2AV) {
11797         if (oright->op_type != OP_RV2AV
11798             || !cUNOPx(oright)->op_first
11799             || cUNOPx(oright)->op_first->op_type != OP_GV
11800             || cUNOPx(oleft )->op_first->op_type != OP_GV
11801             || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
11802                cGVOPx_gv(cUNOPx(oright)->op_first)
11803         )
11804             return;
11805     }
11806     else if (oright->op_type != OP_PADAV
11807         || oright->op_targ != oleft->op_targ
11808     )
11809         return;
11810
11811     /* This actually is an inplace assignment */
11812
11813     modop->op_private |= OPpSORT_INPLACE;
11814
11815     /* transfer MODishness etc from LHS arg to RHS arg */
11816     oright->op_flags = oleft->op_flags;
11817
11818     /* remove the aassign op and the lhs */
11819     op_null(o);
11820     op_null(oleft_pushmark);
11821     if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
11822         op_null(cUNOPx(oleft)->op_first);
11823     op_null(oleft);
11824 }
11825
11826
11827
11828 /* mechanism for deferring recursion in rpeep() */
11829
11830 #define MAX_DEFERRED 4
11831
11832 #define DEFER(o) \
11833   STMT_START { \
11834     if (defer_ix == (MAX_DEFERRED-1)) { \
11835         OP **defer = defer_queue[defer_base]; \
11836         CALL_RPEEP(*defer); \
11837         S_prune_chain_head(defer); \
11838         defer_base = (defer_base + 1) % MAX_DEFERRED; \
11839         defer_ix--; \
11840     } \
11841     defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
11842   } STMT_END
11843
11844 #define IS_AND_OP(o)   (o->op_type == OP_AND)
11845 #define IS_OR_OP(o)    (o->op_type == OP_OR)
11846
11847
11848 /* A peephole optimizer.  We visit the ops in the order they're to execute.
11849  * See the comments at the top of this file for more details about when
11850  * peep() is called */
11851
11852 void
11853 Perl_rpeep(pTHX_ OP *o)
11854 {
11855     dVAR;
11856     OP* oldop = NULL;
11857     OP* oldoldop = NULL;
11858     OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
11859     int defer_base = 0;
11860     int defer_ix = -1;
11861     OP *fop;
11862     OP *sop;
11863
11864     if (!o || o->op_opt)
11865         return;
11866     ENTER;
11867     SAVEOP();
11868     SAVEVPTR(PL_curcop);
11869     for (;; o = o->op_next) {
11870         if (o && o->op_opt)
11871             o = NULL;
11872         if (!o) {
11873             while (defer_ix >= 0) {
11874                 OP **defer =
11875                         defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
11876                 CALL_RPEEP(*defer);
11877                 S_prune_chain_head(defer);
11878             }
11879             break;
11880         }
11881
11882       redo:
11883         /* By default, this op has now been optimised. A couple of cases below
11884            clear this again.  */
11885         o->op_opt = 1;
11886         PL_op = o;
11887
11888
11889         switch (o->op_type) {
11890         case OP_DBSTATE:
11891             PL_curcop = ((COP*)o);              /* for warnings */
11892             break;
11893         case OP_NEXTSTATE:
11894             PL_curcop = ((COP*)o);              /* for warnings */
11895
11896             /* Optimise a "return ..." at the end of a sub to just be "...".
11897              * This saves 2 ops. Before:
11898              * 1  <;> nextstate(main 1 -e:1) v ->2
11899              * 4  <@> return K ->5
11900              * 2    <0> pushmark s ->3
11901              * -    <1> ex-rv2sv sK/1 ->4
11902              * 3      <#> gvsv[*cat] s ->4
11903              *
11904              * After:
11905              * -  <@> return K ->-
11906              * -    <0> pushmark s ->2
11907              * -    <1> ex-rv2sv sK/1 ->-
11908              * 2      <$> gvsv(*cat) s ->3
11909              */
11910             {
11911                 OP *next = o->op_next;
11912                 OP *sibling = OP_SIBLING(o);
11913                 if (   OP_TYPE_IS(next, OP_PUSHMARK)
11914                     && OP_TYPE_IS(sibling, OP_RETURN)
11915                     && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
11916                     && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
11917                        ||OP_TYPE_IS(sibling->op_next->op_next,
11918                                     OP_LEAVESUBLV))
11919                     && cUNOPx(sibling)->op_first == next
11920                     && OP_HAS_SIBLING(next) && OP_SIBLING(next)->op_next
11921                     && next->op_next
11922                 ) {
11923                     /* Look through the PUSHMARK's siblings for one that
11924                      * points to the RETURN */
11925                     OP *top = OP_SIBLING(next);
11926                     while (top && top->op_next) {
11927                         if (top->op_next == sibling) {
11928                             top->op_next = sibling->op_next;
11929                             o->op_next = next->op_next;
11930                             break;
11931                         }
11932                         top = OP_SIBLING(top);
11933                     }
11934                 }
11935             }
11936
11937             /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
11938              *
11939              * This latter form is then suitable for conversion into padrange
11940              * later on. Convert:
11941              *
11942              *   nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
11943              *
11944              * into:
11945              *
11946              *   nextstate1 ->     listop     -> nextstate3
11947              *                 /            \
11948              *         pushmark -> padop1 -> padop2
11949              */
11950             if (o->op_next && (
11951                     o->op_next->op_type == OP_PADSV
11952                  || o->op_next->op_type == OP_PADAV
11953                  || o->op_next->op_type == OP_PADHV
11954                 )
11955                 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
11956                 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
11957                 && o->op_next->op_next->op_next && (
11958                     o->op_next->op_next->op_next->op_type == OP_PADSV
11959                  || o->op_next->op_next->op_next->op_type == OP_PADAV
11960                  || o->op_next->op_next->op_next->op_type == OP_PADHV
11961                 )
11962                 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
11963                 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
11964                 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
11965                 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
11966             ) {
11967                 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
11968
11969                 pad1 =    o->op_next;
11970                 ns2  = pad1->op_next;
11971                 pad2 =  ns2->op_next;
11972                 ns3  = pad2->op_next;
11973
11974                 /* we assume here that the op_next chain is the same as
11975                  * the op_sibling chain */
11976                 assert(OP_SIBLING(o)    == pad1);
11977                 assert(OP_SIBLING(pad1) == ns2);
11978                 assert(OP_SIBLING(ns2)  == pad2);
11979                 assert(OP_SIBLING(pad2) == ns3);
11980
11981                 /* create new listop, with children consisting of:
11982                  * a new pushmark, pad1, pad2. */
11983                 OP_SIBLING_set(pad2, NULL);
11984                 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
11985                 newop->op_flags |= OPf_PARENS;
11986                 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
11987                 newpm = cUNOPx(newop)->op_first; /* pushmark */
11988
11989                 /* Kill nextstate2 between padop1/padop2 */
11990                 op_free(ns2);
11991
11992                 o    ->op_next = newpm;
11993                 newpm->op_next = pad1;
11994                 pad1 ->op_next = pad2;
11995                 pad2 ->op_next = newop; /* listop */
11996                 newop->op_next = ns3;
11997
11998                 OP_SIBLING_set(o, newop);
11999                 OP_SIBLING_set(newop, ns3);
12000                 newop->op_lastsib = 0;
12001
12002                 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
12003
12004                 /* Ensure pushmark has this flag if padops do */
12005                 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
12006                     o->op_next->op_flags |= OPf_MOD;
12007                 }
12008
12009                 break;
12010             }
12011
12012             /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
12013                to carry two labels. For now, take the easier option, and skip
12014                this optimisation if the first NEXTSTATE has a label.  */
12015             if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
12016                 OP *nextop = o->op_next;
12017                 while (nextop && nextop->op_type == OP_NULL)
12018                     nextop = nextop->op_next;
12019
12020                 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
12021                     op_null(o);
12022                     if (oldop)
12023                         oldop->op_next = nextop;
12024                     /* Skip (old)oldop assignment since the current oldop's
12025                        op_next already points to the next op.  */
12026                     continue;
12027                 }
12028             }
12029             break;
12030
12031         case OP_CONCAT:
12032             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
12033                 if (o->op_next->op_private & OPpTARGET_MY) {
12034                     if (o->op_flags & OPf_STACKED) /* chained concats */
12035                         break; /* ignore_optimization */
12036                     else {
12037                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
12038                         o->op_targ = o->op_next->op_targ;
12039                         o->op_next->op_targ = 0;
12040                         o->op_private |= OPpTARGET_MY;
12041                     }
12042                 }
12043                 op_null(o->op_next);
12044             }
12045             break;
12046         case OP_STUB:
12047             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
12048                 break; /* Scalar stub must produce undef.  List stub is noop */
12049             }
12050             goto nothin;
12051         case OP_NULL:
12052             if (o->op_targ == OP_NEXTSTATE
12053                 || o->op_targ == OP_DBSTATE)
12054             {
12055                 PL_curcop = ((COP*)o);
12056             }
12057             /* XXX: We avoid setting op_seq here to prevent later calls
12058                to rpeep() from mistakenly concluding that optimisation
12059                has already occurred. This doesn't fix the real problem,
12060                though (See 20010220.007). AMS 20010719 */
12061             /* op_seq functionality is now replaced by op_opt */
12062             o->op_opt = 0;
12063             /* FALLTHROUGH */
12064         case OP_SCALAR:
12065         case OP_LINESEQ:
12066         case OP_SCOPE:
12067         nothin:
12068             if (oldop) {
12069                 oldop->op_next = o->op_next;
12070                 o->op_opt = 0;
12071                 continue;
12072             }
12073             break;
12074
12075         case OP_PUSHMARK:
12076
12077             /* Given
12078                  5 repeat/DOLIST
12079                  3   ex-list
12080                  1     pushmark
12081                  2     scalar or const
12082                  4   const[0]
12083                convert repeat into a stub with no kids.
12084              */
12085             if (o->op_next->op_type == OP_CONST
12086              || (  o->op_next->op_type == OP_PADSV
12087                 && !(o->op_next->op_private & OPpLVAL_INTRO))
12088              || (  o->op_next->op_type == OP_GV
12089                 && o->op_next->op_next->op_type == OP_RV2SV
12090                 && !(o->op_next->op_next->op_private
12091                         & (OPpLVAL_INTRO|OPpOUR_INTRO))))
12092             {
12093                 const OP *kid = o->op_next->op_next;
12094                 if (o->op_next->op_type == OP_GV)
12095                    kid = kid->op_next;
12096                 /* kid is now the ex-list.  */
12097                 if (kid->op_type == OP_NULL
12098                  && (kid = kid->op_next)->op_type == OP_CONST
12099                     /* kid is now the repeat count.  */
12100                  && kid->op_next->op_type == OP_REPEAT
12101                  && kid->op_next->op_private & OPpREPEAT_DOLIST
12102                  && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
12103                  && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0)
12104                 {
12105                     o = kid->op_next; /* repeat */
12106                     assert(oldop);
12107                     oldop->op_next = o;
12108                     op_free(cBINOPo->op_first);
12109                     op_free(cBINOPo->op_last );
12110                     o->op_flags &=~ OPf_KIDS;
12111                     /* stub is a baseop; repeat is a binop */
12112                     assert(sizeof(OP) <= sizeof(BINOP));
12113                     CHANGE_TYPE(o, OP_STUB);
12114                     o->op_private = 0;
12115                     break;
12116                 }
12117             }
12118
12119             /* Convert a series of PAD ops for my vars plus support into a
12120              * single padrange op. Basically
12121              *
12122              *    pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
12123              *
12124              * becomes, depending on circumstances, one of
12125              *
12126              *    padrange  ----------------------------------> (list) -> rest
12127              *    padrange  --------------------------------------------> rest
12128              *
12129              * where all the pad indexes are sequential and of the same type
12130              * (INTRO or not).
12131              * We convert the pushmark into a padrange op, then skip
12132              * any other pad ops, and possibly some trailing ops.
12133              * Note that we don't null() the skipped ops, to make it
12134              * easier for Deparse to undo this optimisation (and none of
12135              * the skipped ops are holding any resourses). It also makes
12136              * it easier for find_uninit_var(), as it can just ignore
12137              * padrange, and examine the original pad ops.
12138              */
12139         {
12140             OP *p;
12141             OP *followop = NULL; /* the op that will follow the padrange op */
12142             U8 count = 0;
12143             U8 intro = 0;
12144             PADOFFSET base = 0; /* init only to stop compiler whining */
12145             U8 gimme       = 0; /* init only to stop compiler whining */
12146             bool defav = 0;  /* seen (...) = @_ */
12147             bool reuse = 0;  /* reuse an existing padrange op */
12148
12149             /* look for a pushmark -> gv[_] -> rv2av */
12150
12151             {
12152                 OP *rv2av, *q;
12153                 p = o->op_next;
12154                 if (   p->op_type == OP_GV
12155                     && cGVOPx_gv(p) == PL_defgv
12156                     && (rv2av = p->op_next)
12157                     && rv2av->op_type == OP_RV2AV
12158                     && !(rv2av->op_flags & OPf_REF)
12159                     && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
12160                     && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
12161                 ) {
12162                     q = rv2av->op_next;
12163                     if (q->op_type == OP_NULL)
12164                         q = q->op_next;
12165                     if (q->op_type == OP_PUSHMARK) {
12166                         defav = 1;
12167                         p = q;
12168                     }
12169                 }
12170             }
12171             if (!defav) {
12172                 p = o;
12173             }
12174
12175             /* scan for PAD ops */
12176
12177             for (p = p->op_next; p; p = p->op_next) {
12178                 if (p->op_type == OP_NULL)
12179                     continue;
12180
12181                 if ((     p->op_type != OP_PADSV
12182                        && p->op_type != OP_PADAV
12183                        && p->op_type != OP_PADHV
12184                     )
12185                       /* any private flag other than INTRO? e.g. STATE */
12186                    || (p->op_private & ~OPpLVAL_INTRO)
12187                 )
12188                     break;
12189
12190                 /* let $a[N] potentially be optimised into AELEMFAST_LEX
12191                  * instead */
12192                 if (   p->op_type == OP_PADAV
12193                     && p->op_next
12194                     && p->op_next->op_type == OP_CONST
12195                     && p->op_next->op_next
12196                     && p->op_next->op_next->op_type == OP_AELEM
12197                 )
12198                     break;
12199
12200                 /* for 1st padop, note what type it is and the range
12201                  * start; for the others, check that it's the same type
12202                  * and that the targs are contiguous */
12203                 if (count == 0) {
12204                     intro = (p->op_private & OPpLVAL_INTRO);
12205                     base = p->op_targ;
12206                     gimme = (p->op_flags & OPf_WANT);
12207                 }
12208                 else {
12209                     if ((p->op_private & OPpLVAL_INTRO) != intro)
12210                         break;
12211                     /* Note that you'd normally  expect targs to be
12212                      * contiguous in my($a,$b,$c), but that's not the case
12213                      * when external modules start doing things, e.g.
12214                      i* Function::Parameters */
12215                     if (p->op_targ != base + count)
12216                         break;
12217                     assert(p->op_targ == base + count);
12218                     /* all the padops should be in the same context */
12219                     if (gimme != (p->op_flags & OPf_WANT))
12220                         break;
12221                 }
12222
12223                 /* for AV, HV, only when we're not flattening */
12224                 if (   p->op_type != OP_PADSV
12225                     && gimme != OPf_WANT_VOID
12226                     && !(p->op_flags & OPf_REF)
12227                 )
12228                     break;
12229
12230                 if (count >= OPpPADRANGE_COUNTMASK)
12231                     break;
12232
12233                 /* there's a biggest base we can fit into a
12234                  * SAVEt_CLEARPADRANGE in pp_padrange */
12235                 if (intro && base >
12236                         (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)))
12237                     break;
12238
12239                 /* Success! We've got another valid pad op to optimise away */
12240                 count++;
12241                 followop = p->op_next;
12242             }
12243
12244             if (count < 1 || (count == 1 && !defav))
12245                 break;
12246
12247             /* pp_padrange in specifically compile-time void context
12248              * skips pushing a mark and lexicals; in all other contexts
12249              * (including unknown till runtime) it pushes a mark and the
12250              * lexicals. We must be very careful then, that the ops we
12251              * optimise away would have exactly the same effect as the
12252              * padrange.
12253              * In particular in void context, we can only optimise to
12254              * a padrange if see see the complete sequence
12255              *     pushmark, pad*v, ...., list
12256              * which has the net effect of of leaving the markstack as it
12257              * was.  Not pushing on to the stack (whereas padsv does touch
12258              * the stack) makes no difference in void context.
12259              */
12260             assert(followop);
12261             if (gimme == OPf_WANT_VOID) {
12262                 if (followop->op_type == OP_LIST
12263                         && gimme == (followop->op_flags & OPf_WANT)
12264                    )
12265                 {
12266                     followop = followop->op_next; /* skip OP_LIST */
12267
12268                     /* consolidate two successive my(...);'s */
12269
12270                     if (   oldoldop
12271                         && oldoldop->op_type == OP_PADRANGE
12272                         && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
12273                         && (oldoldop->op_private & OPpLVAL_INTRO) == intro
12274                         && !(oldoldop->op_flags & OPf_SPECIAL)
12275                     ) {
12276                         U8 old_count;
12277                         assert(oldoldop->op_next == oldop);
12278                         assert(   oldop->op_type == OP_NEXTSTATE
12279                                || oldop->op_type == OP_DBSTATE);
12280                         assert(oldop->op_next == o);
12281
12282                         old_count
12283                             = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
12284
12285                        /* Do not assume pad offsets for $c and $d are con-
12286                           tiguous in
12287                             my ($a,$b,$c);
12288                             my ($d,$e,$f);
12289                         */
12290                         if (  oldoldop->op_targ + old_count == base
12291                            && old_count < OPpPADRANGE_COUNTMASK - count) {
12292                             base = oldoldop->op_targ;
12293                             count += old_count;
12294                             reuse = 1;
12295                         }
12296                     }
12297
12298                     /* if there's any immediately following singleton
12299                      * my var's; then swallow them and the associated
12300                      * nextstates; i.e.
12301                      *    my ($a,$b); my $c; my $d;
12302                      * is treated as
12303                      *    my ($a,$b,$c,$d);
12304                      */
12305
12306                     while (    ((p = followop->op_next))
12307                             && (  p->op_type == OP_PADSV
12308                                || p->op_type == OP_PADAV
12309                                || p->op_type == OP_PADHV)
12310                             && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
12311                             && (p->op_private & OPpLVAL_INTRO) == intro
12312                             && !(p->op_private & ~OPpLVAL_INTRO)
12313                             && p->op_next
12314                             && (   p->op_next->op_type == OP_NEXTSTATE
12315                                 || p->op_next->op_type == OP_DBSTATE)
12316                             && count < OPpPADRANGE_COUNTMASK
12317                             && base + count == p->op_targ
12318                     ) {
12319                         count++;
12320                         followop = p->op_next;
12321                     }
12322                 }
12323                 else
12324                     break;
12325             }
12326
12327             if (reuse) {
12328                 assert(oldoldop->op_type == OP_PADRANGE);
12329                 oldoldop->op_next = followop;
12330                 oldoldop->op_private = (intro | count);
12331                 o = oldoldop;
12332                 oldop = NULL;
12333                 oldoldop = NULL;
12334             }
12335             else {
12336                 /* Convert the pushmark into a padrange.
12337                  * To make Deparse easier, we guarantee that a padrange was
12338                  * *always* formerly a pushmark */
12339                 assert(o->op_type == OP_PUSHMARK);
12340                 o->op_next = followop;
12341                 CHANGE_TYPE(o, OP_PADRANGE);
12342                 o->op_targ = base;
12343                 /* bit 7: INTRO; bit 6..0: count */
12344                 o->op_private = (intro | count);
12345                 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
12346                                     | gimme | (defav ? OPf_SPECIAL : 0));
12347             }
12348             break;
12349         }
12350
12351         case OP_PADAV:
12352         case OP_PADSV:
12353         case OP_PADHV:
12354         /* Skip over state($x) in void context.  */
12355         if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
12356          && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
12357         {
12358             oldop->op_next = o->op_next;
12359             goto redo_nextstate;
12360         }
12361         if (o->op_type != OP_PADAV)
12362             break;
12363         /* FALLTHROUGH */
12364         case OP_GV:
12365             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
12366                 OP* const pop = (o->op_type == OP_PADAV) ?
12367                             o->op_next : o->op_next->op_next;
12368                 IV i;
12369                 if (pop && pop->op_type == OP_CONST &&
12370                     ((PL_op = pop->op_next)) &&
12371                     pop->op_next->op_type == OP_AELEM &&
12372                     !(pop->op_next->op_private &
12373                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
12374                     (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
12375                 {
12376                     GV *gv;
12377                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
12378                         no_bareword_allowed(pop);
12379                     if (o->op_type == OP_GV)
12380                         op_null(o->op_next);
12381                     op_null(pop->op_next);
12382                     op_null(pop);
12383                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
12384                     o->op_next = pop->op_next->op_next;
12385                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
12386                     o->op_private = (U8)i;
12387                     if (o->op_type == OP_GV) {
12388                         gv = cGVOPo_gv;
12389                         GvAVn(gv);
12390                         o->op_type = OP_AELEMFAST;
12391                     }
12392                     else
12393                         o->op_type = OP_AELEMFAST_LEX;
12394                 }
12395                 if (o->op_type != OP_GV)
12396                     break;
12397             }
12398
12399             /* Remove $foo from the op_next chain in void context.  */
12400             if (oldop
12401              && (  o->op_next->op_type == OP_RV2SV
12402                 || o->op_next->op_type == OP_RV2AV
12403                 || o->op_next->op_type == OP_RV2HV  )
12404              && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
12405              && !(o->op_next->op_private & OPpLVAL_INTRO))
12406             {
12407                 oldop->op_next = o->op_next->op_next;
12408                 /* Reprocess the previous op if it is a nextstate, to
12409                    allow double-nextstate optimisation.  */
12410               redo_nextstate:
12411                 if (oldop->op_type == OP_NEXTSTATE) {
12412                     oldop->op_opt = 0;
12413                     o = oldop;
12414                     oldop = oldoldop;
12415                     oldoldop = NULL;
12416                     goto redo;
12417                 }
12418                 o = oldop;
12419             }
12420             else if (o->op_next->op_type == OP_RV2SV) {
12421                 if (!(o->op_next->op_private & OPpDEREF)) {
12422                     op_null(o->op_next);
12423                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
12424                                                                | OPpOUR_INTRO);
12425                     o->op_next = o->op_next->op_next;
12426                     CHANGE_TYPE(o, OP_GVSV);
12427                 }
12428             }
12429             else if (o->op_next->op_type == OP_READLINE
12430                     && o->op_next->op_next->op_type == OP_CONCAT
12431                     && (o->op_next->op_next->op_flags & OPf_STACKED))
12432             {
12433                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
12434                 CHANGE_TYPE(o, OP_RCATLINE);
12435                 o->op_flags |= OPf_STACKED;
12436                 op_null(o->op_next->op_next);
12437                 op_null(o->op_next);
12438             }
12439
12440             break;
12441
12442 #define HV_OR_SCALARHV(op)                                   \
12443     (  (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \
12444        ? (op)                                                  \
12445        : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \
12446        && (  cUNOPx(op)->op_first->op_type == OP_PADHV          \
12447           || cUNOPx(op)->op_first->op_type == OP_RV2HV)          \
12448          ? cUNOPx(op)->op_first                                   \
12449          : NULL)
12450
12451         case OP_NOT:
12452             if ((fop = HV_OR_SCALARHV(cUNOP->op_first)))
12453                 fop->op_private |= OPpTRUEBOOL;
12454             break;
12455
12456         case OP_AND:
12457         case OP_OR:
12458         case OP_DOR:
12459             fop = cLOGOP->op_first;
12460             sop = OP_SIBLING(fop);
12461             while (cLOGOP->op_other->op_type == OP_NULL)
12462                 cLOGOP->op_other = cLOGOP->op_other->op_next;
12463             while (o->op_next && (   o->op_type == o->op_next->op_type
12464                                   || o->op_next->op_type == OP_NULL))
12465                 o->op_next = o->op_next->op_next;
12466
12467             /* if we're an OR and our next is a AND in void context, we'll
12468                follow it's op_other on short circuit, same for reverse.
12469                We can't do this with OP_DOR since if it's true, its return
12470                value is the underlying value which must be evaluated
12471                by the next op */
12472             if (o->op_next &&
12473                 (
12474                     (IS_AND_OP(o) && IS_OR_OP(o->op_next))
12475                  || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
12476                 )
12477                 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
12478             ) {
12479                 o->op_next = ((LOGOP*)o->op_next)->op_other;
12480             }
12481             DEFER(cLOGOP->op_other);
12482
12483             o->op_opt = 1;
12484             fop = HV_OR_SCALARHV(fop);
12485             if (sop) sop = HV_OR_SCALARHV(sop);
12486             if (fop || sop
12487             ){
12488                 OP * nop = o;
12489                 OP * lop = o;
12490                 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
12491                     while (nop && nop->op_next) {
12492                         switch (nop->op_next->op_type) {
12493                             case OP_NOT:
12494                             case OP_AND:
12495                             case OP_OR:
12496                             case OP_DOR:
12497                                 lop = nop = nop->op_next;
12498                                 break;
12499                             case OP_NULL:
12500                                 nop = nop->op_next;
12501                                 break;
12502                             default:
12503                                 nop = NULL;
12504                                 break;
12505                         }
12506                     }
12507                 }
12508                 if (fop) {
12509                     if (  (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
12510                       || o->op_type == OP_AND  )
12511                         fop->op_private |= OPpTRUEBOOL;
12512                     else if (!(lop->op_flags & OPf_WANT))
12513                         fop->op_private |= OPpMAYBE_TRUEBOOL;
12514                 }
12515                 if (  (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
12516                    && sop)
12517                     sop->op_private |= OPpTRUEBOOL;
12518             }
12519
12520
12521             break;
12522
12523         case OP_COND_EXPR:
12524             if ((fop = HV_OR_SCALARHV(cLOGOP->op_first)))
12525                 fop->op_private |= OPpTRUEBOOL;
12526 #undef HV_OR_SCALARHV
12527             /* GERONIMO! */ /* FALLTHROUGH */
12528
12529         case OP_MAPWHILE:
12530         case OP_GREPWHILE:
12531         case OP_ANDASSIGN:
12532         case OP_ORASSIGN:
12533         case OP_DORASSIGN:
12534         case OP_RANGE:
12535         case OP_ONCE:
12536             while (cLOGOP->op_other->op_type == OP_NULL)
12537                 cLOGOP->op_other = cLOGOP->op_other->op_next;
12538             DEFER(cLOGOP->op_other);
12539             break;
12540
12541         case OP_ENTERLOOP:
12542         case OP_ENTERITER:
12543             while (cLOOP->op_redoop->op_type == OP_NULL)
12544                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
12545             while (cLOOP->op_nextop->op_type == OP_NULL)
12546                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
12547             while (cLOOP->op_lastop->op_type == OP_NULL)
12548                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
12549             /* a while(1) loop doesn't have an op_next that escapes the
12550              * loop, so we have to explicitly follow the op_lastop to
12551              * process the rest of the code */
12552             DEFER(cLOOP->op_lastop);
12553             break;
12554
12555         case OP_ENTERTRY:
12556             assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
12557             DEFER(cLOGOPo->op_other);
12558             break;
12559
12560         case OP_SUBST:
12561             assert(!(cPMOP->op_pmflags & PMf_ONCE));
12562             while (cPMOP->op_pmstashstartu.op_pmreplstart &&
12563                    cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
12564                 cPMOP->op_pmstashstartu.op_pmreplstart
12565                     = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
12566             DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
12567             break;
12568
12569         case OP_SORT: {
12570             OP *oright;
12571
12572             if (o->op_flags & OPf_SPECIAL) {
12573                 /* first arg is a code block */
12574                 OP * const nullop = OP_SIBLING(cLISTOP->op_first);
12575                 OP * kid          = cUNOPx(nullop)->op_first;
12576
12577                 assert(nullop->op_type == OP_NULL);
12578                 assert(kid->op_type == OP_SCOPE
12579                  || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
12580                 /* since OP_SORT doesn't have a handy op_other-style
12581                  * field that can point directly to the start of the code
12582                  * block, store it in the otherwise-unused op_next field
12583                  * of the top-level OP_NULL. This will be quicker at
12584                  * run-time, and it will also allow us to remove leading
12585                  * OP_NULLs by just messing with op_nexts without
12586                  * altering the basic op_first/op_sibling layout. */
12587                 kid = kLISTOP->op_first;
12588                 assert(
12589                       (kid->op_type == OP_NULL
12590                       && (  kid->op_targ == OP_NEXTSTATE
12591                          || kid->op_targ == OP_DBSTATE  ))
12592                     || kid->op_type == OP_STUB
12593                     || kid->op_type == OP_ENTER);
12594                 nullop->op_next = kLISTOP->op_next;
12595                 DEFER(nullop->op_next);
12596             }
12597
12598             /* check that RHS of sort is a single plain array */
12599             oright = cUNOPo->op_first;
12600             if (!oright || oright->op_type != OP_PUSHMARK)
12601                 break;
12602
12603             if (o->op_private & OPpSORT_INPLACE)
12604                 break;
12605
12606             /* reverse sort ... can be optimised.  */
12607             if (!OP_HAS_SIBLING(cUNOPo)) {
12608                 /* Nothing follows us on the list. */
12609                 OP * const reverse = o->op_next;
12610
12611                 if (reverse->op_type == OP_REVERSE &&
12612                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
12613                     OP * const pushmark = cUNOPx(reverse)->op_first;
12614                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
12615                         && (OP_SIBLING(cUNOPx(pushmark)) == o)) {
12616                         /* reverse -> pushmark -> sort */
12617                         o->op_private |= OPpSORT_REVERSE;
12618                         op_null(reverse);
12619                         pushmark->op_next = oright->op_next;
12620                         op_null(oright);
12621                     }
12622                 }
12623             }
12624
12625             break;
12626         }
12627
12628         case OP_REVERSE: {
12629             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
12630             OP *gvop = NULL;
12631             LISTOP *enter, *exlist;
12632
12633             if (o->op_private & OPpSORT_INPLACE)
12634                 break;
12635
12636             enter = (LISTOP *) o->op_next;
12637             if (!enter)
12638                 break;
12639             if (enter->op_type == OP_NULL) {
12640                 enter = (LISTOP *) enter->op_next;
12641                 if (!enter)
12642                     break;
12643             }
12644             /* for $a (...) will have OP_GV then OP_RV2GV here.
12645                for (...) just has an OP_GV.  */
12646             if (enter->op_type == OP_GV) {
12647                 gvop = (OP *) enter;
12648                 enter = (LISTOP *) enter->op_next;
12649                 if (!enter)
12650                     break;
12651                 if (enter->op_type == OP_RV2GV) {
12652                   enter = (LISTOP *) enter->op_next;
12653                   if (!enter)
12654                     break;
12655                 }
12656             }
12657
12658             if (enter->op_type != OP_ENTERITER)
12659                 break;
12660
12661             iter = enter->op_next;
12662             if (!iter || iter->op_type != OP_ITER)
12663                 break;
12664
12665             expushmark = enter->op_first;
12666             if (!expushmark || expushmark->op_type != OP_NULL
12667                 || expushmark->op_targ != OP_PUSHMARK)
12668                 break;
12669
12670             exlist = (LISTOP *) OP_SIBLING(expushmark);
12671             if (!exlist || exlist->op_type != OP_NULL
12672                 || exlist->op_targ != OP_LIST)
12673                 break;
12674
12675             if (exlist->op_last != o) {
12676                 /* Mmm. Was expecting to point back to this op.  */
12677                 break;
12678             }
12679             theirmark = exlist->op_first;
12680             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
12681                 break;
12682
12683             if (OP_SIBLING(theirmark) != o) {
12684                 /* There's something between the mark and the reverse, eg
12685                    for (1, reverse (...))
12686                    so no go.  */
12687                 break;
12688             }
12689
12690             ourmark = ((LISTOP *)o)->op_first;
12691             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
12692                 break;
12693
12694             ourlast = ((LISTOP *)o)->op_last;
12695             if (!ourlast || ourlast->op_next != o)
12696                 break;
12697
12698             rv2av = OP_SIBLING(ourmark);
12699             if (rv2av && rv2av->op_type == OP_RV2AV && !OP_HAS_SIBLING(rv2av)
12700                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
12701                 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
12702                 /* We're just reversing a single array.  */
12703                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
12704                 enter->op_flags |= OPf_STACKED;
12705             }
12706
12707             /* We don't have control over who points to theirmark, so sacrifice
12708                ours.  */
12709             theirmark->op_next = ourmark->op_next;
12710             theirmark->op_flags = ourmark->op_flags;
12711             ourlast->op_next = gvop ? gvop : (OP *) enter;
12712             op_null(ourmark);
12713             op_null(o);
12714             enter->op_private |= OPpITER_REVERSED;
12715             iter->op_private |= OPpITER_REVERSED;
12716
12717             break;
12718         }
12719
12720         case OP_QR:
12721         case OP_MATCH:
12722             if (!(cPMOP->op_pmflags & PMf_ONCE)) {
12723                 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
12724             }
12725             break;
12726
12727         case OP_RUNCV:
12728             if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)) {
12729                 SV *sv;
12730                 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
12731                 else {
12732                     sv = newRV((SV *)PL_compcv);
12733                     sv_rvweaken(sv);
12734                     SvREADONLY_on(sv);
12735                 }
12736                 CHANGE_TYPE(o, OP_CONST);
12737                 o->op_flags |= OPf_SPECIAL;
12738                 cSVOPo->op_sv = sv;
12739             }
12740             break;
12741
12742         case OP_SASSIGN:
12743             if (OP_GIMME(o,0) == G_VOID
12744              || (  o->op_next->op_type == OP_LINESEQ
12745                 && (  o->op_next->op_next->op_type == OP_LEAVESUB
12746                    || (  o->op_next->op_next->op_type == OP_RETURN
12747                       && !CvLVALUE(PL_compcv)))))
12748             {
12749                 OP *right = cBINOP->op_first;
12750                 if (right) {
12751                     /*   sassign
12752                     *      RIGHT
12753                     *      substr
12754                     *         pushmark
12755                     *         arg1
12756                     *         arg2
12757                     *         ...
12758                     * becomes
12759                     *
12760                     *  ex-sassign
12761                     *     substr
12762                     *        pushmark
12763                     *        RIGHT
12764                     *        arg1
12765                     *        arg2
12766                     *        ...
12767                     */
12768                     OP *left = OP_SIBLING(right);
12769                     if (left->op_type == OP_SUBSTR
12770                          && (left->op_private & 7) < 4) {
12771                         op_null(o);
12772                         /* cut out right */
12773                         op_sibling_splice(o, NULL, 1, NULL);
12774                         /* and insert it as second child of OP_SUBSTR */
12775                         op_sibling_splice(left, cBINOPx(left)->op_first, 0,
12776                                     right);
12777                         left->op_private |= OPpSUBSTR_REPL_FIRST;
12778                         left->op_flags =
12779                             (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
12780                     }
12781                 }
12782             }
12783             break;
12784
12785         case OP_AASSIGN:
12786             /* We do the common-vars check here, rather than in newASSIGNOP
12787                (as formerly), so that all lexical vars that get aliased are
12788                marked as such before we do the check.  */
12789             /* There can’t be common vars if the lhs is a stub.  */
12790             if (OP_SIBLING(cLISTOPx(cBINOPo->op_last)->op_first)
12791                     == cLISTOPx(cBINOPo->op_last)->op_last
12792              && cLISTOPx(cBINOPo->op_last)->op_last->op_type == OP_STUB)
12793             {
12794                 o->op_private &=~ OPpASSIGN_COMMON;
12795                 break;
12796             }
12797             if (o->op_private & OPpASSIGN_COMMON) {
12798                  /* See the comment before S_aassign_common_vars concerning
12799                     PL_generation sorcery.  */
12800                 PL_generation++;
12801                 if (!aassign_common_vars(o))
12802                     o->op_private &=~ OPpASSIGN_COMMON;
12803             }
12804             else if (S_aassign_common_vars_aliases_only(aTHX_ o))
12805                 o->op_private |= OPpASSIGN_COMMON;
12806             break;
12807
12808         case OP_CUSTOM: {
12809             Perl_cpeep_t cpeep =
12810                 XopENTRYCUSTOM(o, xop_peep);
12811             if (cpeep)
12812                 cpeep(aTHX_ o, oldop);
12813             break;
12814         }
12815
12816         }
12817         /* did we just null the current op? If so, re-process it to handle
12818          * eliding "empty" ops from the chain */
12819         if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
12820             o->op_opt = 0;
12821             o = oldop;
12822         }
12823         else {
12824             oldoldop = oldop;
12825             oldop = o;
12826         }
12827     }
12828     LEAVE;
12829 }
12830
12831 void
12832 Perl_peep(pTHX_ OP *o)
12833 {
12834     CALL_RPEEP(o);
12835 }
12836
12837 /*
12838 =head1 Custom Operators
12839
12840 =for apidoc Ao||custom_op_xop
12841 Return the XOP structure for a given custom op.  This macro should be
12842 considered internal to OP_NAME and the other access macros: use them instead.
12843 This macro does call a function.  Prior
12844 to 5.19.6, this was implemented as a
12845 function.
12846
12847 =cut
12848 */
12849
12850 XOPRETANY
12851 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
12852 {
12853     SV *keysv;
12854     HE *he = NULL;
12855     XOP *xop;
12856
12857     static const XOP xop_null = { 0, 0, 0, 0, 0 };
12858
12859     PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
12860     assert(o->op_type == OP_CUSTOM);
12861
12862     /* This is wrong. It assumes a function pointer can be cast to IV,
12863      * which isn't guaranteed, but this is what the old custom OP code
12864      * did. In principle it should be safer to Copy the bytes of the
12865      * pointer into a PV: since the new interface is hidden behind
12866      * functions, this can be changed later if necessary.  */
12867     /* Change custom_op_xop if this ever happens */
12868     keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
12869
12870     if (PL_custom_ops)
12871         he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
12872
12873     /* assume noone will have just registered a desc */
12874     if (!he && PL_custom_op_names &&
12875         (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
12876     ) {
12877         const char *pv;
12878         STRLEN l;
12879
12880         /* XXX does all this need to be shared mem? */
12881         Newxz(xop, 1, XOP);
12882         pv = SvPV(HeVAL(he), l);
12883         XopENTRY_set(xop, xop_name, savepvn(pv, l));
12884         if (PL_custom_op_descs &&
12885             (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
12886         ) {
12887             pv = SvPV(HeVAL(he), l);
12888             XopENTRY_set(xop, xop_desc, savepvn(pv, l));
12889         }
12890         Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
12891     }
12892     else {
12893         if (!he)
12894             xop = (XOP *)&xop_null;
12895         else
12896             xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
12897     }
12898     {
12899         XOPRETANY any;
12900         if(field == XOPe_xop_ptr) {
12901             any.xop_ptr = xop;
12902         } else {
12903             const U32 flags = XopFLAGS(xop);
12904             if(flags & field) {
12905                 switch(field) {
12906                 case XOPe_xop_name:
12907                     any.xop_name = xop->xop_name;
12908                     break;
12909                 case XOPe_xop_desc:
12910                     any.xop_desc = xop->xop_desc;
12911                     break;
12912                 case XOPe_xop_class:
12913                     any.xop_class = xop->xop_class;
12914                     break;
12915                 case XOPe_xop_peep:
12916                     any.xop_peep = xop->xop_peep;
12917                     break;
12918                 default:
12919                     NOT_REACHED;
12920                     break;
12921                 }
12922             } else {
12923                 switch(field) {
12924                 case XOPe_xop_name:
12925                     any.xop_name = XOPd_xop_name;
12926                     break;
12927                 case XOPe_xop_desc:
12928                     any.xop_desc = XOPd_xop_desc;
12929                     break;
12930                 case XOPe_xop_class:
12931                     any.xop_class = XOPd_xop_class;
12932                     break;
12933                 case XOPe_xop_peep:
12934                     any.xop_peep = XOPd_xop_peep;
12935                     break;
12936                 default:
12937                     NOT_REACHED;
12938                     break;
12939                 }
12940             }
12941         }
12942         /* Some gcc releases emit a warning for this function:
12943          * op.c: In function 'Perl_custom_op_get_field':
12944          * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
12945          * Whether this is true, is currently unknown. */
12946         return any;
12947     }
12948 }
12949
12950 /*
12951 =for apidoc Ao||custom_op_register
12952 Register a custom op.  See L<perlguts/"Custom Operators">.
12953
12954 =cut
12955 */
12956
12957 void
12958 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
12959 {
12960     SV *keysv;
12961
12962     PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
12963
12964     /* see the comment in custom_op_xop */
12965     keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
12966
12967     if (!PL_custom_ops)
12968         PL_custom_ops = newHV();
12969
12970     if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
12971         Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
12972 }
12973
12974 /*
12975
12976 =for apidoc core_prototype
12977
12978 This function assigns the prototype of the named core function to C<sv>, or
12979 to a new mortal SV if C<sv> is NULL.  It returns the modified C<sv>, or
12980 NULL if the core function has no prototype.  C<code> is a code as returned
12981 by C<keyword()>.  It must not be equal to 0.
12982
12983 =cut
12984 */
12985
12986 SV *
12987 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
12988                           int * const opnum)
12989 {
12990     int i = 0, n = 0, seen_question = 0, defgv = 0;
12991     I32 oa;
12992 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
12993     char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
12994     bool nullret = FALSE;
12995
12996     PERL_ARGS_ASSERT_CORE_PROTOTYPE;
12997
12998     assert (code);
12999
13000     if (!sv) sv = sv_newmortal();
13001
13002 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
13003
13004     switch (code < 0 ? -code : code) {
13005     case KEY_and   : case KEY_chop: case KEY_chomp:
13006     case KEY_cmp   : case KEY_defined: case KEY_delete: case KEY_exec  :
13007     case KEY_exists: case KEY_eq     : case KEY_ge    : case KEY_goto  :
13008     case KEY_grep  : case KEY_gt     : case KEY_last  : case KEY_le    :
13009     case KEY_lt    : case KEY_map    : case KEY_ne    : case KEY_next  :
13010     case KEY_or    : case KEY_print  : case KEY_printf: case KEY_qr    :
13011     case KEY_redo  : case KEY_require: case KEY_return: case KEY_say   :
13012     case KEY_select: case KEY_sort   : case KEY_split : case KEY_system:
13013     case KEY_x     : case KEY_xor    :
13014         if (!opnum) return NULL; nullret = TRUE; goto findopnum;
13015     case KEY_glob:    retsetpvs("_;", OP_GLOB);
13016     case KEY_keys:    retsetpvs("+", OP_KEYS);
13017     case KEY_values:  retsetpvs("+", OP_VALUES);
13018     case KEY_each:    retsetpvs("+", OP_EACH);
13019     case KEY_push:    retsetpvs("+@", OP_PUSH);
13020     case KEY_unshift: retsetpvs("+@", OP_UNSHIFT);
13021     case KEY_pop:     retsetpvs(";+", OP_POP);
13022     case KEY_shift:   retsetpvs(";+", OP_SHIFT);
13023     case KEY_pos:     retsetpvs(";\\[$*]", OP_POS);
13024     case KEY_splice:
13025         retsetpvs("+;$$@", OP_SPLICE);
13026     case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
13027         retsetpvs("", 0);
13028     case KEY_evalbytes:
13029         name = "entereval"; break;
13030     case KEY_readpipe:
13031         name = "backtick";
13032     }
13033
13034 #undef retsetpvs
13035
13036   findopnum:
13037     while (i < MAXO) {  /* The slow way. */
13038         if (strEQ(name, PL_op_name[i])
13039             || strEQ(name, PL_op_desc[i]))
13040         {
13041             if (nullret) { assert(opnum); *opnum = i; return NULL; }
13042             goto found;
13043         }
13044         i++;
13045     }
13046     return NULL;
13047   found:
13048     defgv = PL_opargs[i] & OA_DEFGV;
13049     oa = PL_opargs[i] >> OASHIFT;
13050     while (oa) {
13051         if (oa & OA_OPTIONAL && !seen_question && (
13052               !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
13053         )) {
13054             seen_question = 1;
13055             str[n++] = ';';
13056         }
13057         if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
13058             && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
13059             /* But globs are already references (kinda) */
13060             && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
13061         ) {
13062             str[n++] = '\\';
13063         }
13064         if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
13065          && !scalar_mod_type(NULL, i)) {
13066             str[n++] = '[';
13067             str[n++] = '$';
13068             str[n++] = '@';
13069             str[n++] = '%';
13070             if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
13071             str[n++] = '*';
13072             str[n++] = ']';
13073         }
13074         else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
13075         if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
13076             str[n-1] = '_'; defgv = 0;
13077         }
13078         oa = oa >> 4;
13079     }
13080     if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
13081     str[n++] = '\0';
13082     sv_setpvn(sv, str, n - 1);
13083     if (opnum) *opnum = i;
13084     return sv;
13085 }
13086
13087 OP *
13088 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
13089                       const int opnum)
13090 {
13091     OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
13092     OP *o;
13093
13094     PERL_ARGS_ASSERT_CORESUB_OP;
13095
13096     switch(opnum) {
13097     case 0:
13098         return op_append_elem(OP_LINESEQ,
13099                        argop,
13100                        newSLICEOP(0,
13101                                   newSVOP(OP_CONST, 0, newSViv(-code % 3)),
13102                                   newOP(OP_CALLER,0)
13103                        )
13104                );
13105     case OP_SELECT: /* which represents OP_SSELECT as well */
13106         if (code)
13107             return newCONDOP(
13108                          0,
13109                          newBINOP(OP_GT, 0,
13110                                   newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
13111                                   newSVOP(OP_CONST, 0, newSVuv(1))
13112                                  ),
13113                          coresub_op(newSVuv((UV)OP_SSELECT), 0,
13114                                     OP_SSELECT),
13115                          coresub_op(coreargssv, 0, OP_SELECT)
13116                    );
13117         /* FALLTHROUGH */
13118     default:
13119         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
13120         case OA_BASEOP:
13121             return op_append_elem(
13122                         OP_LINESEQ, argop,
13123                         newOP(opnum,
13124                               opnum == OP_WANTARRAY || opnum == OP_RUNCV
13125                                 ? OPpOFFBYONE << 8 : 0)
13126                    );
13127         case OA_BASEOP_OR_UNOP:
13128             if (opnum == OP_ENTEREVAL) {
13129                 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
13130                 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
13131             }
13132             else o = newUNOP(opnum,0,argop);
13133             if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
13134             else {
13135           onearg:
13136               if (is_handle_constructor(o, 1))
13137                 argop->op_private |= OPpCOREARGS_DEREF1;
13138               if (scalar_mod_type(NULL, opnum))
13139                 argop->op_private |= OPpCOREARGS_SCALARMOD;
13140             }
13141             return o;
13142         default:
13143             o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
13144             if (is_handle_constructor(o, 2))
13145                 argop->op_private |= OPpCOREARGS_DEREF2;
13146             if (opnum == OP_SUBSTR) {
13147                 o->op_private |= OPpMAYBE_LVSUB;
13148                 return o;
13149             }
13150             else goto onearg;
13151         }
13152     }
13153 }
13154
13155 void
13156 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
13157                                SV * const *new_const_svp)
13158 {
13159     const char *hvname;
13160     bool is_const = !!CvCONST(old_cv);
13161     SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
13162
13163     PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
13164
13165     if (is_const && new_const_svp && old_const_sv == *new_const_svp)
13166         return;
13167         /* They are 2 constant subroutines generated from
13168            the same constant. This probably means that
13169            they are really the "same" proxy subroutine
13170            instantiated in 2 places. Most likely this is
13171            when a constant is exported twice.  Don't warn.
13172         */
13173     if (
13174         (ckWARN(WARN_REDEFINE)
13175          && !(
13176                 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
13177              && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
13178              && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
13179                  strEQ(hvname, "autouse"))
13180              )
13181         )
13182      || (is_const
13183          && ckWARN_d(WARN_REDEFINE)
13184          && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
13185         )
13186     )
13187         Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
13188                           is_const
13189                             ? "Constant subroutine %"SVf" redefined"
13190                             : "Subroutine %"SVf" redefined",
13191                           SVfARG(name));
13192 }
13193
13194 /*
13195 =head1 Hook manipulation
13196
13197 These functions provide convenient and thread-safe means of manipulating
13198 hook variables.
13199
13200 =cut
13201 */
13202
13203 /*
13204 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
13205
13206 Puts a C function into the chain of check functions for a specified op
13207 type.  This is the preferred way to manipulate the L</PL_check> array.
13208 I<opcode> specifies which type of op is to be affected.  I<new_checker>
13209 is a pointer to the C function that is to be added to that opcode's
13210 check chain, and I<old_checker_p> points to the storage location where a
13211 pointer to the next function in the chain will be stored.  The value of
13212 I<new_pointer> is written into the L</PL_check> array, while the value
13213 previously stored there is written to I<*old_checker_p>.
13214
13215 The function should be defined like this:
13216
13217     static OP *new_checker(pTHX_ OP *op) { ... }
13218
13219 It is intended to be called in this manner:
13220
13221     new_checker(aTHX_ op)
13222
13223 I<old_checker_p> should be defined like this:
13224
13225     static Perl_check_t old_checker_p;
13226
13227 L</PL_check> is global to an entire process, and a module wishing to
13228 hook op checking may find itself invoked more than once per process,
13229 typically in different threads.  To handle that situation, this function
13230 is idempotent.  The location I<*old_checker_p> must initially (once
13231 per process) contain a null pointer.  A C variable of static duration
13232 (declared at file scope, typically also marked C<static> to give
13233 it internal linkage) will be implicitly initialised appropriately,
13234 if it does not have an explicit initialiser.  This function will only
13235 actually modify the check chain if it finds I<*old_checker_p> to be null.
13236 This function is also thread safe on the small scale.  It uses appropriate
13237 locking to avoid race conditions in accessing L</PL_check>.
13238
13239 When this function is called, the function referenced by I<new_checker>
13240 must be ready to be called, except for I<*old_checker_p> being unfilled.
13241 In a threading situation, I<new_checker> may be called immediately,
13242 even before this function has returned.  I<*old_checker_p> will always
13243 be appropriately set before I<new_checker> is called.  If I<new_checker>
13244 decides not to do anything special with an op that it is given (which
13245 is the usual case for most uses of op check hooking), it must chain the
13246 check function referenced by I<*old_checker_p>.
13247
13248 If you want to influence compilation of calls to a specific subroutine,
13249 then use L</cv_set_call_checker> rather than hooking checking of all
13250 C<entersub> ops.
13251
13252 =cut
13253 */
13254
13255 void
13256 Perl_wrap_op_checker(pTHX_ Optype opcode,
13257     Perl_check_t new_checker, Perl_check_t *old_checker_p)
13258 {
13259     dVAR;
13260
13261     PERL_UNUSED_CONTEXT;
13262     PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
13263     if (*old_checker_p) return;
13264     OP_CHECK_MUTEX_LOCK;
13265     if (!*old_checker_p) {
13266         *old_checker_p = PL_check[opcode];
13267         PL_check[opcode] = new_checker;
13268     }
13269     OP_CHECK_MUTEX_UNLOCK;
13270 }
13271
13272 #include "XSUB.h"
13273
13274 /* Efficient sub that returns a constant scalar value. */
13275 static void
13276 const_sv_xsub(pTHX_ CV* cv)
13277 {
13278     dXSARGS;
13279     SV *const sv = MUTABLE_SV(XSANY.any_ptr);
13280     PERL_UNUSED_ARG(items);
13281     if (!sv) {
13282         XSRETURN(0);
13283     }
13284     EXTEND(sp, 1);
13285     ST(0) = sv;
13286     XSRETURN(1);
13287 }
13288
13289 static void
13290 const_av_xsub(pTHX_ CV* cv)
13291 {
13292     dXSARGS;
13293     AV * const av = MUTABLE_AV(XSANY.any_ptr);
13294     SP -= items;
13295     assert(av);
13296 #ifndef DEBUGGING
13297     if (!av) {
13298         XSRETURN(0);
13299     }
13300 #endif
13301     if (SvRMAGICAL(av))
13302         Perl_croak(aTHX_ "Magical list constants are not supported");
13303     if (GIMME_V != G_ARRAY) {
13304         EXTEND(SP, 1);
13305         ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
13306         XSRETURN(1);
13307     }
13308     EXTEND(SP, AvFILLp(av)+1);
13309     Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
13310     XSRETURN(AvFILLp(av)+1);
13311 }
13312
13313 /*
13314  * Local variables:
13315  * c-indentation-style: bsd
13316  * c-basic-offset: 4
13317  * indent-tabs-mode: nil
13318  * End:
13319  *
13320  * ex: set ts=8 sts=4 sw=4 et:
13321  */