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 #ifdef PERL_OP_PARENT
 301     /* moresib == 0, op_sibling == 0 implies a solitary unattached op */
 302     assert(!o->op_moresib);
 303     assert(!o->op_sibparent);
 304 #endif
 305
 306     return (void *)o;
 307 }
 308
 309 #undef INIT_OPSLOT
 310
 311 #ifdef PERL_DEBUG_READONLY_OPS
 312 void
 313 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
 314 {
 315     PERL_ARGS_ASSERT_SLAB_TO_RO;
 316
 317     if (slab->opslab_readonly) return;
 318     slab->opslab_readonly = 1;
 319     for (; slab; slab = slab->opslab_next) {
 320         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
 321                               (unsigned long) slab->opslab_size, slab));*/
 322         if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
 323             Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
 324                              (unsigned long)slab->opslab_size, errno);
 325     }
 326 }
 327
 328 void
 329 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
 330 {
 331     OPSLAB *slab2;
 332
 333     PERL_ARGS_ASSERT_SLAB_TO_RW;
 334
 335     if (!slab->opslab_readonly) return;
 336     slab2 = slab;
 337     for (; slab2; slab2 = slab2->opslab_next) {
 338         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
 339                               (unsigned long) size, slab2));*/
 340         if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
 341                      PROT_READ|PROT_WRITE)) {
 342             Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
 343                              (unsigned long)slab2->opslab_size, errno);
 344         }
 345     }
 346     slab->opslab_readonly = 0;
 347 }
 348
 349 #else
 350 #  define Slab_to_rw(op)    NOOP
 351 #endif
 352
 353 /* This cannot possibly be right, but it was copied from the old slab
 354    allocator, to which it was originally added, without explanation, in
 355    commit 083fcd5. */
 356 #ifdef NETWARE
 357 #    define PerlMemShared PerlMem
 358 #endif
 359
 360 void
 361 Perl_Slab_Free(pTHX_ void *op)
 362 {
 363     OP * const o = (OP *)op;
 364     OPSLAB *slab;
 365
 366     PERL_ARGS_ASSERT_SLAB_FREE;
 367
 368     if (!o->op_slabbed) {
 369         if (!o->op_static)
 370             PerlMemShared_free(op);
 371         return;
 372     }
 373
 374     slab = OpSLAB(o);
 375     /* If this op is already freed, our refcount will get screwy. */
 376     assert(o->op_type != OP_FREED);
 377     o->op_type = OP_FREED;
 378     o->op_next = slab->opslab_freed;
 379     slab->opslab_freed = o;
 380     DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", (void*)o, (void*)slab));
 381     OpslabREFCNT_dec_padok(slab);
 382 }
 383
 384 void
 385 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
 386 {
 387     const bool havepad = !!PL_comppad;
 388     PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
 389     if (havepad) {
 390         ENTER;
 391         PAD_SAVE_SETNULLPAD();
 392     }
 393     opslab_free(slab);
 394     if (havepad) LEAVE;
 395 }
 396
 397 void
 398 Perl_opslab_free(pTHX_ OPSLAB *slab)
 399 {
 400     OPSLAB *slab2;
 401     PERL_ARGS_ASSERT_OPSLAB_FREE;
 402     PERL_UNUSED_CONTEXT;
 403     DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
 404     assert(slab->opslab_refcnt == 1);
 405     do {
 406         slab2 = slab->opslab_next;
 407 #ifdef DEBUGGING
 408         slab->opslab_refcnt = ~(size_t)0;
 409 #endif
 410 #ifdef PERL_DEBUG_READONLY_OPS
 411         DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
 412                                                (void*)slab));
 413         if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
 414             perror("munmap failed");
 415             abort();
 416         }
 417 #else
 418         PerlMemShared_free(slab);
 419 #endif
 420         slab = slab2;
 421     } while (slab);
 422 }
 423
 424 void
 425 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
 426 {
 427     OPSLAB *slab2;
 428     OPSLOT *slot;
 429 #ifdef DEBUGGING
 430     size_t savestack_count = 0;
 431 #endif
 432     PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
 433     slab2 = slab;
 434     do {
 435         for (slot = slab2->opslab_first;
 436              slot->opslot_next;
 437              slot = slot->opslot_next) {
 438             if (slot->opslot_op.op_type != OP_FREED
 439              && !(slot->opslot_op.op_savefree
 440 #ifdef DEBUGGING
 441                   && ++savestack_count
 442 #endif
 443                  )
 444             ) {
 445                 assert(slot->opslot_op.op_slabbed);
 446                 op_free(&slot->opslot_op);
 447                 if (slab->opslab_refcnt == 1) goto free;
 448             }
 449         }
 450     } while ((slab2 = slab2->opslab_next));
 451     /* > 1 because the CV still holds a reference count. */
 452     if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
 453 #ifdef DEBUGGING
 454         assert(savestack_count == slab->opslab_refcnt-1);
 455 #endif
 456         /* Remove the CV’s reference count. */
 457         slab->opslab_refcnt--;
 458         return;
 459     }
 460    free:
 461     opslab_free(slab);
 462 }
 463
 464 #ifdef PERL_DEBUG_READONLY_OPS
 465 OP *
 466 Perl_op_refcnt_inc(pTHX_ OP *o)
 467 {
 468     if(o) {
 469         OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
 470         if (slab && slab->opslab_readonly) {
 471             Slab_to_rw(slab);
 472             ++o->op_targ;
 473             Slab_to_ro(slab);
 474         } else {
 475             ++o->op_targ;
 476         }
 477     }
 478     return o;
 479
 480 }
 481
 482 PADOFFSET
 483 Perl_op_refcnt_dec(pTHX_ OP *o)
 484 {
 485     PADOFFSET result;
 486     OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
 487
 488     PERL_ARGS_ASSERT_OP_REFCNT_DEC;
 489
 490     if (slab && slab->opslab_readonly) {
 491         Slab_to_rw(slab);
 492         result = --o->op_targ;
 493         Slab_to_ro(slab);
 494     } else {
 495         result = --o->op_targ;
 496     }
 497     return result;
 498 }
 499 #endif
 500 /*
 501  * In the following definition, the ", (OP*)0" is just to make the compiler
 502  * think the expression is of the right type: croak actually does a Siglongjmp.
 503  */
 504 #define CHECKOP(type,o) \
 505     ((PL_op_mask && PL_op_mask[type])                           \
 506      ? ( op_free((OP*)o),                                       \
 507          Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]),  \
 508          (OP*)0 )                                               \
 509      : PL_check[type](aTHX_ (OP*)o))
 510
 511 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
 512
 513 #define OpTYPE_set(o,type) \
 514     STMT_START {                                \
 515         o->op_type = (OPCODE)type;              \
 516         o->op_ppaddr = PL_ppaddr[type];         \
 517     } STMT_END
 518
 519 STATIC OP *
 520 S_no_fh_allowed(pTHX_ OP *o)
 521 {
 522     PERL_ARGS_ASSERT_NO_FH_ALLOWED;
 523
 524     yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
 525                  OP_DESC(o)));
 526     return o;
 527 }
 528
 529 STATIC OP *
 530 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
 531 {
 532     PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
 533     yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
 534     return o;
 535 }
 536
 537 STATIC OP *
 538 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
 539 {
 540     PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
 541
 542     yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
 543     return o;
 544 }
 545
 546 STATIC void
 547 S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid)
 548 {
 549     PERL_ARGS_ASSERT_BAD_TYPE_PV;
 550
 551     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
 552                  (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);
 553 }
 554
 555 /* remove flags var, its unused in all callers, move to to right end since gv
 556   and kid are always the same */
 557 STATIC void
 558 S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)
 559 {
 560     SV * const namesv = cv_name((CV *)gv, NULL, 0);
 561     PERL_ARGS_ASSERT_BAD_TYPE_GV;
 562
 563     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
 564                  (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
 565 }
 566
 567 STATIC void
 568 S_no_bareword_allowed(pTHX_ OP *o)
 569 {
 570     PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
 571
 572     qerror(Perl_mess(aTHX_
 573                      "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
 574                      SVfARG(cSVOPo_sv)));
 575     o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
 576 }
 577
 578 /* "register" allocation */
 579
 580 PADOFFSET
 581 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
 582 {
 583     PADOFFSET off;
 584     const bool is_our = (PL_parser->in_my == KEY_our);
 585
 586     PERL_ARGS_ASSERT_ALLOCMY;
 587
 588     if (flags & ~SVf_UTF8)
 589         Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
 590                    (UV)flags);
 591
 592     /* complain about "my $<special_var>" etc etc */
 593     if (len &&
 594         !(is_our ||
 595           isALPHA(name[1]) ||
 596           ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
 597           (name[1] == '_' && (*name == '$' || len > 2))))
 598     {
 599         if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
 600          && isASCII(name[1])
 601          && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
 602             yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
 603                               name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
 604                               PL_parser->in_my == KEY_state ? "state" : "my"));
 605         } else {
 606             yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
 607                               PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
 608         }
 609     }
 610     else if (len == 2 && name[1] == '_' && !is_our)
 611         /* diag_listed_as: Use of my $_ is experimental */
 612         Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__LEXICAL_TOPIC),
 613                               "Use of %s $_ is experimental",
 614                                PL_parser->in_my == KEY_state
 615                                  ? "state"
 616                                  : "my");
 617
 618     /* allocate a spare slot and store the name in that slot */
 619
 620     off = pad_add_name_pvn(name, len,
 621                        (is_our ? padadd_OUR :
 622                         PL_parser->in_my == KEY_state ? padadd_STATE : 0),
 623                     PL_parser->in_my_stash,
 624                     (is_our
 625                         /* $_ is always in main::, even with our */
 626                         ? (PL_curstash && !memEQs(name,len,"$_")
 627                             ? PL_curstash
 628                             : PL_defstash)
 629                         : NULL
 630                     )
 631     );
 632     /* anon sub prototypes contains state vars should always be cloned,
 633      * otherwise the state var would be shared between anon subs */
 634
 635     if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
 636         CvCLONE_on(PL_compcv);
 637
 638     return off;
 639 }
 640
 641 /*
 642 =head1 Optree Manipulation Functions
 643
 644 =for apidoc alloccopstash
 645
 646 Available only under threaded builds, this function allocates an entry in
 647 C<PL_stashpad> for the stash passed to it.
 648
 649 =cut
 650 */
 651
 652 #ifdef USE_ITHREADS
 653 PADOFFSET
 654 Perl_alloccopstash(pTHX_ HV *hv)
 655 {
 656     PADOFFSET off = 0, o = 1;
 657     bool found_slot = FALSE;
 658
 659     PERL_ARGS_ASSERT_ALLOCCOPSTASH;
 660
 661     if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
 662
 663     for (; o < PL_stashpadmax; ++o) {
 664         if (PL_stashpad[o] == hv) return PL_stashpadix = o;
 665         if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
 666             found_slot = TRUE, off = o;
 667     }
 668     if (!found_slot) {
 669         Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
 670         Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
 671         off = PL_stashpadmax;
 672         PL_stashpadmax += 10;
 673     }
 674
 675     PL_stashpad[PL_stashpadix = off] = hv;
 676     return off;
 677 }
 678 #endif
 679
 680 /* free the body of an op without examining its contents.
 681  * Always use this rather than FreeOp directly */
 682
 683 static void
 684 S_op_destroy(pTHX_ OP *o)
 685 {
 686     FreeOp(o);
 687 }
 688
 689 /* Destructor */
 690
 691 /*
 692 =for apidoc Am|void|op_free|OP *o
 693
 694 Free an op.  Only use this when an op is no longer linked to from any
 695 optree.
 696
 697 =cut
 698 */
 699
 700 void
 701 Perl_op_free(pTHX_ OP *o)
 702 {
 703     dVAR;
 704     OPCODE type;
 705     SSize_t defer_ix = -1;
 706     SSize_t defer_stack_alloc = 0;
 707     OP **defer_stack = NULL;
 708
 709     do {
 710
 711         /* Though ops may be freed twice, freeing the op after its slab is a
 712            big no-no. */
 713         assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
 714         /* During the forced freeing of ops after compilation failure, kidops
 715            may be freed before their parents. */
 716         if (!o || o->op_type == OP_FREED)
 717             continue;
 718
 719         type = o->op_type;
 720
 721         /* an op should only ever acquire op_private flags that we know about.
 722          * If this fails, you may need to fix something in regen/op_private */
 723         if (o->op_ppaddr == PL_ppaddr[o->op_type]) {
 724             assert(!(o->op_private & ~PL_op_private_valid[type]));
 725         }
 726
 727         if (o->op_private & OPpREFCOUNTED) {
 728             switch (type) {
 729             case OP_LEAVESUB:
 730             case OP_LEAVESUBLV:
 731             case OP_LEAVEEVAL:
 732             case OP_LEAVE:
 733             case OP_SCOPE:
 734             case OP_LEAVEWRITE:
 735                 {
 736                 PADOFFSET refcnt;
 737                 OP_REFCNT_LOCK;
 738                 refcnt = OpREFCNT_dec(o);
 739                 OP_REFCNT_UNLOCK;
 740                 if (refcnt) {
 741                     /* Need to find and remove any pattern match ops from the list
 742                        we maintain for reset().  */
 743                     find_and_forget_pmops(o);
 744                     continue;
 745                 }
 746                 }
 747                 break;
 748             default:
 749                 break;
 750             }
 751         }
 752
 753         /* Call the op_free hook if it has been set. Do it now so that it's called
 754          * at the right time for refcounted ops, but still before all of the kids
 755          * are freed. */
 756         CALL_OPFREEHOOK(o);
 757
 758         if (o->op_flags & OPf_KIDS) {
 759             OP *kid, *nextkid;
 760             for (kid = cUNOPo->op_first; kid; kid = nextkid) {
 761                 nextkid = OpSIBLING(kid); /* Get before next freeing kid */
 762                 if (!kid || kid->op_type == OP_FREED)
 763                     /* During the forced freeing of ops after
 764                        compilation failure, kidops may be freed before
 765                        their parents. */
 766                     continue;
 767                 if (!(kid->op_flags & OPf_KIDS))
 768                     /* If it has no kids, just free it now */
 769                     op_free(kid);
 770                 else
 771                     DEFER_OP(kid);
 772             }
 773         }
 774         if (type == OP_NULL)
 775             type = (OPCODE)o->op_targ;
 776
 777         if (o->op_slabbed)
 778             Slab_to_rw(OpSLAB(o));
 779
 780         /* COP* is not cleared by op_clear() so that we may track line
 781          * numbers etc even after null() */
 782         if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
 783             cop_free((COP*)o);
 784         }
 785
 786         op_clear(o);
 787         FreeOp(o);
 788 #ifdef DEBUG_LEAKING_SCALARS
 789         if (PL_op == o)
 790             PL_op = NULL;
 791 #endif
 792     } while ( (o = POP_DEFERRED_OP()) );
 793
 794     Safefree(defer_stack);
 795 }
 796
 797 /* S_op_clear_gv(): free a GV attached to an OP */
 798
 799 #ifdef USE_ITHREADS
 800 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
 801 #else
 802 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
 803 #endif
 804 {
 805
 806     GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
 807             || o->op_type == OP_MULTIDEREF)
 808 #ifdef USE_ITHREADS
 809                 && PL_curpad
 810                 ? ((GV*)PAD_SVl(*ixp)) : NULL;
 811 #else
 812                 ? (GV*)(*svp) : NULL;
 813 #endif
 814     /* It's possible during global destruction that the GV is freed
 815        before the optree. Whilst the SvREFCNT_inc is happy to bump from
 816        0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
 817        will trigger an assertion failure, because the entry to sv_clear
 818        checks that the scalar is not already freed.  A check of for
 819        !SvIS_FREED(gv) turns out to be invalid, because during global
 820        destruction the reference count can be forced down to zero
 821        (with SVf_BREAK set).  In which case raising to 1 and then
 822        dropping to 0 triggers cleanup before it should happen.  I
 823        *think* that this might actually be a general, systematic,
 824        weakness of the whole idea of SVf_BREAK, in that code *is*
 825        allowed to raise and lower references during global destruction,
 826        so any *valid* code that happens to do this during global
 827        destruction might well trigger premature cleanup.  */
 828     bool still_valid = gv && SvREFCNT(gv);
 829
 830     if (still_valid)
 831         SvREFCNT_inc_simple_void(gv);
 832 #ifdef USE_ITHREADS
 833     if (*ixp > 0) {
 834         pad_swipe(*ixp, TRUE);
 835         *ixp = 0;
 836     }
 837 #else
 838     SvREFCNT_dec(*svp);
 839     *svp = NULL;
 840 #endif
 841     if (still_valid) {
 842         int try_downgrade = SvREFCNT(gv) == 2;
 843         SvREFCNT_dec_NN(gv);
 844         if (try_downgrade)
 845             gv_try_downgrade(gv);
 846     }
 847 }
 848
 849
 850 void
 851 Perl_op_clear(pTHX_ OP *o)
 852 {
 853
 854     dVAR;
 855
 856     PERL_ARGS_ASSERT_OP_CLEAR;
 857
 858     switch (o->op_type) {
 859     case OP_NULL:       /* Was holding old type, if any. */
 860         /* FALLTHROUGH */
 861     case OP_ENTERTRY:
 862     case OP_ENTEREVAL:  /* Was holding hints. */
 863         o->op_targ = 0;
 864         break;
 865     default:
 866         if (!(o->op_flags & OPf_REF)
 867             || (PL_check[o->op_type] != Perl_ck_ftst))
 868             break;
 869         /* FALLTHROUGH */
 870     case OP_GVSV:
 871     case OP_GV:
 872     case OP_AELEMFAST:
 873 #ifdef USE_ITHREADS
 874             S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
 875 #else
 876             S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
 877 #endif
 878         break;
 879     case OP_METHOD_REDIR:
 880     case OP_METHOD_REDIR_SUPER:
 881 #ifdef USE_ITHREADS
 882         if (cMETHOPx(o)->op_rclass_targ) {
 883             pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
 884             cMETHOPx(o)->op_rclass_targ = 0;
 885         }
 886 #else
 887         SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
 888         cMETHOPx(o)->op_rclass_sv = NULL;
 889 #endif
 890     case OP_METHOD_NAMED:
 891     case OP_METHOD_SUPER:
 892         SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
 893         cMETHOPx(o)->op_u.op_meth_sv = NULL;
 894 #ifdef USE_ITHREADS
 895         if (o->op_targ) {
 896             pad_swipe(o->op_targ, 1);
 897             o->op_targ = 0;
 898         }
 899 #endif
 900         break;
 901     case OP_CONST:
 902     case OP_HINTSEVAL:
 903         SvREFCNT_dec(cSVOPo->op_sv);
 904         cSVOPo->op_sv = NULL;
 905 #ifdef USE_ITHREADS
 906         /** Bug #15654
 907           Even if op_clear does a pad_free for the target of the op,
 908           pad_free doesn't actually remove the sv that exists in the pad;
 909           instead it lives on. This results in that it could be reused as
 910           a target later on when the pad was reallocated.
 911         **/
 912         if(o->op_targ) {
 913           pad_swipe(o->op_targ,1);
 914           o->op_targ = 0;
 915         }
 916 #endif
 917         break;
 918     case OP_DUMP:
 919     case OP_GOTO:
 920     case OP_NEXT:
 921     case OP_LAST:
 922     case OP_REDO:
 923         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
 924             break;
 925         /* FALLTHROUGH */
 926     case OP_TRANS:
 927     case OP_TRANSR:
 928         if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
 929             assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
 930 #ifdef USE_ITHREADS
 931             if (cPADOPo->op_padix > 0) {
 932                 pad_swipe(cPADOPo->op_padix, TRUE);
 933                 cPADOPo->op_padix = 0;
 934             }
 935 #else
 936             SvREFCNT_dec(cSVOPo->op_sv);
 937             cSVOPo->op_sv = NULL;
 938 #endif
 939         }
 940         else {
 941             PerlMemShared_free(cPVOPo->op_pv);
 942             cPVOPo->op_pv = NULL;
 943         }
 944         break;
 945     case OP_SUBST:
 946         op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
 947         goto clear_pmop;
 948     case OP_PUSHRE:
 949 #ifdef USE_ITHREADS
 950         if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
 951             pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
 952         }
 953 #else
 954         SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
 955 #endif
 956         /* FALLTHROUGH */
 957     case OP_MATCH:
 958     case OP_QR:
 959     clear_pmop:
 960         if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
 961             op_free(cPMOPo->op_code_list);
 962         cPMOPo->op_code_list = NULL;
 963         forget_pmop(cPMOPo);
 964         cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
 965         /* we use the same protection as the "SAFE" version of the PM_ macros
 966          * here since sv_clean_all might release some PMOPs
 967          * after PL_regex_padav has been cleared
 968          * and the clearing of PL_regex_padav needs to
 969          * happen before sv_clean_all
 970          */
 971 #ifdef USE_ITHREADS
 972         if(PL_regex_pad) {        /* We could be in destruction */
 973             const IV offset = (cPMOPo)->op_pmoffset;
 974             ReREFCNT_dec(PM_GETRE(cPMOPo));
 975             PL_regex_pad[offset] = &PL_sv_undef;
 976             sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
 977                            sizeof(offset));
 978         }
 979 #else
 980         ReREFCNT_dec(PM_GETRE(cPMOPo));
 981         PM_SETRE(cPMOPo, NULL);
 982 #endif
 983
 984         break;
 985
 986     case OP_MULTIDEREF:
 987         {
 988             UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
 989             UV actions = items->uv;
 990             bool last = 0;
 991             bool is_hash = FALSE;
 992
 993             while (!last) {
 994                 switch (actions & MDEREF_ACTION_MASK) {
 995
 996                 case MDEREF_reload:
 997                     actions = (++items)->uv;
 998                     continue;
 999
1000                 case MDEREF_HV_padhv_helem:
1001                     is_hash = TRUE;
1002                 case MDEREF_AV_padav_aelem:
1003                     pad_free((++items)->pad_offset);
1004                     goto do_elem;
1005
1006                 case MDEREF_HV_gvhv_helem:
1007                     is_hash = TRUE;
1008                 case MDEREF_AV_gvav_aelem:
1009 #ifdef USE_ITHREADS
1010                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1011 #else
1012                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1013 #endif
1014                     goto do_elem;
1015
1016                 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1017                     is_hash = TRUE;
1018                 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1019 #ifdef USE_ITHREADS
1020                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1021 #else
1022                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1023 #endif
1024                     goto do_vivify_rv2xv_elem;
1025
1026                 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1027                     is_hash = TRUE;
1028                 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1029                     pad_free((++items)->pad_offset);
1030                     goto do_vivify_rv2xv_elem;
1031
1032                 case MDEREF_HV_pop_rv2hv_helem:
1033                 case MDEREF_HV_vivify_rv2hv_helem:
1034                     is_hash = TRUE;
1035                 do_vivify_rv2xv_elem:
1036                 case MDEREF_AV_pop_rv2av_aelem:
1037                 case MDEREF_AV_vivify_rv2av_aelem:
1038                 do_elem:
1039                     switch (actions & MDEREF_INDEX_MASK) {
1040                     case MDEREF_INDEX_none:
1041                         last = 1;
1042                         break;
1043                     case MDEREF_INDEX_const:
1044                         if (is_hash) {
1045 #ifdef USE_ITHREADS
1046                             /* see RT #15654 */
1047                             pad_swipe((++items)->pad_offset, 1);
1048 #else
1049                             SvREFCNT_dec((++items)->sv);
1050 #endif
1051                         }
1052                         else
1053                             items++;
1054                         break;
1055                     case MDEREF_INDEX_padsv:
1056                         pad_free((++items)->pad_offset);
1057                         break;
1058                     case MDEREF_INDEX_gvsv:
1059 #ifdef USE_ITHREADS
1060                         S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1061 #else
1062                         S_op_clear_gv(aTHX_ o, &((++items)->sv));
1063 #endif
1064                         break;
1065                     }
1066
1067                     if (actions & MDEREF_FLAG_last)
1068                         last = 1;
1069                     is_hash = FALSE;
1070
1071                     break;
1072
1073                 default:
1074                     assert(0);
1075                     last = 1;
1076                     break;
1077
1078                 } /* switch */
1079
1080                 actions >>= MDEREF_SHIFT;
1081             } /* while */
1082
1083             /* start of malloc is at op_aux[-1], where the length is
1084              * stored */
1085             PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1086         }
1087         break;
1088     }
1089
1090     if (o->op_targ > 0) {
1091         pad_free(o->op_targ);
1092         o->op_targ = 0;
1093     }
1094 }
1095
1096 STATIC void
1097 S_cop_free(pTHX_ COP* cop)
1098 {
1099     PERL_ARGS_ASSERT_COP_FREE;
1100
1101     CopFILE_free(cop);
1102     if (! specialWARN(cop->cop_warnings))
1103         PerlMemShared_free(cop->cop_warnings);
1104     cophh_free(CopHINTHASH_get(cop));
1105     if (PL_curcop == cop)
1106        PL_curcop = NULL;
1107 }
1108
1109 STATIC void
1110 S_forget_pmop(pTHX_ PMOP *const o
1111               )
1112 {
1113     HV * const pmstash = PmopSTASH(o);
1114
1115     PERL_ARGS_ASSERT_FORGET_PMOP;
1116
1117     if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1118         MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1119         if (mg) {
1120             PMOP **const array = (PMOP**) mg->mg_ptr;
1121             U32 count = mg->mg_len / sizeof(PMOP**);
1122             U32 i = count;
1123
1124             while (i--) {
1125                 if (array[i] == o) {
1126                     /* Found it. Move the entry at the end to overwrite it.  */
1127                     array[i] = array[--count];
1128                     mg->mg_len = count * sizeof(PMOP**);
1129                     /* Could realloc smaller at this point always, but probably
1130                        not worth it. Probably worth free()ing if we're the
1131                        last.  */
1132                     if(!count) {
1133                         Safefree(mg->mg_ptr);
1134                         mg->mg_ptr = NULL;
1135                     }
1136                     break;
1137                 }
1138             }
1139         }
1140     }
1141     if (PL_curpm == o)
1142         PL_curpm = NULL;
1143 }
1144
1145 STATIC void
1146 S_find_and_forget_pmops(pTHX_ OP *o)
1147 {
1148     PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1149
1150     if (o->op_flags & OPf_KIDS) {
1151         OP *kid = cUNOPo->op_first;
1152         while (kid) {
1153             switch (kid->op_type) {
1154             case OP_SUBST:
1155             case OP_PUSHRE:
1156             case OP_MATCH:
1157             case OP_QR:
1158                 forget_pmop((PMOP*)kid);
1159             }
1160             find_and_forget_pmops(kid);
1161             kid = OpSIBLING(kid);
1162         }
1163     }
1164 }
1165
1166 /*
1167 =for apidoc Am|void|op_null|OP *o
1168
1169 Neutralizes an op when it is no longer needed, but is still linked to from
1170 other ops.
1171
1172 =cut
1173 */
1174
1175 void
1176 Perl_op_null(pTHX_ OP *o)
1177 {
1178     dVAR;
1179
1180     PERL_ARGS_ASSERT_OP_NULL;
1181
1182     if (o->op_type == OP_NULL)
1183         return;
1184     op_clear(o);
1185     o->op_targ = o->op_type;
1186     OpTYPE_set(o, OP_NULL);
1187 }
1188
1189 void
1190 Perl_op_refcnt_lock(pTHX)
1191 {
1192 #ifdef USE_ITHREADS
1193     dVAR;
1194 #endif
1195     PERL_UNUSED_CONTEXT;
1196     OP_REFCNT_LOCK;
1197 }
1198
1199 void
1200 Perl_op_refcnt_unlock(pTHX)
1201 {
1202 #ifdef USE_ITHREADS
1203     dVAR;
1204 #endif
1205     PERL_UNUSED_CONTEXT;
1206     OP_REFCNT_UNLOCK;
1207 }
1208
1209
1210 /*
1211 =for apidoc op_sibling_splice
1212
1213 A general function for editing the structure of an existing chain of
1214 op_sibling nodes.  By analogy with the perl-level splice() function, allows
1215 you to delete zero or more sequential nodes, replacing them with zero or
1216 more different nodes.  Performs the necessary op_first/op_last
1217 housekeeping on the parent node and op_sibling manipulation on the
1218 children.  The last deleted node will be marked as as the last node by
1219 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1220
1221 Note that op_next is not manipulated, and nodes are not freed; that is the
1222 responsibility of the caller.  It also won't create a new list op for an
1223 empty list etc; use higher-level functions like op_append_elem() for that.
1224
1225 parent is the parent node of the sibling chain. It may passed as NULL if
1226 the splicing doesn't affect the first or last op in the chain.
1227
1228 start is the node preceding the first node to be spliced.  Node(s)
1229 following it will be deleted, and ops will be inserted after it.  If it is
1230 NULL, the first node onwards is deleted, and nodes are inserted at the
1231 beginning.
1232
1233 del_count is the number of nodes to delete.  If zero, no nodes are deleted.
1234 If -1 or greater than or equal to the number of remaining kids, all
1235 remaining kids are deleted.
1236
1237 insert is the first of a chain of nodes to be inserted in place of the nodes.
1238 If NULL, no nodes are inserted.
1239
1240 The head of the chain of deleted ops is returned, or NULL if no ops were
1241 deleted.
1242
1243 For example:
1244
1245     action                    before      after         returns
1246     ------                    -----       -----         -------
1247
1248                               P           P
1249     splice(P, A, 2, X-Y-Z)    |           |             B-C
1250                               A-B-C-D     A-X-Y-Z-D
1251
1252                               P           P
1253     splice(P, NULL, 1, X-Y)   |           |             A
1254                               A-B-C-D     X-Y-B-C-D
1255
1256                               P           P
1257     splice(P, NULL, 3, NULL)  |           |             A-B-C
1258                               A-B-C-D     D
1259
1260                               P           P
1261     splice(P, B, 0, X-Y)      |           |             NULL
1262                               A-B-C-D     A-B-X-Y-C-D
1263
1264
1265 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1266 see C<OpMORESIB_set>, C<OpLASTSIB_set>, C<OpMAYBESIB_set>.
1267
1268 =cut
1269 */
1270
1271 OP *
1272 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1273 {
1274     OP *first;
1275     OP *rest;
1276     OP *last_del = NULL;
1277     OP *last_ins = NULL;
1278
1279     if (start)
1280         first = OpSIBLING(start);
1281     else if (!parent)
1282         goto no_parent;
1283     else
1284         first = cLISTOPx(parent)->op_first;
1285
1286     assert(del_count >= -1);
1287
1288     if (del_count && first) {
1289         last_del = first;
1290         while (--del_count && OpHAS_SIBLING(last_del))
1291             last_del = OpSIBLING(last_del);
1292         rest = OpSIBLING(last_del);
1293         OpLASTSIB_set(last_del, NULL);
1294     }
1295     else
1296         rest = first;
1297
1298     if (insert) {
1299         last_ins = insert;
1300         while (OpHAS_SIBLING(last_ins))
1301             last_ins = OpSIBLING(last_ins);
1302         OpMAYBESIB_set(last_ins, rest, NULL);
1303     }
1304     else
1305         insert = rest;
1306
1307     if (start) {
1308         OpMAYBESIB_set(start, insert, NULL);
1309     }
1310     else {
1311         if (!parent)
1312             goto no_parent;
1313         cLISTOPx(parent)->op_first = insert;
1314         if (insert)
1315             parent->op_flags |= OPf_KIDS;
1316         else
1317             parent->op_flags &= ~OPf_KIDS;
1318     }
1319
1320     if (!rest) {
1321         /* update op_last etc */
1322         U32 type;
1323         OP *lastop;
1324
1325         if (!parent)
1326             goto no_parent;
1327
1328         /* ought to use OP_CLASS(parent) here, but that can't handle
1329          * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1330          * either */
1331         type = parent->op_type;
1332         if (type == OP_CUSTOM) {
1333             dTHX;
1334             type = XopENTRYCUSTOM(parent, xop_class);
1335         }
1336         else {
1337             if (type == OP_NULL)
1338                 type = parent->op_targ;
1339             type = PL_opargs[type] & OA_CLASS_MASK;
1340         }
1341
1342         lastop = last_ins ? last_ins : start ? start : NULL;
1343         if (   type == OA_BINOP
1344             || type == OA_LISTOP
1345             || type == OA_PMOP
1346             || type == OA_LOOP
1347         )
1348             cLISTOPx(parent)->op_last = lastop;
1349
1350         if (lastop)
1351             OpLASTSIB_set(lastop, parent);
1352     }
1353     return last_del ? first : NULL;
1354
1355   no_parent:
1356     Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1357 }
1358
1359
1360 #ifdef PERL_OP_PARENT
1361
1362 /*
1363 =for apidoc op_parent
1364
1365 Returns the parent OP of o, if it has a parent. Returns NULL otherwise.
1366 This function is only available on perls built with C<-DPERL_OP_PARENT>.
1367
1368 =cut
1369 */
1370
1371 OP *
1372 Perl_op_parent(OP *o)
1373 {
1374     PERL_ARGS_ASSERT_OP_PARENT;
1375     while (OpHAS_SIBLING(o))
1376         o = OpSIBLING(o);
1377     return o->op_sibparent;
1378 }
1379
1380 #endif
1381
1382
1383 /* replace the sibling following start with a new UNOP, which becomes
1384  * the parent of the original sibling; e.g.
1385  *
1386  *  op_sibling_newUNOP(P, A, unop-args...)
1387  *
1388  *  P              P
1389  *  |      becomes |
1390  *  A-B-C          A-U-C
1391  *                   |
1392  *                   B
1393  *
1394  * where U is the new UNOP.
1395  *
1396  * parent and start args are the same as for op_sibling_splice();
1397  * type and flags args are as newUNOP().
1398  *
1399  * Returns the new UNOP.
1400  */
1401
1402 OP *
1403 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1404 {
1405     OP *kid, *newop;
1406
1407     kid = op_sibling_splice(parent, start, 1, NULL);
1408     newop = newUNOP(type, flags, kid);
1409     op_sibling_splice(parent, start, 0, newop);
1410     return newop;
1411 }
1412
1413
1414 /* lowest-level newLOGOP-style function - just allocates and populates
1415  * the struct. Higher-level stuff should be done by S_new_logop() /
1416  * newLOGOP(). This function exists mainly to avoid op_first assignment
1417  * being spread throughout this file.
1418  */
1419
1420 LOGOP *
1421 S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1422 {
1423     dVAR;
1424     LOGOP *logop;
1425     OP *kid = first;
1426     NewOp(1101, logop, 1, LOGOP);
1427     OpTYPE_set(logop, type);
1428     logop->op_first = first;
1429     logop->op_other = other;
1430     logop->op_flags = OPf_KIDS;
1431     while (kid && OpHAS_SIBLING(kid))
1432         kid = OpSIBLING(kid);
1433     if (kid)
1434         OpLASTSIB_set(kid, (OP*)logop);
1435     return logop;
1436 }
1437
1438
1439 /* Contextualizers */
1440
1441 /*
1442 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1443
1444 Applies a syntactic context to an op tree representing an expression.
1445 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
1446 or C<G_VOID> to specify the context to apply.  The modified op tree
1447 is returned.
1448
1449 =cut
1450 */
1451
1452 OP *
1453 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1454 {
1455     PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1456     switch (context) {
1457         case G_SCALAR: return scalar(o);
1458         case G_ARRAY:  return list(o);
1459         case G_VOID:   return scalarvoid(o);
1460         default:
1461             Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1462                        (long) context);
1463     }
1464 }
1465
1466 /*
1467
1468 =for apidoc Am|OP*|op_linklist|OP *o
1469 This function is the implementation of the L</LINKLIST> macro.  It should
1470 not be called directly.
1471
1472 =cut
1473 */
1474
1475 OP *
1476 Perl_op_linklist(pTHX_ OP *o)
1477 {
1478     OP *first;
1479
1480     PERL_ARGS_ASSERT_OP_LINKLIST;
1481
1482     if (o->op_next)
1483         return o->op_next;
1484
1485     /* establish postfix order */
1486     first = cUNOPo->op_first;
1487     if (first) {
1488         OP *kid;
1489         o->op_next = LINKLIST(first);
1490         kid = first;
1491         for (;;) {
1492             OP *sibl = OpSIBLING(kid);
1493             if (sibl) {
1494                 kid->op_next = LINKLIST(sibl);
1495                 kid = sibl;
1496             } else {
1497                 kid->op_next = o;
1498                 break;
1499             }
1500         }
1501     }
1502     else
1503         o->op_next = o;
1504
1505     return o->op_next;
1506 }
1507
1508 static OP *
1509 S_scalarkids(pTHX_ OP *o)
1510 {
1511     if (o && o->op_flags & OPf_KIDS) {
1512         OP *kid;
1513         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1514             scalar(kid);
1515     }
1516     return o;
1517 }
1518
1519 STATIC OP *
1520 S_scalarboolean(pTHX_ OP *o)
1521 {
1522     PERL_ARGS_ASSERT_SCALARBOOLEAN;
1523
1524     if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
1525      && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
1526         if (ckWARN(WARN_SYNTAX)) {
1527             const line_t oldline = CopLINE(PL_curcop);
1528
1529             if (PL_parser && PL_parser->copline != NOLINE) {
1530                 /* This ensures that warnings are reported at the first line
1531                    of the conditional, not the last.  */
1532                 CopLINE_set(PL_curcop, PL_parser->copline);
1533             }
1534             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1535             CopLINE_set(PL_curcop, oldline);
1536         }
1537     }
1538     return scalar(o);
1539 }
1540
1541 static SV *
1542 S_op_varname(pTHX_ const OP *o)
1543 {
1544     assert(o);
1545     assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1546            o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1547     {
1548         const char funny  = o->op_type == OP_PADAV
1549                          || o->op_type == OP_RV2AV ? '@' : '%';
1550         if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1551             GV *gv;
1552             if (cUNOPo->op_first->op_type != OP_GV
1553              || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1554                 return NULL;
1555             return varname(gv, funny, 0, NULL, 0, 1);
1556         }
1557         return
1558             varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, 1);
1559     }
1560 }
1561
1562 static void
1563 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1564 { /* or not so pretty :-) */
1565     if (o->op_type == OP_CONST) {
1566         *retsv = cSVOPo_sv;
1567         if (SvPOK(*retsv)) {
1568             SV *sv = *retsv;
1569             *retsv = sv_newmortal();
1570             pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1571                       PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1572         }
1573         else if (!SvOK(*retsv))
1574             *retpv = "undef";
1575     }
1576     else *retpv = "...";
1577 }
1578
1579 static void
1580 S_scalar_slice_warning(pTHX_ const OP *o)
1581 {
1582     OP *kid;
1583     const char lbrack =
1584         o->op_type == OP_HSLICE ? '{' : '[';
1585     const char rbrack =
1586         o->op_type == OP_HSLICE ? '}' : ']';
1587     SV *name;
1588     SV *keysv = NULL; /* just to silence compiler warnings */
1589     const char *key = NULL;
1590
1591     if (!(o->op_private & OPpSLICEWARNING))
1592         return;
1593     if (PL_parser && PL_parser->error_count)
1594         /* This warning can be nonsensical when there is a syntax error. */
1595         return;
1596
1597     kid = cLISTOPo->op_first;
1598     kid = OpSIBLING(kid); /* get past pushmark */
1599     /* weed out false positives: any ops that can return lists */
1600     switch (kid->op_type) {
1601     case OP_BACKTICK:
1602     case OP_GLOB:
1603     case OP_READLINE:
1604     case OP_MATCH:
1605     case OP_RV2AV:
1606     case OP_EACH:
1607     case OP_VALUES:
1608     case OP_KEYS:
1609     case OP_SPLIT:
1610     case OP_LIST:
1611     case OP_SORT:
1612     case OP_REVERSE:
1613     case OP_ENTERSUB:
1614     case OP_CALLER:
1615     case OP_LSTAT:
1616     case OP_STAT:
1617     case OP_READDIR:
1618     case OP_SYSTEM:
1619     case OP_TMS:
1620     case OP_LOCALTIME:
1621     case OP_GMTIME:
1622     case OP_ENTEREVAL:
1623         return;
1624     }
1625
1626     /* Don't warn if we have a nulled list either. */
1627     if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1628         return;
1629
1630     assert(OpSIBLING(kid));
1631     name = S_op_varname(aTHX_ OpSIBLING(kid));
1632     if (!name) /* XS module fiddling with the op tree */
1633         return;
1634     S_op_pretty(aTHX_ kid, &keysv, &key);
1635     assert(SvPOK(name));
1636     sv_chop(name,SvPVX(name)+1);
1637     if (key)
1638        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1639         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1640                    "Scalar value @%"SVf"%c%s%c better written as $%"SVf
1641                    "%c%s%c",
1642                     SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1643                     lbrack, key, rbrack);
1644     else
1645        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1646         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1647                    "Scalar value @%"SVf"%c%"SVf"%c better written as $%"
1648                     SVf"%c%"SVf"%c",
1649                     SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1650                     SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1651 }
1652
1653 OP *
1654 Perl_scalar(pTHX_ OP *o)
1655 {
1656     OP *kid;
1657
1658     /* assumes no premature commitment */
1659     if (!o || (PL_parser && PL_parser->error_count)
1660          || (o->op_flags & OPf_WANT)
1661          || o->op_type == OP_RETURN)
1662     {
1663         return o;
1664     }
1665
1666     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1667
1668     switch (o->op_type) {
1669     case OP_REPEAT:
1670         scalar(cBINOPo->op_first);
1671         if (o->op_private & OPpREPEAT_DOLIST) {
1672             kid = cLISTOPx(cUNOPo->op_first)->op_first;
1673             assert(kid->op_type == OP_PUSHMARK);
1674             if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1675                 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1676                 o->op_private &=~ OPpREPEAT_DOLIST;
1677             }
1678         }
1679         break;
1680     case OP_OR:
1681     case OP_AND:
1682     case OP_COND_EXPR:
1683         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
1684             scalar(kid);
1685         break;
1686         /* FALLTHROUGH */
1687     case OP_SPLIT:
1688     case OP_MATCH:
1689     case OP_QR:
1690     case OP_SUBST:
1691     case OP_NULL:
1692     default:
1693         if (o->op_flags & OPf_KIDS) {
1694             for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1695                 scalar(kid);
1696         }
1697         break;
1698     case OP_LEAVE:
1699     case OP_LEAVETRY:
1700         kid = cLISTOPo->op_first;
1701         scalar(kid);
1702         kid = OpSIBLING(kid);
1703     do_kids:
1704         while (kid) {
1705             OP *sib = OpSIBLING(kid);
1706             if (sib && kid->op_type != OP_LEAVEWHEN
1707              && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
1708                 || (  sib->op_targ != OP_NEXTSTATE
1709                    && sib->op_targ != OP_DBSTATE  )))
1710                 scalarvoid(kid);
1711             else
1712                 scalar(kid);
1713             kid = sib;
1714         }
1715         PL_curcop = &PL_compiling;
1716         break;
1717     case OP_SCOPE:
1718     case OP_LINESEQ:
1719     case OP_LIST:
1720         kid = cLISTOPo->op_first;
1721         goto do_kids;
1722     case OP_SORT:
1723         Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1724         break;
1725     case OP_KVHSLICE:
1726     case OP_KVASLICE:
1727     {
1728         /* Warn about scalar context */
1729         const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1730         const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1731         SV *name;
1732         SV *keysv;
1733         const char *key = NULL;
1734
1735         /* This warning can be nonsensical when there is a syntax error. */
1736         if (PL_parser && PL_parser->error_count)
1737             break;
1738
1739         if (!ckWARN(WARN_SYNTAX)) break;
1740
1741         kid = cLISTOPo->op_first;
1742         kid = OpSIBLING(kid); /* get past pushmark */
1743         assert(OpSIBLING(kid));
1744         name = S_op_varname(aTHX_ OpSIBLING(kid));
1745         if (!name) /* XS module fiddling with the op tree */
1746             break;
1747         S_op_pretty(aTHX_ kid, &keysv, &key);
1748         assert(SvPOK(name));
1749         sv_chop(name,SvPVX(name)+1);
1750         if (key)
1751   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1752             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1753                        "%%%"SVf"%c%s%c in scalar context better written "
1754                        "as $%"SVf"%c%s%c",
1755                         SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1756                         lbrack, key, rbrack);
1757         else
1758   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1759             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1760                        "%%%"SVf"%c%"SVf"%c in scalar context better "
1761                        "written as $%"SVf"%c%"SVf"%c",
1762                         SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1763                         SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1764     }
1765     }
1766     return o;
1767 }
1768
1769 OP *
1770 Perl_scalarvoid(pTHX_ OP *arg)
1771 {
1772     dVAR;
1773     OP *kid;
1774     SV* sv;
1775     U8 want;
1776     SSize_t defer_stack_alloc = 0;
1777     SSize_t defer_ix = -1;
1778     OP **defer_stack = NULL;
1779     OP *o = arg;
1780
1781     PERL_ARGS_ASSERT_SCALARVOID;
1782
1783     do {
1784         SV *useless_sv = NULL;
1785         const char* useless = NULL;
1786
1787         if (o->op_type == OP_NEXTSTATE
1788             || o->op_type == OP_DBSTATE
1789             || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1790                                           || o->op_targ == OP_DBSTATE)))
1791             PL_curcop = (COP*)o;                /* for warning below */
1792
1793         /* assumes no premature commitment */
1794         want = o->op_flags & OPf_WANT;
1795         if ((want && want != OPf_WANT_SCALAR)
1796             || (PL_parser && PL_parser->error_count)
1797             || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1798         {
1799             continue;
1800         }
1801
1802         if ((o->op_private & OPpTARGET_MY)
1803             && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1804         {
1805             /* newASSIGNOP has already applied scalar context, which we
1806                leave, as if this op is inside SASSIGN.  */
1807             continue;
1808         }
1809
1810         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1811
1812         switch (o->op_type) {
1813         default:
1814             if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1815                 break;
1816             /* FALLTHROUGH */
1817         case OP_REPEAT:
1818             if (o->op_flags & OPf_STACKED)
1819                 break;
1820             if (o->op_type == OP_REPEAT)
1821                 scalar(cBINOPo->op_first);
1822             goto func_ops;
1823         case OP_SUBSTR:
1824             if (o->op_private == 4)
1825                 break;
1826             /* FALLTHROUGH */
1827         case OP_WANTARRAY:
1828         case OP_GV:
1829         case OP_SMARTMATCH:
1830         case OP_AV2ARYLEN:
1831         case OP_REF:
1832         case OP_REFGEN:
1833         case OP_SREFGEN:
1834         case OP_DEFINED:
1835         case OP_HEX:
1836         case OP_OCT:
1837         case OP_LENGTH:
1838         case OP_VEC:
1839         case OP_INDEX:
1840         case OP_RINDEX:
1841         case OP_SPRINTF:
1842         case OP_KVASLICE:
1843         case OP_KVHSLICE:
1844         case OP_UNPACK:
1845         case OP_PACK:
1846         case OP_JOIN:
1847         case OP_LSLICE:
1848         case OP_ANONLIST:
1849         case OP_ANONHASH:
1850         case OP_SORT:
1851         case OP_REVERSE:
1852         case OP_RANGE:
1853         case OP_FLIP:
1854         case OP_FLOP:
1855         case OP_CALLER:
1856         case OP_FILENO:
1857         case OP_EOF:
1858         case OP_TELL:
1859         case OP_GETSOCKNAME:
1860         case OP_GETPEERNAME:
1861         case OP_READLINK:
1862         case OP_TELLDIR:
1863         case OP_GETPPID:
1864         case OP_GETPGRP:
1865         case OP_GETPRIORITY:
1866         case OP_TIME:
1867         case OP_TMS:
1868         case OP_LOCALTIME:
1869         case OP_GMTIME:
1870         case OP_GHBYNAME:
1871         case OP_GHBYADDR:
1872         case OP_GHOSTENT:
1873         case OP_GNBYNAME:
1874         case OP_GNBYADDR:
1875         case OP_GNETENT:
1876         case OP_GPBYNAME:
1877         case OP_GPBYNUMBER:
1878         case OP_GPROTOENT:
1879         case OP_GSBYNAME:
1880         case OP_GSBYPORT:
1881         case OP_GSERVENT:
1882         case OP_GPWNAM:
1883         case OP_GPWUID:
1884         case OP_GGRNAM:
1885         case OP_GGRGID:
1886         case OP_GETLOGIN:
1887         case OP_PROTOTYPE:
1888         case OP_RUNCV:
1889         func_ops:
1890             useless = OP_DESC(o);
1891             break;
1892
1893         case OP_GVSV:
1894         case OP_PADSV:
1895         case OP_PADAV:
1896         case OP_PADHV:
1897         case OP_PADANY:
1898         case OP_AELEM:
1899         case OP_AELEMFAST:
1900         case OP_AELEMFAST_LEX:
1901         case OP_ASLICE:
1902         case OP_HELEM:
1903         case OP_HSLICE:
1904             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1905                 /* Otherwise it's "Useless use of grep iterator" */
1906                 useless = OP_DESC(o);
1907             break;
1908
1909         case OP_SPLIT:
1910             kid = cLISTOPo->op_first;
1911             if (kid && kid->op_type == OP_PUSHRE
1912                 && !kid->op_targ
1913                 && !(o->op_flags & OPf_STACKED)
1914 #ifdef USE_ITHREADS
1915                 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
1916 #else
1917                 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
1918 #endif
1919                 )
1920                 useless = OP_DESC(o);
1921             break;
1922
1923         case OP_NOT:
1924             kid = cUNOPo->op_first;
1925             if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1926                 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1927                 goto func_ops;
1928             }
1929             useless = "negative pattern binding (!~)";
1930             break;
1931
1932         case OP_SUBST:
1933             if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1934                 useless = "non-destructive substitution (s///r)";
1935             break;
1936
1937         case OP_TRANSR:
1938             useless = "non-destructive transliteration (tr///r)";
1939             break;
1940
1941         case OP_RV2GV:
1942         case OP_RV2SV:
1943         case OP_RV2AV:
1944         case OP_RV2HV:
1945             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1946                 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
1947                 useless = "a variable";
1948             break;
1949
1950         case OP_CONST:
1951             sv = cSVOPo_sv;
1952             if (cSVOPo->op_private & OPpCONST_STRICT)
1953                 no_bareword_allowed(o);
1954             else {
1955                 if (ckWARN(WARN_VOID)) {
1956                     NV nv;
1957                     /* don't warn on optimised away booleans, eg
1958                      * use constant Foo, 5; Foo || print; */
1959                     if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1960                         useless = NULL;
1961                     /* the constants 0 and 1 are permitted as they are
1962                        conventionally used as dummies in constructs like
1963                        1 while some_condition_with_side_effects;  */
1964                     else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
1965                         useless = NULL;
1966                     else if (SvPOK(sv)) {
1967                         SV * const dsv = newSVpvs("");
1968                         useless_sv
1969                             = Perl_newSVpvf(aTHX_
1970                                             "a constant (%s)",
1971                                             pv_pretty(dsv, SvPVX_const(sv),
1972                                                       SvCUR(sv), 32, NULL, NULL,
1973                                                       PERL_PV_PRETTY_DUMP
1974                                                       | PERL_PV_ESCAPE_NOCLEAR
1975                                                       | PERL_PV_ESCAPE_UNI_DETECT));
1976                         SvREFCNT_dec_NN(dsv);
1977                     }
1978                     else if (SvOK(sv)) {
1979                         useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", SVfARG(sv));
1980                     }
1981                     else
1982                         useless = "a constant (undef)";
1983                 }
1984             }
1985             op_null(o);         /* don't execute or even remember it */
1986             break;
1987
1988         case OP_POSTINC:
1989             OpTYPE_set(o, OP_PREINC);  /* pre-increment is faster */
1990             break;
1991
1992         case OP_POSTDEC:
1993             OpTYPE_set(o, OP_PREDEC);  /* pre-decrement is faster */
1994             break;
1995
1996         case OP_I_POSTINC:
1997             OpTYPE_set(o, OP_I_PREINC);        /* pre-increment is faster */
1998             break;
1999
2000         case OP_I_POSTDEC:
2001             OpTYPE_set(o, OP_I_PREDEC);        /* pre-decrement is faster */
2002             break;
2003
2004         case OP_SASSIGN: {
2005             OP *rv2gv;
2006             UNOP *refgen, *rv2cv;
2007             LISTOP *exlist;
2008
2009             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2010                 break;
2011
2012             rv2gv = ((BINOP *)o)->op_last;
2013             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2014                 break;
2015
2016             refgen = (UNOP *)((BINOP *)o)->op_first;
2017
2018             if (!refgen || (refgen->op_type != OP_REFGEN
2019                             && refgen->op_type != OP_SREFGEN))
2020                 break;
2021
2022             exlist = (LISTOP *)refgen->op_first;
2023             if (!exlist || exlist->op_type != OP_NULL
2024                 || exlist->op_targ != OP_LIST)
2025                 break;
2026
2027             if (exlist->op_first->op_type != OP_PUSHMARK
2028                 && exlist->op_first != exlist->op_last)
2029                 break;
2030
2031             rv2cv = (UNOP*)exlist->op_last;
2032
2033             if (rv2cv->op_type != OP_RV2CV)
2034                 break;
2035
2036             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2037             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2038             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2039
2040             o->op_private |= OPpASSIGN_CV_TO_GV;
2041             rv2gv->op_private |= OPpDONT_INIT_GV;
2042             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2043
2044             break;
2045         }
2046
2047         case OP_AASSIGN: {
2048             inplace_aassign(o);
2049             break;
2050         }
2051
2052         case OP_OR:
2053         case OP_AND:
2054             kid = cLOGOPo->op_first;
2055             if (kid->op_type == OP_NOT
2056                 && (kid->op_flags & OPf_KIDS)) {
2057                 if (o->op_type == OP_AND) {
2058                     OpTYPE_set(o, OP_OR);
2059                 } else {
2060                     OpTYPE_set(o, OP_AND);
2061                 }
2062                 op_null(kid);
2063             }
2064             /* FALLTHROUGH */
2065
2066         case OP_DOR:
2067         case OP_COND_EXPR:
2068         case OP_ENTERGIVEN:
2069         case OP_ENTERWHEN:
2070             for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2071                 if (!(kid->op_flags & OPf_KIDS))
2072                     scalarvoid(kid);
2073                 else
2074                     DEFER_OP(kid);
2075         break;
2076
2077         case OP_NULL:
2078             if (o->op_flags & OPf_STACKED)
2079                 break;
2080             /* FALLTHROUGH */
2081         case OP_NEXTSTATE:
2082         case OP_DBSTATE:
2083         case OP_ENTERTRY:
2084         case OP_ENTER:
2085             if (!(o->op_flags & OPf_KIDS))
2086                 break;
2087             /* FALLTHROUGH */
2088         case OP_SCOPE:
2089         case OP_LEAVE:
2090         case OP_LEAVETRY:
2091         case OP_LEAVELOOP:
2092         case OP_LINESEQ:
2093         case OP_LEAVEGIVEN:
2094         case OP_LEAVEWHEN:
2095         kids:
2096             for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2097                 if (!(kid->op_flags & OPf_KIDS))
2098                     scalarvoid(kid);
2099                 else
2100                     DEFER_OP(kid);
2101             break;
2102         case OP_LIST:
2103             /* If the first kid after pushmark is something that the padrange
2104                optimisation would reject, then null the list and the pushmark.
2105             */
2106             if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2107                 && (  !(kid = OpSIBLING(kid))
2108                       || (  kid->op_type != OP_PADSV
2109                             && kid->op_type != OP_PADAV
2110                             && kid->op_type != OP_PADHV)
2111                       || kid->op_private & ~OPpLVAL_INTRO
2112                       || !(kid = OpSIBLING(kid))
2113                       || (  kid->op_type != OP_PADSV
2114                             && kid->op_type != OP_PADAV
2115                             && kid->op_type != OP_PADHV)
2116                       || kid->op_private & ~OPpLVAL_INTRO)
2117             ) {
2118                 op_null(cUNOPo->op_first); /* NULL the pushmark */
2119                 op_null(o); /* NULL the list */
2120             }
2121             goto kids;
2122         case OP_ENTEREVAL:
2123             scalarkids(o);
2124             break;
2125         case OP_SCALAR:
2126             scalar(o);
2127             break;
2128         }
2129
2130         if (useless_sv) {
2131             /* mortalise it, in case warnings are fatal.  */
2132             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2133                            "Useless use of %"SVf" in void context",
2134                            SVfARG(sv_2mortal(useless_sv)));
2135         }
2136         else if (useless) {
2137             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2138                            "Useless use of %s in void context",
2139                            useless);
2140         }
2141     } while ( (o = POP_DEFERRED_OP()) );
2142
2143     Safefree(defer_stack);
2144
2145     return arg;
2146 }
2147
2148 static OP *
2149 S_listkids(pTHX_ OP *o)
2150 {
2151     if (o && o->op_flags & OPf_KIDS) {
2152         OP *kid;
2153         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2154             list(kid);
2155     }
2156     return o;
2157 }
2158
2159 OP *
2160 Perl_list(pTHX_ OP *o)
2161 {
2162     OP *kid;
2163
2164     /* assumes no premature commitment */
2165     if (!o || (o->op_flags & OPf_WANT)
2166          || (PL_parser && PL_parser->error_count)
2167          || o->op_type == OP_RETURN)
2168     {
2169         return o;
2170     }
2171
2172     if ((o->op_private & OPpTARGET_MY)
2173         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2174     {
2175         return o;                               /* As if inside SASSIGN */
2176     }
2177
2178     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2179
2180     switch (o->op_type) {
2181     case OP_FLOP:
2182         list(cBINOPo->op_first);
2183         break;
2184     case OP_REPEAT:
2185         if (o->op_private & OPpREPEAT_DOLIST
2186          && !(o->op_flags & OPf_STACKED))
2187         {
2188             list(cBINOPo->op_first);
2189             kid = cBINOPo->op_last;
2190             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2191              && SvIVX(kSVOP_sv) == 1)
2192             {
2193                 op_null(o); /* repeat */
2194                 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2195                 /* const (rhs): */
2196                 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2197             }
2198         }
2199         break;
2200     case OP_OR:
2201     case OP_AND:
2202     case OP_COND_EXPR:
2203         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2204             list(kid);
2205         break;
2206     default:
2207     case OP_MATCH:
2208     case OP_QR:
2209     case OP_SUBST:
2210     case OP_NULL:
2211         if (!(o->op_flags & OPf_KIDS))
2212             break;
2213         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2214             list(cBINOPo->op_first);
2215             return gen_constant_list(o);
2216         }
2217         listkids(o);
2218         break;
2219     case OP_LIST:
2220         listkids(o);
2221         if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2222             op_null(cUNOPo->op_first); /* NULL the pushmark */
2223             op_null(o); /* NULL the list */
2224         }
2225         break;
2226     case OP_LEAVE:
2227     case OP_LEAVETRY:
2228         kid = cLISTOPo->op_first;
2229         list(kid);
2230         kid = OpSIBLING(kid);
2231     do_kids:
2232         while (kid) {
2233             OP *sib = OpSIBLING(kid);
2234             if (sib && kid->op_type != OP_LEAVEWHEN)
2235                 scalarvoid(kid);
2236             else
2237                 list(kid);
2238             kid = sib;
2239         }
2240         PL_curcop = &PL_compiling;
2241         break;
2242     case OP_SCOPE:
2243     case OP_LINESEQ:
2244         kid = cLISTOPo->op_first;
2245         goto do_kids;
2246     }
2247     return o;
2248 }
2249
2250 static OP *
2251 S_scalarseq(pTHX_ OP *o)
2252 {
2253     if (o) {
2254         const OPCODE type = o->op_type;
2255
2256         if (type == OP_LINESEQ || type == OP_SCOPE ||
2257             type == OP_LEAVE || type == OP_LEAVETRY)
2258         {
2259             OP *kid, *sib;
2260             for (kid = cLISTOPo->op_first; kid; kid = sib) {
2261                 if ((sib = OpSIBLING(kid))
2262                  && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2263                     || (  sib->op_targ != OP_NEXTSTATE
2264                        && sib->op_targ != OP_DBSTATE  )))
2265                 {
2266                     scalarvoid(kid);
2267                 }
2268             }
2269             PL_curcop = &PL_compiling;
2270         }
2271         o->op_flags &= ~OPf_PARENS;
2272         if (PL_hints & HINT_BLOCK_SCOPE)
2273             o->op_flags |= OPf_PARENS;
2274     }
2275     else
2276         o = newOP(OP_STUB, 0);
2277     return o;
2278 }
2279
2280 STATIC OP *
2281 S_modkids(pTHX_ OP *o, I32 type)
2282 {
2283     if (o && o->op_flags & OPf_KIDS) {
2284         OP *kid;
2285         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2286             op_lvalue(kid, type);
2287     }
2288     return o;
2289 }
2290
2291
2292 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2293  * const fields. Also, convert CONST keys to HEK-in-SVs.
2294  * rop is the op that retrieves the hash;
2295  * key_op is the first key
2296  */
2297
2298 void
2299 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op)
2300 {
2301     PADNAME *lexname;
2302     GV **fields;
2303     bool check_fields;
2304
2305     /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2306     if (rop) {
2307         if (rop->op_first->op_type == OP_PADSV)
2308             /* @$hash{qw(keys here)} */
2309             rop = (UNOP*)rop->op_first;
2310         else {
2311             /* @{$hash}{qw(keys here)} */
2312             if (rop->op_first->op_type == OP_SCOPE
2313                 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2314                 {
2315                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2316                 }
2317             else
2318                 rop = NULL;
2319         }
2320     }
2321
2322     lexname = NULL; /* just to silence compiler warnings */
2323     fields  = NULL; /* just to silence compiler warnings */
2324
2325     check_fields =
2326             rop
2327          && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2328              SvPAD_TYPED(lexname))
2329          && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2330          && isGV(*fields) && GvHV(*fields);
2331
2332     for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2333         SV **svp, *sv;
2334         if (key_op->op_type != OP_CONST)
2335             continue;
2336         svp = cSVOPx_svp(key_op);
2337
2338         /* Make the CONST have a shared SV */
2339         if (   !SvIsCOW_shared_hash(sv = *svp)
2340             && SvTYPE(sv) < SVt_PVMG
2341             && SvOK(sv)
2342             && !SvROK(sv))
2343         {
2344             SSize_t keylen;
2345             const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2346             SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2347             SvREFCNT_dec_NN(sv);
2348             *svp = nsv;
2349         }
2350
2351         if (   check_fields
2352             && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2353         {
2354             Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
2355                         "in variable %"PNf" of type %"HEKf,
2356                         SVfARG(*svp), PNfARG(lexname),
2357                         HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2358         }
2359     }
2360 }
2361
2362
2363 /*
2364 =for apidoc finalize_optree
2365
2366 This function finalizes the optree.  Should be called directly after
2367 the complete optree is built.  It does some additional
2368 checking which can't be done in the normal ck_xxx functions and makes
2369 the tree thread-safe.
2370
2371 =cut
2372 */
2373 void
2374 Perl_finalize_optree(pTHX_ OP* o)
2375 {
2376     PERL_ARGS_ASSERT_FINALIZE_OPTREE;
2377
2378     ENTER;
2379     SAVEVPTR(PL_curcop);
2380
2381     finalize_op(o);
2382
2383     LEAVE;
2384 }
2385
2386 #ifdef USE_ITHREADS
2387 /* Relocate sv to the pad for thread safety.
2388  * Despite being a "constant", the SV is written to,
2389  * for reference counts, sv_upgrade() etc. */
2390 PERL_STATIC_INLINE void
2391 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
2392 {
2393     PADOFFSET ix;
2394     PERL_ARGS_ASSERT_OP_RELOCATE_SV;
2395     if (!*svp) return;
2396     ix = pad_alloc(OP_CONST, SVf_READONLY);
2397     SvREFCNT_dec(PAD_SVl(ix));
2398     PAD_SETSV(ix, *svp);
2399     /* XXX I don't know how this isn't readonly already. */
2400     if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
2401     *svp = NULL;
2402     *targp = ix;
2403 }
2404 #endif
2405
2406
2407 STATIC void
2408 S_finalize_op(pTHX_ OP* o)
2409 {
2410     PERL_ARGS_ASSERT_FINALIZE_OP;
2411
2412
2413     switch (o->op_type) {
2414     case OP_NEXTSTATE:
2415     case OP_DBSTATE:
2416         PL_curcop = ((COP*)o);          /* for warnings */
2417         break;
2418     case OP_EXEC:
2419         if (OpHAS_SIBLING(o)) {
2420             OP *sib = OpSIBLING(o);
2421             if ((  sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
2422                 && ckWARN(WARN_EXEC)
2423                 && OpHAS_SIBLING(sib))
2424             {
2425                     const OPCODE type = OpSIBLING(sib)->op_type;
2426                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
2427                         const line_t oldline = CopLINE(PL_curcop);
2428                         CopLINE_set(PL_curcop, CopLINE((COP*)sib));
2429                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
2430                             "Statement unlikely to be reached");
2431                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
2432                             "\t(Maybe you meant system() when you said exec()?)\n");
2433                         CopLINE_set(PL_curcop, oldline);
2434                     }
2435             }
2436         }
2437         break;
2438
2439     case OP_GV:
2440         if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
2441             GV * const gv = cGVOPo_gv;
2442             if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
2443                 /* XXX could check prototype here instead of just carping */
2444                 SV * const sv = sv_newmortal();
2445                 gv_efullname3(sv, gv, NULL);
2446                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
2447                     "%"SVf"() called too early to check prototype",
2448                     SVfARG(sv));
2449             }
2450         }
2451         break;
2452
2453     case OP_CONST:
2454         if (cSVOPo->op_private & OPpCONST_STRICT)
2455             no_bareword_allowed(o);
2456         /* FALLTHROUGH */
2457 #ifdef USE_ITHREADS
2458     case OP_HINTSEVAL:
2459         op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
2460 #endif
2461         break;
2462
2463 #ifdef USE_ITHREADS
2464     /* Relocate all the METHOP's SVs to the pad for thread safety. */
2465     case OP_METHOD_NAMED:
2466     case OP_METHOD_SUPER:
2467     case OP_METHOD_REDIR:
2468     case OP_METHOD_REDIR_SUPER:
2469         op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
2470         break;
2471 #endif
2472
2473     case OP_HELEM: {
2474         UNOP *rop;
2475         SVOP *key_op;
2476         OP *kid;
2477
2478         if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
2479             break;
2480
2481         rop = (UNOP*)((BINOP*)o)->op_first;
2482
2483         goto check_keys;
2484
2485     case OP_HSLICE:
2486         S_scalar_slice_warning(aTHX_ o);
2487         /* FALLTHROUGH */
2488
2489     case OP_KVHSLICE:
2490         kid = OpSIBLING(cLISTOPo->op_first);
2491         if (/* I bet there's always a pushmark... */
2492             OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
2493             && OP_TYPE_ISNT_NN(kid, OP_CONST))
2494         {
2495             break;
2496         }
2497
2498         key_op = (SVOP*)(kid->op_type == OP_CONST
2499                                 ? kid
2500                                 : OpSIBLING(kLISTOP->op_first));
2501
2502         rop = (UNOP*)((LISTOP*)o)->op_last;
2503
2504       check_keys:
2505         if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
2506             rop = NULL;
2507         S_check_hash_fields_and_hekify(aTHX_ rop, key_op);
2508         break;
2509     }
2510     case OP_ASLICE:
2511         S_scalar_slice_warning(aTHX_ o);
2512         break;
2513
2514     case OP_SUBST: {
2515         if (cPMOPo->op_pmreplrootu.op_pmreplroot)
2516             finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
2517         break;
2518     }
2519     default:
2520         break;
2521     }
2522
2523     if (o->op_flags & OPf_KIDS) {
2524         OP *kid;
2525
2526 #ifdef DEBUGGING
2527         /* check that op_last points to the last sibling, and that
2528          * the last op_sibling/op_sibparent field points back to the
2529          * parent, and that the only ops with KIDS are those which are
2530          * entitled to them */
2531         U32 type = o->op_type;
2532         U32 family;
2533         bool has_last;
2534
2535         if (type == OP_NULL) {
2536             type = o->op_targ;
2537             /* ck_glob creates a null UNOP with ex-type GLOB
2538              * (which is a list op. So pretend it wasn't a listop */
2539             if (type == OP_GLOB)
2540                 type = OP_NULL;
2541         }
2542         family = PL_opargs[type] & OA_CLASS_MASK;
2543
2544         has_last = (   family == OA_BINOP
2545                     || family == OA_LISTOP
2546                     || family == OA_PMOP
2547                     || family == OA_LOOP
2548                    );
2549         assert(  has_last /* has op_first and op_last, or ...
2550               ... has (or may have) op_first: */
2551               || family == OA_UNOP
2552               || family == OA_UNOP_AUX
2553               || family == OA_LOGOP
2554               || family == OA_BASEOP_OR_UNOP
2555               || family == OA_FILESTATOP
2556               || family == OA_LOOPEXOP
2557               || family == OA_METHOP
2558               /* I don't know why SASSIGN is tagged as OA_BASEOP - DAPM */
2559               || type == OP_SASSIGN
2560               || type == OP_CUSTOM
2561               || type == OP_NULL /* new_logop does this */
2562               );
2563
2564         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2565 #  ifdef PERL_OP_PARENT
2566             if (!OpHAS_SIBLING(kid)) {
2567                 if (has_last)
2568                     assert(kid == cLISTOPo->op_last);
2569                 assert(kid->op_sibparent == o);
2570             }
2571 #  else
2572             if (has_last && !OpHAS_SIBLING(kid))
2573                 assert(kid == cLISTOPo->op_last);
2574 #  endif
2575         }
2576 #endif
2577
2578         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
2579             finalize_op(kid);
2580     }
2581 }
2582
2583 /*
2584 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
2585
2586 Propagate lvalue ("modifiable") context to an op and its children.
2587 C<type> represents the context type, roughly based on the type of op that
2588 would do the modifying, although C<local()> is represented by OP_NULL,
2589 because it has no op type of its own (it is signalled by a flag on
2590 the lvalue op).
2591
2592 This function detects things that can't be modified, such as C<$x+1>, and
2593 generates errors for them.  For example, C<$x+1 = 2> would cause it to be
2594 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
2595
2596 It also flags things that need to behave specially in an lvalue context,
2597 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
2598
2599 =cut
2600 */
2601
2602 static void
2603 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
2604 {
2605     CV *cv = PL_compcv;
2606     PadnameLVALUE_on(pn);
2607     while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
2608         cv = CvOUTSIDE(cv);
2609         assert(cv);
2610         assert(CvPADLIST(cv));
2611         pn =
2612            PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
2613         assert(PadnameLEN(pn));
2614         PadnameLVALUE_on(pn);
2615     }
2616 }
2617
2618 static bool
2619 S_vivifies(const OPCODE type)
2620 {
2621     switch(type) {
2622     case OP_RV2AV:     case   OP_ASLICE:
2623     case OP_RV2HV:     case OP_KVASLICE:
2624     case OP_RV2SV:     case   OP_HSLICE:
2625     case OP_AELEMFAST: case OP_KVHSLICE:
2626     case OP_HELEM:
2627     case OP_AELEM:
2628         return 1;
2629     }
2630     return 0;
2631 }
2632
2633 static void
2634 S_lvref(pTHX_ OP *o, I32 type)
2635 {
2636     dVAR;
2637     OP *kid;
2638     switch (o->op_type) {
2639     case OP_COND_EXPR:
2640         for (kid = OpSIBLING(cUNOPo->op_first); kid;
2641              kid = OpSIBLING(kid))
2642             S_lvref(aTHX_ kid, type);
2643         /* FALLTHROUGH */
2644     case OP_PUSHMARK:
2645         return;
2646     case OP_RV2AV:
2647         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2648         o->op_flags |= OPf_STACKED;
2649         if (o->op_flags & OPf_PARENS) {
2650             if (o->op_private & OPpLVAL_INTRO) {
2651                  yyerror(Perl_form(aTHX_ "Can't modify reference to "
2652                       "localized parenthesized array in list assignment"));
2653                 return;
2654             }
2655           slurpy:
2656             OpTYPE_set(o, OP_LVAVREF);
2657             o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
2658             o->op_flags |= OPf_MOD|OPf_REF;
2659             return;
2660         }
2661         o->op_private |= OPpLVREF_AV;
2662         goto checkgv;
2663     case OP_RV2CV:
2664         kid = cUNOPo->op_first;
2665         if (kid->op_type == OP_NULL)
2666             kid = cUNOPx(OpSIBLING(kUNOP->op_first))
2667                 ->op_first;
2668         o->op_private = OPpLVREF_CV;
2669         if (kid->op_type == OP_GV)
2670             o->op_flags |= OPf_STACKED;
2671         else if (kid->op_type == OP_PADCV) {
2672             o->op_targ = kid->op_targ;
2673             kid->op_targ = 0;
2674             op_free(cUNOPo->op_first);
2675             cUNOPo->op_first = NULL;
2676             o->op_flags &=~ OPf_KIDS;
2677         }
2678         else goto badref;
2679         break;
2680     case OP_RV2HV:
2681         if (o->op_flags & OPf_PARENS) {
2682           parenhash:
2683             yyerror(Perl_form(aTHX_ "Can't modify reference to "
2684                                  "parenthesized hash in list assignment"));
2685                 return;
2686         }
2687         o->op_private |= OPpLVREF_HV;
2688         /* FALLTHROUGH */
2689     case OP_RV2SV:
2690       checkgv:
2691         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2692         o->op_flags |= OPf_STACKED;
2693         break;
2694     case OP_PADHV:
2695         if (o->op_flags & OPf_PARENS) goto parenhash;
2696         o->op_private |= OPpLVREF_HV;
2697         /* FALLTHROUGH */
2698     case OP_PADSV:
2699         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2700         break;
2701     case OP_PADAV:
2702         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2703         if (o->op_flags & OPf_PARENS) goto slurpy;
2704         o->op_private |= OPpLVREF_AV;
2705         break;
2706     case OP_AELEM:
2707     case OP_HELEM:
2708         o->op_private |= OPpLVREF_ELEM;
2709         o->op_flags   |= OPf_STACKED;
2710         break;
2711     case OP_ASLICE:
2712     case OP_HSLICE:
2713         OpTYPE_set(o, OP_LVREFSLICE);
2714         o->op_private &= OPpLVAL_INTRO|OPpLVREF_ELEM;
2715         return;
2716     case OP_NULL:
2717         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
2718             goto badref;
2719         else if (!(o->op_flags & OPf_KIDS))
2720             return;
2721         if (o->op_targ != OP_LIST) {
2722             S_lvref(aTHX_ cBINOPo->op_first, type);
2723             return;
2724         }
2725         /* FALLTHROUGH */
2726     case OP_LIST:
2727         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
2728             assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
2729             S_lvref(aTHX_ kid, type);
2730         }
2731         return;
2732     case OP_STUB:
2733         if (o->op_flags & OPf_PARENS)
2734             return;
2735         /* FALLTHROUGH */
2736     default:
2737       badref:
2738         /* diag_listed_as: Can't modify reference to %s in %s assignment */
2739         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
2740                      o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
2741                       ? "do block"
2742                       : OP_DESC(o),
2743                      PL_op_desc[type]));
2744     }
2745     OpTYPE_set(o, OP_LVREF);
2746     o->op_private &=
2747         OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
2748     if (type == OP_ENTERLOOP)
2749         o->op_private |= OPpLVREF_ITER;
2750 }
2751
2752 OP *
2753 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
2754 {
2755     dVAR;
2756     OP *kid;
2757     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2758     int localize = -1;
2759
2760     if (!o || (PL_parser && PL_parser->error_count))
2761         return o;
2762
2763     if ((o->op_private & OPpTARGET_MY)
2764         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2765     {
2766         return o;
2767     }
2768
2769     assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2770
2771     if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2772
2773     switch (o->op_type) {
2774     case OP_UNDEF:
2775         PL_modcount++;
2776         return o;
2777     case OP_STUB:
2778         if ((o->op_flags & OPf_PARENS))
2779             break;
2780         goto nomod;
2781     case OP_ENTERSUB:
2782         if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
2783             !(o->op_flags & OPf_STACKED)) {
2784             OpTYPE_set(o, OP_RV2CV);            /* entersub => rv2cv */
2785             assert(cUNOPo->op_first->op_type == OP_NULL);
2786             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
2787             break;
2788         }
2789         else {                          /* lvalue subroutine call */
2790             o->op_private |= OPpLVAL_INTRO;
2791             PL_modcount = RETURN_UNLIMITED_NUMBER;
2792             if (type == OP_GREPSTART || type == OP_ENTERSUB
2793              || type == OP_REFGEN    || type == OP_LEAVESUBLV) {
2794                 /* Potential lvalue context: */
2795                 o->op_private |= OPpENTERSUB_INARGS;
2796                 break;
2797             }
2798             else {                      /* Compile-time error message: */
2799                 OP *kid = cUNOPo->op_first;
2800                 CV *cv;
2801                 GV *gv;
2802
2803                 if (kid->op_type != OP_PUSHMARK) {
2804                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2805                         Perl_croak(aTHX_
2806                                 "panic: unexpected lvalue entersub "
2807                                 "args: type/targ %ld:%"UVuf,
2808                                 (long)kid->op_type, (UV)kid->op_targ);
2809                     kid = kLISTOP->op_first;
2810                 }
2811                 while (OpHAS_SIBLING(kid))
2812                     kid = OpSIBLING(kid);
2813                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
2814                     break;      /* Postpone until runtime */
2815                 }
2816
2817                 kid = kUNOP->op_first;
2818                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2819                     kid = kUNOP->op_first;
2820                 if (kid->op_type == OP_NULL)
2821                     Perl_croak(aTHX_
2822                                "Unexpected constant lvalue entersub "
2823                                "entry via type/targ %ld:%"UVuf,
2824                                (long)kid->op_type, (UV)kid->op_targ);
2825                 if (kid->op_type != OP_GV) {
2826                     break;
2827                 }
2828
2829                 gv = kGVOP_gv;
2830                 cv = isGV(gv)
2831                     ? GvCV(gv)
2832                     : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
2833                         ? MUTABLE_CV(SvRV(gv))
2834                         : NULL;
2835                 if (!cv)
2836                     break;
2837                 if (CvLVALUE(cv))
2838                     break;
2839             }
2840         }
2841         /* FALLTHROUGH */
2842     default:
2843       nomod:
2844         if (flags & OP_LVALUE_NO_CROAK) return NULL;
2845         /* grep, foreach, subcalls, refgen */
2846         if (type == OP_GREPSTART || type == OP_ENTERSUB
2847          || type == OP_REFGEN    || type == OP_LEAVESUBLV)
2848             break;
2849         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2850                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
2851                       ? "do block"
2852                       : (o->op_type == OP_ENTERSUB
2853                         ? "non-lvalue subroutine call"
2854                         : OP_DESC(o))),
2855                      type ? PL_op_desc[type] : "local"));
2856         return o;
2857
2858     case OP_PREINC:
2859     case OP_PREDEC:
2860     case OP_POW:
2861     case OP_MULTIPLY:
2862     case OP_DIVIDE:
2863     case OP_MODULO:
2864     case OP_ADD:
2865     case OP_SUBTRACT:
2866     case OP_CONCAT:
2867     case OP_LEFT_SHIFT:
2868     case OP_RIGHT_SHIFT:
2869     case OP_BIT_AND:
2870     case OP_BIT_XOR:
2871     case OP_BIT_OR:
2872     case OP_I_MULTIPLY:
2873     case OP_I_DIVIDE:
2874     case OP_I_MODULO:
2875     case OP_I_ADD:
2876     case OP_I_SUBTRACT:
2877         if (!(o->op_flags & OPf_STACKED))
2878             goto nomod;
2879         PL_modcount++;
2880         break;
2881
2882     case OP_REPEAT:
2883         if (o->op_flags & OPf_STACKED) {
2884             PL_modcount++;
2885             break;
2886         }
2887         if (!(o->op_private & OPpREPEAT_DOLIST))
2888             goto nomod;
2889         else {
2890             const I32 mods = PL_modcount;
2891             modkids(cBINOPo->op_first, type);
2892             if (type != OP_AASSIGN)
2893                 goto nomod;
2894             kid = cBINOPo->op_last;
2895             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
2896                 const IV iv = SvIV(kSVOP_sv);
2897                 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
2898                     PL_modcount =
2899                         mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
2900             }
2901             else
2902                 PL_modcount = RETURN_UNLIMITED_NUMBER;
2903         }
2904         break;
2905
2906     case OP_COND_EXPR:
2907         localize = 1;
2908         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2909             op_lvalue(kid, type);
2910         break;
2911
2912     case OP_RV2AV:
2913     case OP_RV2HV:
2914         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
2915            PL_modcount = RETURN_UNLIMITED_NUMBER;
2916             return o;           /* Treat \(@foo) like ordinary list. */
2917         }
2918         /* FALLTHROUGH */
2919     case OP_RV2GV:
2920         if (scalar_mod_type(o, type))
2921             goto nomod;
2922         ref(cUNOPo->op_first, o->op_type);
2923         /* FALLTHROUGH */
2924     case OP_ASLICE:
2925     case OP_HSLICE:
2926         localize = 1;
2927         /* FALLTHROUGH */
2928     case OP_AASSIGN:
2929         /* Do not apply the lvsub flag for rv2[ah]v in scalar context.  */
2930         if (type == OP_LEAVESUBLV && (
2931                 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
2932              || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2933            ))
2934             o->op_private |= OPpMAYBE_LVSUB;
2935         /* FALLTHROUGH */
2936     case OP_NEXTSTATE:
2937     case OP_DBSTATE:
2938        PL_modcount = RETURN_UNLIMITED_NUMBER;
2939         break;
2940     case OP_KVHSLICE:
2941     case OP_KVASLICE:
2942         if (type == OP_LEAVESUBLV)
2943             o->op_private |= OPpMAYBE_LVSUB;
2944         goto nomod;
2945     case OP_AV2ARYLEN:
2946         PL_hints |= HINT_BLOCK_SCOPE;
2947         if (type == OP_LEAVESUBLV)
2948             o->op_private |= OPpMAYBE_LVSUB;
2949         PL_modcount++;
2950         break;
2951     case OP_RV2SV:
2952         ref(cUNOPo->op_first, o->op_type);
2953         localize = 1;
2954         /* FALLTHROUGH */
2955     case OP_GV:
2956         PL_hints |= HINT_BLOCK_SCOPE;
2957         /* FALLTHROUGH */
2958     case OP_SASSIGN:
2959     case OP_ANDASSIGN:
2960     case OP_ORASSIGN:
2961     case OP_DORASSIGN:
2962         PL_modcount++;
2963         break;
2964
2965     case OP_AELEMFAST:
2966     case OP_AELEMFAST_LEX:
2967         localize = -1;
2968         PL_modcount++;
2969         break;
2970
2971     case OP_PADAV:
2972     case OP_PADHV:
2973        PL_modcount = RETURN_UNLIMITED_NUMBER;
2974         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
2975             return o;           /* Treat \(@foo) like ordinary list. */
2976         if (scalar_mod_type(o, type))
2977             goto nomod;
2978         if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2979           && type == OP_LEAVESUBLV)
2980             o->op_private |= OPpMAYBE_LVSUB;
2981         /* FALLTHROUGH */
2982     case OP_PADSV:
2983         PL_modcount++;
2984         if (!type) /* local() */
2985             Perl_croak(aTHX_ "Can't localize lexical variable %"PNf,
2986                               PNfARG(PAD_COMPNAME(o->op_targ)));
2987         if (!(o->op_private & OPpLVAL_INTRO)
2988          || (  type != OP_SASSIGN && type != OP_AASSIGN
2989             && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ))  ))
2990             S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
2991         break;
2992
2993     case OP_PUSHMARK:
2994         localize = 0;
2995         break;
2996
2997     case OP_KEYS:
2998         if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
2999             goto nomod;
3000         goto lvalue_func;
3001     case OP_SUBSTR:
3002         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
3003             goto nomod;
3004         /* FALLTHROUGH */
3005     case OP_POS:
3006     case OP_VEC:
3007       lvalue_func:
3008         if (type == OP_LEAVESUBLV)
3009             o->op_private |= OPpMAYBE_LVSUB;
3010         if (o->op_flags & OPf_KIDS)
3011             op_lvalue(OpSIBLING(cBINOPo->op_first), type);
3012         break;
3013
3014     case OP_AELEM:
3015     case OP_HELEM:
3016         ref(cBINOPo->op_first, o->op_type);
3017         if (type == OP_ENTERSUB &&
3018              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
3019             o->op_private |= OPpLVAL_DEFER;
3020         if (type == OP_LEAVESUBLV)
3021             o->op_private |= OPpMAYBE_LVSUB;
3022         localize = 1;
3023         PL_modcount++;
3024         break;
3025
3026     case OP_LEAVE:
3027     case OP_LEAVELOOP:
3028         o->op_private |= OPpLVALUE;
3029         /* FALLTHROUGH */
3030     case OP_SCOPE:
3031     case OP_ENTER:
3032     case OP_LINESEQ:
3033         localize = 0;
3034         if (o->op_flags & OPf_KIDS)
3035             op_lvalue(cLISTOPo->op_last, type);
3036         break;
3037
3038     case OP_NULL:
3039         localize = 0;
3040         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
3041             goto nomod;
3042         else if (!(o->op_flags & OPf_KIDS))
3043             break;
3044         if (o->op_targ != OP_LIST) {
3045             op_lvalue(cBINOPo->op_first, type);
3046             break;
3047         }
3048         /* FALLTHROUGH */
3049     case OP_LIST:
3050         localize = 0;
3051         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3052             /* elements might be in void context because the list is
3053                in scalar context or because they are attribute sub calls */
3054             if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
3055                 op_lvalue(kid, type);
3056         break;
3057
3058     case OP_COREARGS:
3059         return o;
3060
3061     case OP_AND:
3062     case OP_OR:
3063         if (type == OP_LEAVESUBLV
3064          || !S_vivifies(cLOGOPo->op_first->op_type))
3065             op_lvalue(cLOGOPo->op_first, type);
3066         if (type == OP_LEAVESUBLV
3067          || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
3068             op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
3069         goto nomod;
3070
3071     case OP_SREFGEN:
3072         if (type != OP_AASSIGN && type != OP_SASSIGN
3073          && type != OP_ENTERLOOP)
3074             goto nomod;
3075         /* Don’t bother applying lvalue context to the ex-list.  */
3076         kid = cUNOPx(cUNOPo->op_first)->op_first;
3077         assert (!OpHAS_SIBLING(kid));
3078         goto kid_2lvref;
3079     case OP_REFGEN:
3080         if (type != OP_AASSIGN) goto nomod;
3081         kid = cUNOPo->op_first;
3082       kid_2lvref:
3083         {
3084             const U8 ec = PL_parser ? PL_parser->error_count : 0;
3085             S_lvref(aTHX_ kid, type);
3086             if (!PL_parser || PL_parser->error_count == ec) {
3087                 if (!FEATURE_REFALIASING_IS_ENABLED)
3088                     Perl_croak(aTHX_
3089                        "Experimental aliasing via reference not enabled");
3090                 Perl_ck_warner_d(aTHX_
3091                                  packWARN(WARN_EXPERIMENTAL__REFALIASING),
3092                                 "Aliasing via reference is experimental");
3093             }
3094         }
3095         if (o->op_type == OP_REFGEN)
3096             op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
3097         op_null(o);
3098         return o;
3099
3100     case OP_SPLIT:
3101         kid = cLISTOPo->op_first;
3102         if (kid && kid->op_type == OP_PUSHRE &&
3103                 (  kid->op_targ
3104                 || o->op_flags & OPf_STACKED
3105 #ifdef USE_ITHREADS
3106                 || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
3107 #else
3108                 || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
3109 #endif
3110         )) {
3111             /* This is actually @array = split.  */
3112             PL_modcount = RETURN_UNLIMITED_NUMBER;
3113             break;
3114         }
3115         goto nomod;
3116
3117     case OP_SCALAR:
3118         op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
3119         goto nomod;
3120     }
3121
3122     /* [20011101.069] File test operators interpret OPf_REF to mean that
3123        their argument is a filehandle; thus \stat(".") should not set
3124        it. AMS 20011102 */
3125     if (type == OP_REFGEN &&
3126         PL_check[o->op_type] == Perl_ck_ftst)
3127         return o;
3128
3129     if (type != OP_LEAVESUBLV)
3130         o->op_flags |= OPf_MOD;
3131
3132     if (type == OP_AASSIGN || type == OP_SASSIGN)
3133         o->op_flags |= OPf_SPECIAL|OPf_REF;
3134     else if (!type) { /* local() */
3135         switch (localize) {
3136         case 1:
3137             o->op_private |= OPpLVAL_INTRO;
3138             o->op_flags &= ~OPf_SPECIAL;
3139             PL_hints |= HINT_BLOCK_SCOPE;
3140             break;
3141         case 0:
3142             break;
3143         case -1:
3144             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
3145                            "Useless localization of %s", OP_DESC(o));
3146         }
3147     }
3148     else if (type != OP_GREPSTART && type != OP_ENTERSUB
3149              && type != OP_LEAVESUBLV)
3150         o->op_flags |= OPf_REF;
3151     return o;
3152 }
3153
3154 STATIC bool
3155 S_scalar_mod_type(const OP *o, I32 type)
3156 {
3157     switch (type) {
3158     case OP_POS:
3159     case OP_SASSIGN:
3160         if (o && o->op_type == OP_RV2GV)
3161             return FALSE;
3162         /* FALLTHROUGH */
3163     case OP_PREINC:
3164     case OP_PREDEC:
3165     case OP_POSTINC:
3166     case OP_POSTDEC:
3167     case OP_I_PREINC:
3168     case OP_I_PREDEC:
3169     case OP_I_POSTINC:
3170     case OP_I_POSTDEC:
3171     case OP_POW:
3172     case OP_MULTIPLY:
3173     case OP_DIVIDE:
3174     case OP_MODULO:
3175     case OP_REPEAT:
3176     case OP_ADD:
3177     case OP_SUBTRACT:
3178     case OP_I_MULTIPLY:
3179     case OP_I_DIVIDE:
3180     case OP_I_MODULO:
3181     case OP_I_ADD:
3182     case OP_I_SUBTRACT:
3183     case OP_LEFT_SHIFT:
3184     case OP_RIGHT_SHIFT:
3185     case OP_BIT_AND:
3186     case OP_BIT_XOR:
3187     case OP_BIT_OR:
3188     case OP_CONCAT:
3189     case OP_SUBST:
3190     case OP_TRANS:
3191     case OP_TRANSR:
3192     case OP_READ:
3193     case OP_SYSREAD:
3194     case OP_RECV:
3195     case OP_ANDASSIGN:
3196     case OP_ORASSIGN:
3197     case OP_DORASSIGN:
3198         return TRUE;
3199     default:
3200         return FALSE;
3201     }
3202 }
3203
3204 STATIC bool
3205 S_is_handle_constructor(const OP *o, I32 numargs)
3206 {
3207     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
3208
3209     switch (o->op_type) {
3210     case OP_PIPE_OP:
3211     case OP_SOCKPAIR:
3212         if (numargs == 2)
3213             return TRUE;
3214         /* FALLTHROUGH */
3215     case OP_SYSOPEN:
3216     case OP_OPEN:
3217     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
3218     case OP_SOCKET:
3219     case OP_OPEN_DIR:
3220     case OP_ACCEPT:
3221         if (numargs == 1)
3222             return TRUE;
3223         /* FALLTHROUGH */
3224     default:
3225         return FALSE;
3226     }
3227 }
3228
3229 static OP *
3230 S_refkids(pTHX_ OP *o, I32 type)
3231 {
3232     if (o && o->op_flags & OPf_KIDS) {
3233         OP *kid;
3234         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3235             ref(kid, type);
3236     }
3237     return o;
3238 }
3239
3240 OP *
3241 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
3242 {
3243     dVAR;
3244     OP *kid;
3245
3246     PERL_ARGS_ASSERT_DOREF;
3247
3248     if (PL_parser && PL_parser->error_count)
3249         return o;
3250
3251     switch (o->op_type) {
3252     case OP_ENTERSUB:
3253         if ((type == OP_EXISTS || type == OP_DEFINED) &&
3254             !(o->op_flags & OPf_STACKED)) {
3255             OpTYPE_set(o, OP_RV2CV);             /* entersub => rv2cv */
3256             assert(cUNOPo->op_first->op_type == OP_NULL);
3257             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
3258             o->op_flags |= OPf_SPECIAL;
3259         }
3260         else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
3261             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3262                               : type == OP_RV2HV ? OPpDEREF_HV
3263                               : OPpDEREF_SV);
3264             o->op_flags |= OPf_MOD;
3265         }
3266
3267         break;
3268
3269     case OP_COND_EXPR:
3270         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
3271             doref(kid, type, set_op_ref);
3272         break;
3273     case OP_RV2SV:
3274         if (type == OP_DEFINED)
3275             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
3276         doref(cUNOPo->op_first, o->op_type, set_op_ref);
3277         /* FALLTHROUGH */
3278     case OP_PADSV:
3279         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3280             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3281                               : type == OP_RV2HV ? OPpDEREF_HV
3282                               : OPpDEREF_SV);
3283             o->op_flags |= OPf_MOD;
3284         }
3285         break;
3286
3287     case OP_RV2AV:
3288     case OP_RV2HV:
3289         if (set_op_ref)
3290             o->op_flags |= OPf_REF;
3291         /* FALLTHROUGH */
3292     case OP_RV2GV:
3293         if (type == OP_DEFINED)
3294             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
3295         doref(cUNOPo->op_first, o->op_type, set_op_ref);
3296         break;
3297
3298     case OP_PADAV:
3299     case OP_PADHV:
3300         if (set_op_ref)
3301             o->op_flags |= OPf_REF;
3302         break;
3303
3304     case OP_SCALAR:
3305     case OP_NULL:
3306         if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
3307             break;
3308         doref(cBINOPo->op_first, type, set_op_ref);
3309         break;
3310     case OP_AELEM:
3311     case OP_HELEM:
3312         doref(cBINOPo->op_first, o->op_type, set_op_ref);
3313         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3314             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3315                               : type == OP_RV2HV ? OPpDEREF_HV
3316                               : OPpDEREF_SV);
3317             o->op_flags |= OPf_MOD;
3318         }
3319         break;
3320
3321     case OP_SCOPE:
3322     case OP_LEAVE:
3323         set_op_ref = FALSE;
3324         /* FALLTHROUGH */
3325     case OP_ENTER:
3326     case OP_LIST:
3327         if (!(o->op_flags & OPf_KIDS))
3328             break;
3329         doref(cLISTOPo->op_last, type, set_op_ref);
3330         break;
3331     default:
3332         break;
3333     }
3334     return scalar(o);
3335
3336 }
3337
3338 STATIC OP *
3339 S_dup_attrlist(pTHX_ OP *o)
3340 {
3341     OP *rop;
3342
3343     PERL_ARGS_ASSERT_DUP_ATTRLIST;
3344
3345     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
3346      * where the first kid is OP_PUSHMARK and the remaining ones
3347      * are OP_CONST.  We need to push the OP_CONST values.
3348      */
3349     if (o->op_type == OP_CONST)
3350         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
3351     else {
3352         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
3353         rop = NULL;
3354         for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
3355             if (o->op_type == OP_CONST)
3356                 rop = op_append_elem(OP_LIST, rop,
3357                                   newSVOP(OP_CONST, o->op_flags,
3358                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
3359         }
3360     }
3361     return rop;
3362 }
3363
3364 STATIC void
3365 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
3366 {
3367     PERL_ARGS_ASSERT_APPLY_ATTRS;
3368     {
3369         SV * const stashsv = newSVhek(HvNAME_HEK(stash));
3370
3371         /* fake up C<use attributes $pkg,$rv,@attrs> */
3372
3373 #define ATTRSMODULE "attributes"
3374 #define ATTRSMODULE_PM "attributes.pm"
3375
3376         Perl_load_module(
3377           aTHX_ PERL_LOADMOD_IMPORT_OPS,
3378           newSVpvs(ATTRSMODULE),
3379           NULL,
3380           op_prepend_elem(OP_LIST,
3381                           newSVOP(OP_CONST, 0, stashsv),
3382                           op_prepend_elem(OP_LIST,
3383                                           newSVOP(OP_CONST, 0,
3384                                                   newRV(target)),
3385                                           dup_attrlist(attrs))));
3386     }
3387 }
3388
3389 STATIC void
3390 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
3391 {
3392     OP *pack, *imop, *arg;
3393     SV *meth, *stashsv, **svp;
3394
3395     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
3396
3397     if (!attrs)
3398         return;
3399
3400     assert(target->op_type == OP_PADSV ||
3401            target->op_type == OP_PADHV ||
3402            target->op_type == OP_PADAV);
3403
3404     /* Ensure that attributes.pm is loaded. */
3405     /* Don't force the C<use> if we don't need it. */
3406     svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
3407     if (svp && *svp != &PL_sv_undef)
3408         NOOP;   /* already in %INC */
3409     else
3410         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
3411                                newSVpvs(ATTRSMODULE), NULL);
3412
3413     /* Need package name for method call. */
3414     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
3415
3416     /* Build up the real arg-list. */
3417     stashsv = newSVhek(HvNAME_HEK(stash));
3418
3419     arg = newOP(OP_PADSV, 0);
3420     arg->op_targ = target->op_targ;
3421     arg = op_prepend_elem(OP_LIST,
3422                        newSVOP(OP_CONST, 0, stashsv),
3423                        op_prepend_elem(OP_LIST,
3424                                     newUNOP(OP_REFGEN, 0,
3425                                             arg),
3426                                     dup_attrlist(attrs)));
3427
3428     /* Fake up a method call to import */
3429     meth = newSVpvs_share("import");
3430     imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
3431                    op_append_elem(OP_LIST,
3432                                op_prepend_elem(OP_LIST, pack, arg),
3433                                newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
3434
3435     /* Combine the ops. */
3436     *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
3437 }
3438
3439 /*
3440 =notfor apidoc apply_attrs_string
3441
3442 Attempts to apply a list of attributes specified by the C<attrstr> and
3443 C<len> arguments to the subroutine identified by the C<cv> argument which
3444 is expected to be associated with the package identified by the C<stashpv>
3445 argument (see L<attributes>).  It gets this wrong, though, in that it
3446 does not correctly identify the boundaries of the individual attribute
3447 specifications within C<attrstr>.  This is not really intended for the
3448 public API, but has to be listed here for systems such as AIX which
3449 need an explicit export list for symbols.  (It's called from XS code
3450 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
3451 to respect attribute syntax properly would be welcome.
3452
3453 =cut
3454 */
3455
3456 void
3457 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
3458                         const char *attrstr, STRLEN len)
3459 {
3460     OP *attrs = NULL;
3461
3462     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
3463
3464     if (!len) {
3465         len = strlen(attrstr);
3466     }
3467
3468     while (len) {
3469         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
3470         if (len) {
3471             const char * const sstr = attrstr;
3472             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
3473             attrs = op_append_elem(OP_LIST, attrs,
3474                                 newSVOP(OP_CONST, 0,
3475                                         newSVpvn(sstr, attrstr-sstr)));
3476         }
3477     }
3478
3479     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3480                      newSVpvs(ATTRSMODULE),
3481                      NULL, op_prepend_elem(OP_LIST,
3482                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
3483                                   op_prepend_elem(OP_LIST,
3484                                                newSVOP(OP_CONST, 0,
3485                                                        newRV(MUTABLE_SV(cv))),
3486                                                attrs)));
3487 }
3488
3489 STATIC void
3490 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
3491 {
3492     OP *new_proto = NULL;
3493     STRLEN pvlen;
3494     char *pv;
3495     OP *o;
3496
3497     PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
3498
3499     if (!*attrs)
3500         return;
3501
3502     o = *attrs;
3503     if (o->op_type == OP_CONST) {
3504         pv = SvPV(cSVOPo_sv, pvlen);
3505         if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3506             SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3507             SV ** const tmpo = cSVOPx_svp(o);
3508             SvREFCNT_dec(cSVOPo_sv);
3509             *tmpo = tmpsv;
3510             new_proto = o;
3511             *attrs = NULL;
3512         }
3513     } else if (o->op_type == OP_LIST) {
3514         OP * lasto;
3515         assert(o->op_flags & OPf_KIDS);
3516         lasto = cLISTOPo->op_first;
3517         assert(lasto->op_type == OP_PUSHMARK);
3518         for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
3519             if (o->op_type == OP_CONST) {
3520                 pv = SvPV(cSVOPo_sv, pvlen);
3521                 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3522                     SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3523                     SV ** const tmpo = cSVOPx_svp(o);
3524                     SvREFCNT_dec(cSVOPo_sv);
3525                     *tmpo = tmpsv;
3526                     if (new_proto && ckWARN(WARN_MISC)) {
3527                         STRLEN new_len;
3528                         const char * newp = SvPV(cSVOPo_sv, new_len);
3529                         Perl_warner(aTHX_ packWARN(WARN_MISC),
3530                             "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub",
3531                             UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
3532                         op_free(new_proto);
3533                     }
3534                     else if (new_proto)
3535                         op_free(new_proto);
3536                     new_proto = o;
3537                     /* excise new_proto from the list */
3538                     op_sibling_splice(*attrs, lasto, 1, NULL);
3539                     o = lasto;
3540                     continue;
3541                 }
3542             }
3543             lasto = o;
3544         }
3545         /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
3546            would get pulled in with no real need */
3547         if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
3548             op_free(*attrs);
3549             *attrs = NULL;
3550         }
3551     }
3552
3553     if (new_proto) {
3554         SV *svname;
3555         if (isGV(name)) {
3556             svname = sv_newmortal();
3557             gv_efullname3(svname, name, NULL);
3558         }
3559         else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
3560             svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
3561         else
3562             svname = (SV *)name;
3563         if (ckWARN(WARN_ILLEGALPROTO))
3564             (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
3565         if (*proto && ckWARN(WARN_PROTOTYPE)) {
3566             STRLEN old_len, new_len;
3567             const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
3568             const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
3569
3570             Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3571                 "Prototype '%"UTF8f"' overridden by attribute 'prototype(%"UTF8f")'"
3572                 " in %"SVf,
3573                 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
3574                 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
3575                 SVfARG(svname));
3576         }
3577         if (*proto)
3578             op_free(*proto);
3579         *proto = new_proto;
3580     }
3581 }
3582
3583 static void
3584 S_cant_declare(pTHX_ OP *o)
3585 {
3586     if (o->op_type == OP_NULL
3587      && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
3588         o = cUNOPo->op_first;
3589     yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
3590                              o->op_type == OP_NULL
3591                                && o->op_flags & OPf_SPECIAL
3592                                  ? "do block"
3593                                  : OP_DESC(o),
3594                              PL_parser->in_my == KEY_our   ? "our"   :
3595                              PL_parser->in_my == KEY_state ? "state" :
3596                                                              "my"));
3597 }
3598
3599 STATIC OP *
3600 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
3601 {
3602     I32 type;
3603     const bool stately = PL_parser && PL_parser->in_my == KEY_state;
3604
3605     PERL_ARGS_ASSERT_MY_KID;
3606
3607     if (!o || (PL_parser && PL_parser->error_count))
3608         return o;
3609
3610     type = o->op_type;
3611
3612     if (type == OP_LIST) {
3613         OP *kid;
3614         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3615             my_kid(kid, attrs, imopsp);
3616         return o;
3617     } else if (type == OP_UNDEF || type == OP_STUB) {
3618         return o;
3619     } else if (type == OP_RV2SV ||      /* "our" declaration */
3620                type == OP_RV2AV ||
3621                type == OP_RV2HV) { /* XXX does this let anything illegal in? */
3622         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
3623             S_cant_declare(aTHX_ o);
3624         } else if (attrs) {
3625             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
3626             assert(PL_parser);
3627             PL_parser->in_my = FALSE;
3628             PL_parser->in_my_stash = NULL;
3629             apply_attrs(GvSTASH(gv),
3630                         (type == OP_RV2SV ? GvSV(gv) :
3631                          type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
3632                          type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
3633                         attrs);
3634         }
3635         o->op_private |= OPpOUR_INTRO;
3636         return o;
3637     }
3638     else if (type != OP_PADSV &&
3639              type != OP_PADAV &&
3640              type != OP_PADHV &&
3641              type != OP_PUSHMARK)
3642     {
3643         S_cant_declare(aTHX_ o);
3644         return o;
3645     }
3646     else if (attrs && type != OP_PUSHMARK) {
3647         HV *stash;
3648
3649         assert(PL_parser);
3650         PL_parser->in_my = FALSE;
3651         PL_parser->in_my_stash = NULL;
3652
3653         /* check for C<my Dog $spot> when deciding package */
3654         stash = PAD_COMPNAME_TYPE(o->op_targ);
3655         if (!stash)
3656             stash = PL_curstash;
3657         apply_attrs_my(stash, o, attrs, imopsp);
3658     }
3659     o->op_flags |= OPf_MOD;
3660     o->op_private |= OPpLVAL_INTRO;
3661     if (stately)
3662         o->op_private |= OPpPAD_STATE;
3663     return o;
3664 }
3665
3666 OP *
3667 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
3668 {
3669     OP *rops;
3670     int maybe_scalar = 0;
3671
3672     PERL_ARGS_ASSERT_MY_ATTRS;
3673
3674 /* [perl #17376]: this appears to be premature, and results in code such as
3675    C< our(%x); > executing in list mode rather than void mode */
3676 #if 0
3677     if (o->op_flags & OPf_PARENS)
3678         list(o);
3679     else
3680         maybe_scalar = 1;
3681 #else
3682     maybe_scalar = 1;
3683 #endif
3684     if (attrs)
3685         SAVEFREEOP(attrs);
3686     rops = NULL;
3687     o = my_kid(o, attrs, &rops);
3688     if (rops) {
3689         if (maybe_scalar && o->op_type == OP_PADSV) {
3690             o = scalar(op_append_list(OP_LIST, rops, o));
3691             o->op_private |= OPpLVAL_INTRO;
3692         }
3693         else {
3694             /* The listop in rops might have a pushmark at the beginning,
3695                which will mess up list assignment. */
3696             LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
3697             if (rops->op_type == OP_LIST &&
3698                 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
3699             {
3700                 OP * const pushmark = lrops->op_first;
3701                 /* excise pushmark */
3702                 op_sibling_splice(rops, NULL, 1, NULL);
3703                 op_free(pushmark);
3704             }
3705             o = op_append_list(OP_LIST, o, rops);
3706         }
3707     }
3708     PL_parser->in_my = FALSE;
3709     PL_parser->in_my_stash = NULL;
3710     return o;
3711 }
3712
3713 OP *
3714 Perl_sawparens(pTHX_ OP *o)
3715 {
3716     PERL_UNUSED_CONTEXT;
3717     if (o)
3718         o->op_flags |= OPf_PARENS;
3719     return o;
3720 }
3721
3722 OP *
3723 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
3724 {
3725     OP *o;
3726     bool ismatchop = 0;
3727     const OPCODE ltype = left->op_type;
3728     const OPCODE rtype = right->op_type;
3729
3730     PERL_ARGS_ASSERT_BIND_MATCH;
3731
3732     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
3733           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
3734     {
3735       const char * const desc
3736           = PL_op_desc[(
3737                           rtype == OP_SUBST || rtype == OP_TRANS
3738                        || rtype == OP_TRANSR
3739                        )
3740                        ? (int)rtype : OP_MATCH];
3741       const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
3742       SV * const name =
3743         S_op_varname(aTHX_ left);
3744       if (name)
3745         Perl_warner(aTHX_ packWARN(WARN_MISC),
3746              "Applying %s to %"SVf" will act on scalar(%"SVf")",
3747              desc, SVfARG(name), SVfARG(name));
3748       else {
3749         const char * const sample = (isary
3750              ? "@array" : "%hash");
3751         Perl_warner(aTHX_ packWARN(WARN_MISC),
3752              "Applying %s to %s will act on scalar(%s)",
3753              desc, sample, sample);
3754       }
3755     }
3756
3757     if (rtype == OP_CONST &&
3758         cSVOPx(right)->op_private & OPpCONST_BARE &&
3759         cSVOPx(right)->op_private & OPpCONST_STRICT)
3760     {
3761         no_bareword_allowed(right);
3762     }
3763
3764     /* !~ doesn't make sense with /r, so error on it for now */
3765     if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
3766         type == OP_NOT)
3767         /* diag_listed_as: Using !~ with %s doesn't make sense */
3768         yyerror("Using !~ with s///r doesn't make sense");
3769     if (rtype == OP_TRANSR && type == OP_NOT)
3770         /* diag_listed_as: Using !~ with %s doesn't make sense */
3771         yyerror("Using !~ with tr///r doesn't make sense");
3772
3773     ismatchop = (rtype == OP_MATCH ||
3774                  rtype == OP_SUBST ||
3775                  rtype == OP_TRANS || rtype == OP_TRANSR)
3776              && !(right->op_flags & OPf_SPECIAL);
3777     if (ismatchop && right->op_private & OPpTARGET_MY) {
3778         right->op_targ = 0;
3779         right->op_private &= ~OPpTARGET_MY;
3780     }
3781     if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
3782         if (left->op_type == OP_PADSV
3783          && !(left->op_private & OPpLVAL_INTRO))
3784         {
3785             right->op_targ = left->op_targ;
3786             op_free(left);
3787             o = right;
3788         }
3789         else {
3790             right->op_flags |= OPf_STACKED;
3791             if (rtype != OP_MATCH && rtype != OP_TRANSR &&
3792             ! (rtype == OP_TRANS &&
3793                right->op_private & OPpTRANS_IDENTICAL) &&
3794             ! (rtype == OP_SUBST &&
3795                (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3796                 left = op_lvalue(left, rtype);
3797             if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
3798                 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
3799             else
3800                 o = op_prepend_elem(rtype, scalar(left), right);
3801         }
3802         if (type == OP_NOT)
3803             return newUNOP(OP_NOT, 0, scalar(o));
3804         return o;
3805     }
3806     else
3807         return bind_match(type, left,
3808                 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
3809 }
3810
3811 OP *
3812 Perl_invert(pTHX_ OP *o)
3813 {
3814     if (!o)
3815         return NULL;
3816     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
3817 }
3818
3819 /*
3820 =for apidoc Amx|OP *|op_scope|OP *o
3821
3822 Wraps up an op tree with some additional ops so that at runtime a dynamic
3823 scope will be created.  The original ops run in the new dynamic scope,
3824 and then, provided that they exit normally, the scope will be unwound.
3825 The additional ops used to create and unwind the dynamic scope will
3826 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
3827 instead if the ops are simple enough to not need the full dynamic scope
3828 structure.
3829
3830 =cut
3831 */
3832
3833 OP *
3834 Perl_op_scope(pTHX_ OP *o)
3835 {
3836     dVAR;
3837     if (o) {
3838         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
3839             o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
3840             OpTYPE_set(o, OP_LEAVE);
3841         }
3842         else if (o->op_type == OP_LINESEQ) {
3843             OP *kid;
3844             OpTYPE_set(o, OP_SCOPE);
3845             kid = ((LISTOP*)o)->op_first;
3846             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
3847                 op_null(kid);
3848
3849                 /* The following deals with things like 'do {1 for 1}' */
3850                 kid = OpSIBLING(kid);
3851                 if (kid &&
3852                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
3853                     op_null(kid);
3854             }
3855         }
3856         else
3857             o = newLISTOP(OP_SCOPE, 0, o, NULL);
3858     }
3859     return o;
3860 }
3861
3862 OP *
3863 Perl_op_unscope(pTHX_ OP *o)
3864 {
3865     if (o && o->op_type == OP_LINESEQ) {
3866         OP *kid = cLISTOPo->op_first;
3867         for(; kid; kid = OpSIBLING(kid))
3868             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
3869                 op_null(kid);
3870     }
3871     return o;
3872 }
3873
3874 /*
3875 =for apidoc Am|int|block_start|int full
3876
3877 Handles compile-time scope entry.
3878 Arranges for hints to be restored on block
3879 exit and also handles pad sequence numbers to make lexical variables scope
3880 right.  Returns a savestack index for use with C<block_end>.
3881
3882 =cut
3883 */
3884
3885 int
3886 Perl_block_start(pTHX_ int full)
3887 {
3888     const int retval = PL_savestack_ix;
3889
3890     PL_compiling.cop_seq = PL_cop_seqmax;
3891     COP_SEQMAX_INC;
3892     pad_block_start(full);
3893     SAVEHINTS();
3894     PL_hints &= ~HINT_BLOCK_SCOPE;
3895     SAVECOMPILEWARNINGS();
3896     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
3897     SAVEI32(PL_compiling.cop_seq);
3898     PL_compiling.cop_seq = 0;
3899
3900     CALL_BLOCK_HOOKS(bhk_start, full);
3901
3902     return retval;
3903 }
3904
3905 /*
3906 =for apidoc Am|OP *|block_end|I32 floor|OP *seq
3907
3908 Handles compile-time scope exit.  C<floor>
3909 is the savestack index returned by
3910 C<block_start>, and C<seq> is the body of the block.  Returns the block,
3911 possibly modified.
3912
3913 =cut
3914 */
3915
3916 OP*
3917 Perl_block_end(pTHX_ I32 floor, OP *seq)
3918 {
3919     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
3920     OP* retval = scalarseq(seq);
3921     OP *o;
3922
3923     /* XXX Is the null PL_parser check necessary here? */
3924     assert(PL_parser); /* Let’s find out under debugging builds.  */
3925     if (PL_parser && PL_parser->parsed_sub) {
3926         o = newSTATEOP(0, NULL, NULL);
3927         op_null(o);
3928         retval = op_append_elem(OP_LINESEQ, retval, o);
3929     }
3930
3931     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
3932
3933     LEAVE_SCOPE(floor);
3934     if (needblockscope)
3935         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
3936     o = pad_leavemy();
3937
3938     if (o) {
3939         /* pad_leavemy has created a sequence of introcv ops for all my
3940            subs declared in the block.  We have to replicate that list with
3941            clonecv ops, to deal with this situation:
3942
3943                sub {
3944                    my sub s1;
3945                    my sub s2;
3946                    sub s1 { state sub foo { \&s2 } }
3947                }->()
3948
3949            Originally, I was going to have introcv clone the CV and turn
3950            off the stale flag.  Since &s1 is declared before &s2, the
3951            introcv op for &s1 is executed (on sub entry) before the one for
3952            &s2.  But the &foo sub inside &s1 (which is cloned when &s1 is
3953            cloned, since it is a state sub) closes over &s2 and expects
3954            to see it in its outer CV’s pad.  If the introcv op clones &s1,
3955            then &s2 is still marked stale.  Since &s1 is not active, and
3956            &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
3957            ble will not stay shared’ warning.  Because it is the same stub
3958            that will be used when the introcv op for &s2 is executed, clos-
3959            ing over it is safe.  Hence, we have to turn off the stale flag
3960            on all lexical subs in the block before we clone any of them.
3961            Hence, having introcv clone the sub cannot work.  So we create a
3962            list of ops like this:
3963
3964                lineseq
3965                   |
3966                   +-- introcv
3967                   |
3968                   +-- introcv
3969                   |
3970                   +-- introcv
3971                   |
3972                   .
3973                   .
3974                   .
3975                   |
3976                   +-- clonecv
3977                   |
3978                   +-- clonecv
3979                   |
3980                   +-- clonecv
3981                   |
3982                   .
3983                   .
3984                   .
3985          */
3986         OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
3987         OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
3988         for (;; kid = OpSIBLING(kid)) {
3989             OP *newkid = newOP(OP_CLONECV, 0);
3990             newkid->op_targ = kid->op_targ;
3991             o = op_append_elem(OP_LINESEQ, o, newkid);
3992             if (kid == last) break;
3993         }
3994         retval = op_prepend_elem(OP_LINESEQ, o, retval);
3995     }
3996
3997     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
3998
3999     return retval;
4000 }
4001
4002 /*
4003 =head1 Compile-time scope hooks
4004
4005 =for apidoc Aox||blockhook_register
4006
4007 Register a set of hooks to be called when the Perl lexical scope changes
4008 at compile time.  See L<perlguts/"Compile-time scope hooks">.
4009
4010 =cut
4011 */
4012
4013 void
4014 Perl_blockhook_register(pTHX_ BHK *hk)
4015 {
4016     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
4017
4018     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
4019 }
4020
4021 void
4022 Perl_newPROG(pTHX_ OP *o)
4023 {
4024     PERL_ARGS_ASSERT_NEWPROG;
4025
4026     if (PL_in_eval) {
4027         PERL_CONTEXT *cx;
4028         I32 i;
4029         if (PL_eval_root)
4030                 return;
4031         PL_eval_root = newUNOP(OP_LEAVEEVAL,
4032                                ((PL_in_eval & EVAL_KEEPERR)
4033                                 ? OPf_SPECIAL : 0), o);
4034
4035         cx = &cxstack[cxstack_ix];
4036         assert(CxTYPE(cx) == CXt_EVAL);
4037
4038         if ((cx->blk_gimme & G_WANT) == G_VOID)
4039             scalarvoid(PL_eval_root);
4040         else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
4041             list(PL_eval_root);
4042         else
4043             scalar(PL_eval_root);
4044
4045         PL_eval_start = op_linklist(PL_eval_root);
4046         PL_eval_root->op_private |= OPpREFCOUNTED;
4047         OpREFCNT_set(PL_eval_root, 1);
4048         PL_eval_root->op_next = 0;
4049         i = PL_savestack_ix;
4050         SAVEFREEOP(o);
4051         ENTER;
4052         CALL_PEEP(PL_eval_start);
4053         finalize_optree(PL_eval_root);
4054         S_prune_chain_head(&PL_eval_start);
4055         LEAVE;
4056         PL_savestack_ix = i;
4057     }
4058     else {
4059         if (o->op_type == OP_STUB) {
4060             /* This block is entered if nothing is compiled for the main
4061                program. This will be the case for an genuinely empty main
4062                program, or one which only has BEGIN blocks etc, so already
4063                run and freed.
4064
4065                Historically (5.000) the guard above was !o. However, commit
4066                f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
4067                c71fccf11fde0068, changed perly.y so that newPROG() is now
4068                called with the output of block_end(), which returns a new
4069                OP_STUB for the case of an empty optree. ByteLoader (and
4070                maybe other things) also take this path, because they set up
4071                PL_main_start and PL_main_root directly, without generating an
4072                optree.
4073
4074                If the parsing the main program aborts (due to parse errors,
4075                or due to BEGIN or similar calling exit), then newPROG()
4076                isn't even called, and hence this code path and its cleanups
4077                are skipped. This shouldn't make a make a difference:
4078                * a non-zero return from perl_parse is a failure, and
4079                  perl_destruct() should be called immediately.
4080                * however, if exit(0) is called during the parse, then
4081                  perl_parse() returns 0, and perl_run() is called. As
4082                  PL_main_start will be NULL, perl_run() will return
4083                  promptly, and the exit code will remain 0.
4084             */
4085
4086             PL_comppad_name = 0;
4087             PL_compcv = 0;
4088             S_op_destroy(aTHX_ o);
4089             return;
4090         }
4091         PL_main_root = op_scope(sawparens(scalarvoid(o)));
4092         PL_curcop = &PL_compiling;
4093         PL_main_start = LINKLIST(PL_main_root);
4094         PL_main_root->op_private |= OPpREFCOUNTED;
4095         OpREFCNT_set(PL_main_root, 1);
4096         PL_main_root->op_next = 0;
4097         CALL_PEEP(PL_main_start);
4098         finalize_optree(PL_main_root);
4099         S_prune_chain_head(&PL_main_start);
4100         cv_forget_slab(PL_compcv);
4101         PL_compcv = 0;
4102
4103         /* Register with debugger */
4104         if (PERLDB_INTER) {
4105             CV * const cv = get_cvs("DB::postponed", 0);
4106             if (cv) {
4107                 dSP;
4108                 PUSHMARK(SP);
4109                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
4110                 PUTBACK;
4111                 call_sv(MUTABLE_SV(cv), G_DISCARD);
4112             }
4113         }
4114     }
4115 }
4116
4117 OP *
4118 Perl_localize(pTHX_ OP *o, I32 lex)
4119 {
4120     PERL_ARGS_ASSERT_LOCALIZE;
4121
4122     if (o->op_flags & OPf_PARENS)
4123 /* [perl #17376]: this appears to be premature, and results in code such as
4124    C< our(%x); > executing in list mode rather than void mode */
4125 #if 0
4126         list(o);
4127 #else
4128         NOOP;
4129 #endif
4130     else {
4131         if ( PL_parser->bufptr > PL_parser->oldbufptr
4132             && PL_parser->bufptr[-1] == ','
4133             && ckWARN(WARN_PARENTHESIS))
4134         {
4135             char *s = PL_parser->bufptr;
4136             bool sigil = FALSE;
4137
4138             /* some heuristics to detect a potential error */
4139             while (*s && (strchr(", \t\n", *s)))
4140                 s++;
4141
4142             while (1) {
4143                 if (*s && strchr("@$%*", *s) && *++s
4144                        && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
4145                     s++;
4146                     sigil = TRUE;
4147                     while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
4148                         s++;
4149                     while (*s && (strchr(", \t\n", *s)))
4150                         s++;
4151                 }
4152                 else
4153                     break;
4154             }
4155             if (sigil && (*s == ';' || *s == '=')) {
4156                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
4157                                 "Parentheses missing around \"%s\" list",
4158                                 lex
4159                                     ? (PL_parser->in_my == KEY_our
4160                                         ? "our"
4161                                         : PL_parser->in_my == KEY_state
4162                                             ? "state"
4163                                             : "my")
4164                                     : "local");
4165             }
4166         }
4167     }
4168     if (lex)
4169         o = my(o);
4170     else
4171         o = op_lvalue(o, OP_NULL);              /* a bit kludgey */
4172     PL_parser->in_my = FALSE;
4173     PL_parser->in_my_stash = NULL;
4174     return o;
4175 }
4176
4177 OP *
4178 Perl_jmaybe(pTHX_ OP *o)
4179 {
4180     PERL_ARGS_ASSERT_JMAYBE;
4181
4182     if (o->op_type == OP_LIST) {
4183         OP * const o2
4184             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
4185         o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
4186     }
4187     return o;
4188 }
4189
4190 PERL_STATIC_INLINE OP *
4191 S_op_std_init(pTHX_ OP *o)
4192 {
4193     I32 type = o->op_type;
4194
4195     PERL_ARGS_ASSERT_OP_STD_INIT;
4196
4197     if (PL_opargs[type] & OA_RETSCALAR)
4198         scalar(o);
4199     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
4200         o->op_targ = pad_alloc(type, SVs_PADTMP);
4201
4202     return o;
4203 }
4204
4205 PERL_STATIC_INLINE OP *
4206 S_op_integerize(pTHX_ OP *o)
4207 {
4208     I32 type = o->op_type;
4209
4210     PERL_ARGS_ASSERT_OP_INTEGERIZE;
4211
4212     /* integerize op. */
4213     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
4214     {
4215         dVAR;
4216         o->op_ppaddr = PL_ppaddr[++(o->op_type)];
4217     }
4218
4219     if (type == OP_NEGATE)
4220         /* XXX might want a ck_negate() for this */
4221         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
4222
4223     return o;
4224 }
4225
4226 static OP *
4227 S_fold_constants(pTHX_ OP *o)
4228 {
4229     dVAR;
4230     OP * VOL curop;
4231     OP *newop;
4232     VOL I32 type = o->op_type;
4233     bool is_stringify;
4234     SV * VOL sv = NULL;
4235     int ret = 0;
4236     I32 oldscope;
4237     OP *old_next;
4238     SV * const oldwarnhook = PL_warnhook;
4239     SV * const olddiehook  = PL_diehook;
4240     COP not_compiling;
4241     U8 oldwarn = PL_dowarn;
4242     dJMPENV;
4243
4244     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
4245
4246     if (!(PL_opargs[type] & OA_FOLDCONST))
4247         goto nope;
4248
4249     switch (type) {
4250     case OP_UCFIRST:
4251     case OP_LCFIRST:
4252     case OP_UC:
4253     case OP_LC:
4254     case OP_FC:
4255 #ifdef USE_LOCALE_CTYPE
4256         if (IN_LC_COMPILETIME(LC_CTYPE))
4257             goto nope;
4258 #endif
4259         break;
4260     case OP_SLT:
4261     case OP_SGT:
4262     case OP_SLE:
4263     case OP_SGE:
4264     case OP_SCMP:
4265 #ifdef USE_LOCALE_COLLATE
4266         if (IN_LC_COMPILETIME(LC_COLLATE))
4267             goto nope;
4268 #endif
4269         break;
4270     case OP_SPRINTF:
4271         /* XXX what about the numeric ops? */
4272 #ifdef USE_LOCALE_NUMERIC
4273         if (IN_LC_COMPILETIME(LC_NUMERIC))
4274             goto nope;
4275 #endif
4276         break;
4277     case OP_PACK:
4278         if (!OpHAS_SIBLING(cLISTOPo->op_first)
4279           || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
4280             goto nope;
4281         {
4282             SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
4283             if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
4284             {
4285                 const char *s = SvPVX_const(sv);
4286                 while (s < SvEND(sv)) {
4287                     if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
4288                     s++;
4289                 }
4290             }
4291         }
4292         break;
4293     case OP_REPEAT:
4294         if (o->op_private & OPpREPEAT_DOLIST) goto nope;
4295         break;
4296     case OP_SREFGEN:
4297         if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
4298          || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
4299             goto nope;
4300     }
4301
4302     if (PL_parser && PL_parser->error_count)
4303         goto nope;              /* Don't try to run w/ errors */
4304
4305     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4306         const OPCODE type = curop->op_type;
4307         if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
4308             type != OP_LIST &&
4309             type != OP_SCALAR &&
4310             type != OP_NULL &&
4311             type != OP_PUSHMARK)
4312         {
4313             goto nope;
4314         }
4315     }
4316
4317     curop = LINKLIST(o);
4318     old_next = o->op_next;
4319     o->op_next = 0;
4320     PL_op = curop;
4321
4322     oldscope = PL_scopestack_ix;
4323     create_eval_scope(G_FAKINGEVAL);
4324
4325     /* Verify that we don't need to save it:  */
4326     assert(PL_curcop == &PL_compiling);
4327     StructCopy(&PL_compiling, &not_compiling, COP);
4328     PL_curcop = &not_compiling;
4329     /* The above ensures that we run with all the correct hints of the
4330        currently compiling COP, but that IN_PERL_RUNTIME is true. */
4331     assert(IN_PERL_RUNTIME);
4332     PL_warnhook = PERL_WARNHOOK_FATAL;
4333     PL_diehook  = NULL;
4334     JMPENV_PUSH(ret);
4335
4336     /* Effective $^W=1.  */
4337     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
4338         PL_dowarn |= G_WARN_ON;
4339
4340     switch (ret) {
4341     case 0:
4342         CALLRUNOPS(aTHX);
4343         sv = *(PL_stack_sp--);
4344         if (o->op_targ && sv == PAD_SV(o->op_targ)) {   /* grab pad temp? */
4345             pad_swipe(o->op_targ,  FALSE);
4346         }
4347         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
4348             SvREFCNT_inc_simple_void(sv);
4349             SvTEMP_off(sv);
4350         }
4351         else { assert(SvIMMORTAL(sv)); }
4352         break;
4353     case 3:
4354         /* Something tried to die.  Abandon constant folding.  */
4355         /* Pretend the error never happened.  */
4356         CLEAR_ERRSV();
4357         o->op_next = old_next;
4358         break;
4359     default:
4360         JMPENV_POP;
4361         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
4362         PL_warnhook = oldwarnhook;
4363         PL_diehook  = olddiehook;
4364         /* XXX note that this croak may fail as we've already blown away
4365          * the stack - eg any nested evals */
4366         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
4367     }
4368     JMPENV_POP;
4369     PL_dowarn   = oldwarn;
4370     PL_warnhook = oldwarnhook;
4371     PL_diehook  = olddiehook;
4372     PL_curcop = &PL_compiling;
4373
4374     if (PL_scopestack_ix > oldscope)
4375         delete_eval_scope();
4376
4377     if (ret)
4378         goto nope;
4379
4380     /* OP_STRINGIFY and constant folding are used to implement qq.
4381        Here the constant folding is an implementation detail that we
4382        want to hide.  If the stringify op is itself already marked
4383        folded, however, then it is actually a folded join.  */
4384     is_stringify = type == OP_STRINGIFY && !o->op_folded;
4385     op_free(o);
4386     assert(sv);
4387     if (is_stringify)
4388         SvPADTMP_off(sv);
4389     else if (!SvIMMORTAL(sv)) {
4390         SvPADTMP_on(sv);
4391         SvREADONLY_on(sv);
4392     }
4393     newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
4394     if (!is_stringify) newop->op_folded = 1;
4395     return newop;
4396
4397  nope:
4398     return o;
4399 }
4400
4401 static OP *
4402 S_gen_constant_list(pTHX_ OP *o)
4403 {
4404     dVAR;
4405     OP *curop;
4406     const SSize_t oldtmps_floor = PL_tmps_floor;
4407     SV **svp;
4408     AV *av;
4409
4410     list(o);
4411     if (PL_parser && PL_parser->error_count)
4412         return o;               /* Don't attempt to run with errors */
4413
4414     curop = LINKLIST(o);
4415     o->op_next = 0;
4416     CALL_PEEP(curop);
4417     S_prune_chain_head(&curop);
4418     PL_op = curop;
4419     Perl_pp_pushmark(aTHX);
4420     CALLRUNOPS(aTHX);
4421     PL_op = curop;
4422     assert (!(curop->op_flags & OPf_SPECIAL));
4423     assert(curop->op_type == OP_RANGE);
4424     Perl_pp_anonlist(aTHX);
4425     PL_tmps_floor = oldtmps_floor;
4426
4427     OpTYPE_set(o, OP_RV2AV);
4428     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
4429     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
4430     o->op_opt = 0;              /* needs to be revisited in rpeep() */
4431     av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
4432
4433     /* replace subtree with an OP_CONST */
4434     curop = ((UNOP*)o)->op_first;
4435     op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
4436     op_free(curop);
4437
4438     if (AvFILLp(av) != -1)
4439         for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
4440         {
4441             SvPADTMP_on(*svp);
4442             SvREADONLY_on(*svp);
4443         }
4444     LINKLIST(o);
4445     return list(o);
4446 }
4447
4448 /*
4449 =head1 Optree Manipulation Functions
4450 */
4451
4452 /* List constructors */
4453
4454 /*
4455 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
4456
4457 Append an item to the list of ops contained directly within a list-type
4458 op, returning the lengthened list.  C<first> is the list-type op,
4459 and C<last> is the op to append to the list.  C<optype> specifies the
4460 intended opcode for the list.  If C<first> is not already a list of the
4461 right type, it will be upgraded into one.  If either C<first> or C<last>
4462 is null, the other is returned unchanged.
4463
4464 =cut
4465 */
4466
4467 OP *
4468 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
4469 {
4470     if (!first)
4471         return last;
4472
4473     if (!last)
4474         return first;
4475
4476     if (first->op_type != (unsigned)type
4477         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
4478     {
4479         return newLISTOP(type, 0, first, last);
4480     }
4481
4482     op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
4483     first->op_flags |= OPf_KIDS;
4484     return first;
4485 }
4486
4487 /*
4488 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
4489
4490 Concatenate the lists of ops contained directly within two list-type ops,
4491 returning the combined list.  C<first> and C<last> are the list-type ops
4492 to concatenate.  C<optype> specifies the intended opcode for the list.
4493 If either C<first> or C<last> is not already a list of the right type,
4494 it will be upgraded into one.  If either C<first> or C<last> is null,
4495 the other is returned unchanged.
4496
4497 =cut
4498 */
4499
4500 OP *
4501 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
4502 {
4503     if (!first)
4504         return last;
4505
4506     if (!last)
4507         return first;
4508
4509     if (first->op_type != (unsigned)type)
4510         return op_prepend_elem(type, first, last);
4511
4512     if (last->op_type != (unsigned)type)
4513         return op_append_elem(type, first, last);
4514
4515     OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
4516     ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
4517     OpLASTSIB_set(((LISTOP*)first)->op_last, first);
4518     first->op_flags |= (last->op_flags & OPf_KIDS);
4519
4520     S_op_destroy(aTHX_ last);
4521
4522     return first;
4523 }
4524
4525 /*
4526 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
4527
4528 Prepend an item to the list of ops contained directly within a list-type
4529 op, returning the lengthened list.  C<first> is the op to prepend to the
4530 list, and C<last> is the list-type op.  C<optype> specifies the intended
4531 opcode for the list.  If C<last> is not already a list of the right type,
4532 it will be upgraded into one.  If either C<first> or C<last> is null,
4533 the other is returned unchanged.
4534
4535 =cut
4536 */
4537
4538 OP *
4539 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
4540 {
4541     if (!first)
4542         return last;
4543
4544     if (!last)
4545         return first;
4546
4547     if (last->op_type == (unsigned)type) {
4548         if (type == OP_LIST) {  /* already a PUSHMARK there */
4549             /* insert 'first' after pushmark */
4550             op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
4551             if (!(first->op_flags & OPf_PARENS))
4552                 last->op_flags &= ~OPf_PARENS;
4553         }
4554         else
4555             op_sibling_splice(last, NULL, 0, first);
4556         last->op_flags |= OPf_KIDS;
4557         return last;
4558     }
4559
4560     return newLISTOP(type, 0, first, last);
4561 }
4562
4563 /*
4564 =for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
4565
4566 Converts C<o> into a list op if it is not one already, and then converts it
4567 into the specified C<type>, calling its check function, allocating a target if
4568 it needs one, and folding constants.
4569
4570 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
4571 C<op_prepend_elem> and C<op_append_elem>.  Then finally it is passed to
4572 C<op_convert_list> to make it the right type.
4573
4574 =cut
4575 */
4576
4577 OP *
4578 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
4579 {
4580     dVAR;
4581     if (type < 0) type = -type, flags |= OPf_SPECIAL;
4582     if (!o || o->op_type != OP_LIST)
4583         o = force_list(o, 0);
4584     else
4585     {
4586         o->op_flags &= ~OPf_WANT;
4587         o->op_private &= ~OPpLVAL_INTRO;
4588     }
4589
4590     if (!(PL_opargs[type] & OA_MARK))
4591         op_null(cLISTOPo->op_first);
4592     else {
4593         OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
4594         if (kid2 && kid2->op_type == OP_COREARGS) {
4595             op_null(cLISTOPo->op_first);
4596             kid2->op_private |= OPpCOREARGS_PUSHMARK;
4597         }
4598     }
4599
4600     OpTYPE_set(o, type);
4601     o->op_flags |= flags;
4602     if (flags & OPf_FOLDED)
4603         o->op_folded = 1;
4604
4605     o = CHECKOP(type, o);
4606     if (o->op_type != (unsigned)type)
4607         return o;
4608
4609     return fold_constants(op_integerize(op_std_init(o)));
4610 }
4611
4612 /* Constructors */
4613
4614
4615 /*
4616 =head1 Optree construction
4617
4618 =for apidoc Am|OP *|newNULLLIST
4619
4620 Constructs, checks, and returns a new C<stub> op, which represents an
4621 empty list expression.
4622
4623 =cut
4624 */
4625
4626 OP *
4627 Perl_newNULLLIST(pTHX)
4628 {
4629     return newOP(OP_STUB, 0);
4630 }
4631
4632 /* promote o and any siblings to be a list if its not already; i.e.
4633  *
4634  *  o - A - B
4635  *
4636  * becomes
4637  *
4638  *  list
4639  *    |
4640  *  pushmark - o - A - B
4641  *
4642  * If nullit it true, the list op is nulled.
4643  */
4644
4645 static OP *
4646 S_force_list(pTHX_ OP *o, bool nullit)
4647 {
4648     if (!o || o->op_type != OP_LIST) {
4649         OP *rest = NULL;
4650         if (o) {
4651             /* manually detach any siblings then add them back later */
4652             rest = OpSIBLING(o);
4653             OpLASTSIB_set(o, NULL);
4654         }
4655         o = newLISTOP(OP_LIST, 0, o, NULL);
4656         if (rest)
4657             op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
4658     }
4659     if (nullit)
4660         op_null(o);
4661     return o;
4662 }
4663
4664 /*
4665 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
4666
4667 Constructs, checks, and returns an op of any list type.  C<type> is
4668 the opcode.  C<flags> gives the eight bits of C<op_flags>, except that
4669 C<OPf_KIDS> will be set automatically if required.  C<first> and C<last>
4670 supply up to two ops to be direct children of the list op; they are
4671 consumed by this function and become part of the constructed op tree.
4672
4673 For most list operators, the check function expects all the kid ops to be
4674 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
4675 appropriate.  What you want to do in that case is create an op of type
4676 OP_LIST, append more children to it, and then call L</op_convert_list>.
4677 See L</op_convert_list> for more information.
4678
4679
4680 =cut
4681 */
4682
4683 OP *
4684 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4685 {
4686     dVAR;
4687     LISTOP *listop;
4688
4689     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
4690         || type == OP_CUSTOM);
4691
4692     NewOp(1101, listop, 1, LISTOP);
4693
4694     OpTYPE_set(listop, type);
4695     if (first || last)
4696         flags |= OPf_KIDS;
4697     listop->op_flags = (U8)flags;
4698
4699     if (!last && first)
4700         last = first;
4701     else if (!first && last)
4702         first = last;
4703     else if (first)
4704         OpMORESIB_set(first, last);
4705     listop->op_first = first;
4706     listop->op_last = last;
4707     if (type == OP_LIST) {
4708         OP* const pushop = newOP(OP_PUSHMARK, 0);
4709         OpMORESIB_set(pushop, first);
4710         listop->op_first = pushop;
4711         listop->op_flags |= OPf_KIDS;
4712         if (!last)
4713             listop->op_last = pushop;
4714     }
4715     if (listop->op_last)
4716         OpLASTSIB_set(listop->op_last, (OP*)listop);
4717
4718     return CHECKOP(type, listop);
4719 }
4720
4721 /*
4722 =for apidoc Am|OP *|newOP|I32 type|I32 flags
4723
4724 Constructs, checks, and returns an op of any base type (any type that
4725 has no extra fields).  C<type> is the opcode.  C<flags> gives the
4726 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
4727 of C<op_private>.
4728
4729 =cut
4730 */
4731
4732 OP *
4733 Perl_newOP(pTHX_ I32 type, I32 flags)
4734 {
4735     dVAR;
4736     OP *o;
4737
4738     if (type == -OP_ENTEREVAL) {
4739         type = OP_ENTEREVAL;
4740         flags |= OPpEVAL_BYTES<<8;
4741     }
4742
4743     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
4744         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4745         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4746         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4747
4748     NewOp(1101, o, 1, OP);
4749     OpTYPE_set(o, type);
4750     o->op_flags = (U8)flags;
4751
4752     o->op_next = o;
4753     o->op_private = (U8)(0 | (flags >> 8));
4754     if (PL_opargs[type] & OA_RETSCALAR)
4755         scalar(o);
4756     if (PL_opargs[type] & OA_TARGET)
4757         o->op_targ = pad_alloc(type, SVs_PADTMP);
4758     return CHECKOP(type, o);
4759 }
4760
4761 /*
4762 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
4763
4764 Constructs, checks, and returns an op of any unary type.  C<type> is
4765 the opcode.  C<flags> gives the eight bits of C<op_flags>, except that
4766 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
4767 bits, the eight bits of C<op_private>, except that the bit with value 1
4768 is automatically set.  C<first> supplies an optional op to be the direct
4769 child of the unary op; it is consumed by this function and become part
4770 of the constructed op tree.
4771
4772 =cut
4773 */
4774
4775 OP *
4776 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
4777 {
4778     dVAR;
4779     UNOP *unop;
4780
4781     if (type == -OP_ENTEREVAL) {
4782         type = OP_ENTEREVAL;
4783         flags |= OPpEVAL_BYTES<<8;
4784     }
4785
4786     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
4787         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4788         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4789         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
4790         || type == OP_SASSIGN
4791         || type == OP_ENTERTRY
4792         || type == OP_CUSTOM
4793         || type == OP_NULL );
4794
4795     if (!first)
4796         first = newOP(OP_STUB, 0);
4797     if (PL_opargs[type] & OA_MARK)
4798         first = force_list(first, 1);
4799
4800     NewOp(1101, unop, 1, UNOP);
4801     OpTYPE_set(unop, type);
4802     unop->op_first = first;
4803     unop->op_flags = (U8)(flags | OPf_KIDS);
4804     unop->op_private = (U8)(1 | (flags >> 8));
4805
4806     if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
4807         OpLASTSIB_set(first, (OP*)unop);
4808
4809     unop = (UNOP*) CHECKOP(type, unop);
4810     if (unop->op_next)
4811         return (OP*)unop;
4812
4813     return fold_constants(op_integerize(op_std_init((OP *) unop)));
4814 }
4815
4816 /*
4817 =for apidoc newUNOP_AUX
4818
4819 Similar to C<newUNOP>, but creates an UNOP_AUX struct instead, with op_aux
4820 initialised to aux
4821
4822 =cut
4823 */
4824
4825 OP *
4826 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
4827 {
4828     dVAR;
4829     UNOP_AUX *unop;
4830
4831     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
4832         || type == OP_CUSTOM);
4833
4834     NewOp(1101, unop, 1, UNOP_AUX);
4835     unop->op_type = (OPCODE)type;
4836     unop->op_ppaddr = PL_ppaddr[type];
4837     unop->op_first = first;
4838     unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
4839     unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
4840     unop->op_aux = aux;
4841
4842     if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
4843         OpLASTSIB_set(first, (OP*)unop);
4844
4845     unop = (UNOP_AUX*) CHECKOP(type, unop);
4846
4847     return op_std_init((OP *) unop);
4848 }
4849
4850 /*
4851 =for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
4852
4853 Constructs, checks, and returns an op of method type with a method name
4854 evaluated at runtime.  C<type> is the opcode.  C<flags> gives the eight
4855 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
4856 and, shifted up eight bits, the eight bits of C<op_private>, except that
4857 the bit with value 1 is automatically set.  C<dynamic_meth> supplies an
4858 op which evaluates method name; it is consumed by this function and
4859 become part of the constructed op tree.
4860 Supported optypes: OP_METHOD.
4861
4862 =cut
4863 */
4864
4865 static OP*
4866 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
4867     dVAR;
4868     METHOP *methop;
4869
4870     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
4871         || type == OP_CUSTOM);
4872
4873     NewOp(1101, methop, 1, METHOP);
4874     if (dynamic_meth) {
4875         if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
4876         methop->op_flags = (U8)(flags | OPf_KIDS);
4877         methop->op_u.op_first = dynamic_meth;
4878         methop->op_private = (U8)(1 | (flags >> 8));
4879
4880         if (!OpHAS_SIBLING(dynamic_meth))
4881             OpLASTSIB_set(dynamic_meth, (OP*)methop);
4882     }
4883     else {
4884         assert(const_meth);
4885         methop->op_flags = (U8)(flags & ~OPf_KIDS);
4886         methop->op_u.op_meth_sv = const_meth;
4887         methop->op_private = (U8)(0 | (flags >> 8));
4888         methop->op_next = (OP*)methop;
4889     }
4890
4891 #ifdef USE_ITHREADS
4892     methop->op_rclass_targ = 0;
4893 #else
4894     methop->op_rclass_sv = NULL;
4895 #endif
4896
4897     OpTYPE_set(methop, type);
4898     return CHECKOP(type, methop);
4899 }
4900
4901 OP *
4902 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
4903     PERL_ARGS_ASSERT_NEWMETHOP;
4904     return newMETHOP_internal(type, flags, dynamic_meth, NULL);
4905 }
4906
4907 /*
4908 =for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
4909
4910 Constructs, checks, and returns an op of method type with a constant
4911 method name.  C<type> is the opcode.  C<flags> gives the eight bits of
4912 C<op_flags>, and, shifted up eight bits, the eight bits of
4913 C<op_private>.  C<const_meth> supplies a constant method name;
4914 it must be a shared COW string.
4915 Supported optypes: OP_METHOD_NAMED.
4916
4917 =cut
4918 */
4919
4920 OP *
4921 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
4922     PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
4923     return newMETHOP_internal(type, flags, NULL, const_meth);
4924 }
4925
4926 /*
4927 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
4928
4929 Constructs, checks, and returns an op of any binary type.  C<type>
4930 is the opcode.  C<flags> gives the eight bits of C<op_flags>, except
4931 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4932 the eight bits of C<op_private>, except that the bit with value 1 or
4933 2 is automatically set as required.  C<first> and C<last> supply up to
4934 two ops to be the direct children of the binary op; they are consumed
4935 by this function and become part of the constructed op tree.
4936
4937 =cut
4938 */
4939
4940 OP *
4941 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4942 {
4943     dVAR;
4944     BINOP *binop;
4945
4946     ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
4947         || type == OP_SASSIGN || type == OP_NULL || type == OP_CUSTOM);
4948
4949     NewOp(1101, binop, 1, BINOP);
4950
4951     if (!first)
4952         first = newOP(OP_NULL, 0);
4953
4954     OpTYPE_set(binop, type);
4955     binop->op_first = first;
4956     binop->op_flags = (U8)(flags | OPf_KIDS);
4957     if (!last) {
4958         last = first;
4959         binop->op_private = (U8)(1 | (flags >> 8));
4960     }
4961     else {
4962         binop->op_private = (U8)(2 | (flags >> 8));
4963         OpMORESIB_set(first, last);
4964     }
4965
4966     if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
4967         OpLASTSIB_set(last, (OP*)binop);
4968
4969     binop->op_last = OpSIBLING(binop->op_first);
4970     if (binop->op_last)
4971         OpLASTSIB_set(binop->op_last, (OP*)binop);
4972
4973     binop = (BINOP*)CHECKOP(type, binop);
4974     if (binop->op_next || binop->op_type != (OPCODE)type)
4975         return (OP*)binop;
4976
4977     return fold_constants(op_integerize(op_std_init((OP *)binop)));
4978 }
4979
4980 static int uvcompare(const void *a, const void *b)
4981     __attribute__nonnull__(1)
4982     __attribute__nonnull__(2)
4983     __attribute__pure__;
4984 static int uvcompare(const void *a, const void *b)
4985 {
4986     if (*((const UV *)a) < (*(const UV *)b))
4987         return -1;
4988     if (*((const UV *)a) > (*(const UV *)b))
4989         return 1;
4990     if (*((const UV *)a+1) < (*(const UV *)b+1))
4991         return -1;
4992     if (*((const UV *)a+1) > (*(const UV *)b+1))
4993         return 1;
4994     return 0;
4995 }
4996
4997 static OP *
4998 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
4999 {
5000     SV * const tstr = ((SVOP*)expr)->op_sv;
5001     SV * const rstr =
5002                               ((SVOP*)repl)->op_sv;
5003     STRLEN tlen;
5004     STRLEN rlen;
5005     const U8 *t = (U8*)SvPV_const(tstr, tlen);
5006     const U8 *r = (U8*)SvPV_const(rstr, rlen);
5007     I32 i;
5008     I32 j;
5009     I32 grows = 0;
5010     short *tbl;
5011
5012     const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
5013     const I32 squash     = o->op_private & OPpTRANS_SQUASH;
5014     I32 del              = o->op_private & OPpTRANS_DELETE;
5015     SV* swash;
5016
5017     PERL_ARGS_ASSERT_PMTRANS;
5018
5019     PL_hints |= HINT_BLOCK_SCOPE;
5020
5021     if (SvUTF8(tstr))
5022         o->op_private |= OPpTRANS_FROM_UTF;
5023
5024     if (SvUTF8(rstr))
5025         o->op_private |= OPpTRANS_TO_UTF;
5026
5027     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
5028         SV* const listsv = newSVpvs("# comment\n");
5029         SV* transv = NULL;
5030         const U8* tend = t + tlen;
5031         const U8* rend = r + rlen;
5032         STRLEN ulen;
5033         UV tfirst = 1;
5034         UV tlast = 0;
5035         IV tdiff;
5036         STRLEN tcount = 0;
5037         UV rfirst = 1;
5038         UV rlast = 0;
5039         IV rdiff;
5040         STRLEN rcount = 0;
5041         IV diff;
5042         I32 none = 0;
5043         U32 max = 0;
5044         I32 bits;
5045         I32 havefinal = 0;
5046         U32 final = 0;
5047         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
5048         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
5049         U8* tsave = NULL;
5050         U8* rsave = NULL;
5051         const U32 flags = UTF8_ALLOW_DEFAULT;
5052
5053         if (!from_utf) {
5054             STRLEN len = tlen;
5055             t = tsave = bytes_to_utf8(t, &len);
5056             tend = t + len;
5057         }
5058         if (!to_utf && rlen) {
5059             STRLEN len = rlen;
5060             r = rsave = bytes_to_utf8(r, &len);
5061             rend = r + len;
5062         }
5063
5064 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
5065  * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
5066  * odd.  */
5067
5068         if (complement) {
5069             U8 tmpbuf[UTF8_MAXBYTES+1];
5070             UV *cp;
5071             UV nextmin = 0;
5072             Newx(cp, 2*tlen, UV);
5073             i = 0;
5074             transv = newSVpvs("");
5075             while (t < tend) {
5076                 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
5077                 t += ulen;
5078                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
5079                     t++;
5080                     cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
5081                     t += ulen;
5082                 }
5083                 else {
5084                  cp[2*i+1] = cp[2*i];
5085                 }
5086                 i++;
5087             }
5088             qsort(cp, i, 2*sizeof(UV), uvcompare);
5089             for (j = 0; j < i; j++) {
5090                 UV  val = cp[2*j];
5091                 diff = val - nextmin;
5092                 if (diff > 0) {
5093                     t = uvchr_to_utf8(tmpbuf,nextmin);
5094                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5095                     if (diff > 1) {
5096                         U8  range_mark = ILLEGAL_UTF8_BYTE;
5097                         t = uvchr_to_utf8(tmpbuf, val - 1);
5098                         sv_catpvn(transv, (char *)&range_mark, 1);
5099                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5100                     }
5101                 }
5102                 val = cp[2*j+1];
5103                 if (val >= nextmin)
5104                     nextmin = val + 1;
5105             }
5106             t = uvchr_to_utf8(tmpbuf,nextmin);
5107             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5108             {
5109                 U8 range_mark = ILLEGAL_UTF8_BYTE;
5110                 sv_catpvn(transv, (char *)&range_mark, 1);
5111             }
5112             t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
5113             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5114             t = (const U8*)SvPVX_const(transv);
5115             tlen = SvCUR(transv);
5116             tend = t + tlen;
5117             Safefree(cp);
5118         }
5119         else if (!rlen && !del) {
5120             r = t; rlen = tlen; rend = tend;
5121         }
5122         if (!squash) {
5123                 if ((!rlen && !del) || t == r ||
5124                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
5125                 {
5126                     o->op_private |= OPpTRANS_IDENTICAL;
5127                 }
5128         }
5129
5130         while (t < tend || tfirst <= tlast) {
5131             /* see if we need more "t" chars */
5132             if (tfirst > tlast) {
5133                 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
5134                 t += ulen;
5135                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {      /* illegal utf8 val indicates range */
5136                     t++;
5137                     tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
5138                     t += ulen;
5139                 }
5140                 else
5141                     tlast = tfirst;
5142             }
5143
5144             /* now see if we need more "r" chars */
5145             if (rfirst > rlast) {
5146                 if (r < rend) {
5147                     rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
5148                     r += ulen;
5149                     if (r < rend && *r == ILLEGAL_UTF8_BYTE) {  /* illegal utf8 val indicates range */
5150                         r++;
5151                         rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
5152                         r += ulen;
5153                     }
5154                     else
5155                         rlast = rfirst;
5156                 }
5157                 else {
5158                     if (!havefinal++)
5159                         final = rlast;
5160                     rfirst = rlast = 0xffffffff;
5161                 }
5162             }
5163
5164             /* now see which range will peter out first, if either. */
5165             tdiff = tlast - tfirst;
5166             rdiff = rlast - rfirst;
5167             tcount += tdiff + 1;
5168             rcount += rdiff + 1;
5169
5170             if (tdiff <= rdiff)
5171                 diff = tdiff;
5172             else
5173                 diff = rdiff;
5174
5175             if (rfirst == 0xffffffff) {
5176                 diff = tdiff;   /* oops, pretend rdiff is infinite */
5177                 if (diff > 0)
5178                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
5179                                    (long)tfirst, (long)tlast);
5180                 else
5181                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
5182             }
5183             else {
5184                 if (diff > 0)
5185                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
5186                                    (long)tfirst, (long)(tfirst + diff),
5187                                    (long)rfirst);
5188                 else
5189                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
5190                                    (long)tfirst, (long)rfirst);
5191
5192                 if (rfirst + diff > max)
5193                     max = rfirst + diff;
5194                 if (!grows)
5195                     grows = (tfirst < rfirst &&
5196                              UNISKIP(tfirst) < UNISKIP(rfirst + diff));
5197                 rfirst += diff + 1;
5198             }
5199             tfirst += diff + 1;
5200         }
5201
5202         none = ++max;
5203         if (del)
5204             del = ++max;
5205
5206         if (max > 0xffff)
5207             bits = 32;
5208         else if (max > 0xff)
5209             bits = 16;
5210         else
5211             bits = 8;
5212
5213         swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
5214 #ifdef USE_ITHREADS
5215         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
5216         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
5217         PAD_SETSV(cPADOPo->op_padix, swash);
5218         SvPADTMP_on(swash);
5219         SvREADONLY_on(swash);
5220 #else
5221         cSVOPo->op_sv = swash;
5222 #endif
5223         SvREFCNT_dec(listsv);
5224         SvREFCNT_dec(transv);
5225
5226         if (!del && havefinal && rlen)
5227             (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
5228                            newSVuv((UV)final), 0);
5229
5230         Safefree(tsave);
5231         Safefree(rsave);
5232
5233         tlen = tcount;
5234         rlen = rcount;
5235         if (r < rend)
5236             rlen++;
5237         else if (rlast == 0xffffffff)
5238             rlen = 0;
5239
5240         goto warnins;
5241     }
5242
5243     tbl = (short*)PerlMemShared_calloc(
5244         (o->op_private & OPpTRANS_COMPLEMENT) &&
5245             !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
5246         sizeof(short));
5247     cPVOPo->op_pv = (char*)tbl;
5248     if (complement) {
5249         for (i = 0; i < (I32)tlen; i++)
5250             tbl[t[i]] = -1;
5251         for (i = 0, j = 0; i < 256; i++) {
5252             if (!tbl[i]) {
5253                 if (j >= (I32)rlen) {
5254                     if (del)
5255                         tbl[i] = -2;
5256                     else if (rlen)
5257                         tbl[i] = r[j-1];
5258                     else
5259                         tbl[i] = (short)i;
5260                 }
5261                 else {
5262                     if (i < 128 && r[j] >= 128)
5263                         grows = 1;
5264                     tbl[i] = r[j++];
5265                 }
5266             }
5267         }
5268         if (!del) {
5269             if (!rlen) {
5270                 j = rlen;
5271                 if (!squash)
5272                     o->op_private |= OPpTRANS_IDENTICAL;
5273             }
5274             else if (j >= (I32)rlen)
5275                 j = rlen - 1;
5276             else {
5277                 tbl =
5278                     (short *)
5279                     PerlMemShared_realloc(tbl,
5280                                           (0x101+rlen-j) * sizeof(short));
5281                 cPVOPo->op_pv = (char*)tbl;
5282             }
5283             tbl[0x100] = (short)(rlen - j);
5284             for (i=0; i < (I32)rlen - j; i++)
5285                 tbl[0x101+i] = r[j+i];
5286         }
5287     }
5288     else {
5289         if (!rlen && !del) {
5290             r = t; rlen = tlen;
5291             if (!squash)
5292                 o->op_private |= OPpTRANS_IDENTICAL;
5293         }
5294         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
5295             o->op_private |= OPpTRANS_IDENTICAL;
5296         }
5297         for (i = 0; i < 256; i++)
5298             tbl[i] = -1;
5299         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
5300             if (j >= (I32)rlen) {
5301                 if (del) {
5302                     if (tbl[t[i]] == -1)
5303                         tbl[t[i]] = -2;
5304                     continue;
5305                 }
5306                 --j;
5307             }
5308             if (tbl[t[i]] == -1) {
5309                 if (t[i] < 128 && r[j] >= 128)
5310                     grows = 1;
5311                 tbl[t[i]] = r[j];
5312             }
5313         }
5314     }
5315
5316   warnins:
5317     if(del && rlen == tlen) {
5318         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
5319     } else if(rlen > tlen && !complement) {
5320         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
5321     }
5322
5323     if (grows)
5324         o->op_private |= OPpTRANS_GROWS;
5325     op_free(expr);
5326     op_free(repl);
5327
5328     return o;
5329 }
5330
5331 /*
5332 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
5333
5334 Constructs, checks, and returns an op of any pattern matching type.
5335 C<type> is the opcode.  C<flags> gives the eight bits of C<op_flags>
5336 and, shifted up eight bits, the eight bits of C<op_private>.
5337
5338 =cut
5339 */
5340
5341 OP *
5342 Perl_newPMOP(pTHX_ I32 type, I32 flags)
5343 {
5344     dVAR;
5345     PMOP *pmop;
5346
5347     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
5348         || type == OP_CUSTOM);
5349
5350     NewOp(1101, pmop, 1, PMOP);
5351     OpTYPE_set(pmop, type);
5352     pmop->op_flags = (U8)flags;
5353     pmop->op_private = (U8)(0 | (flags >> 8));
5354     if (PL_opargs[type] & OA_RETSCALAR)
5355         scalar((OP *)pmop);
5356
5357     if (PL_hints & HINT_RE_TAINT)
5358         pmop->op_pmflags |= PMf_RETAINT;
5359 #ifdef USE_LOCALE_CTYPE
5360     if (IN_LC_COMPILETIME(LC_CTYPE)) {
5361         set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
5362     }
5363     else
5364 #endif
5365          if (IN_UNI_8_BIT) {
5366         set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
5367     }
5368     if (PL_hints & HINT_RE_FLAGS) {
5369         SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5370          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
5371         );
5372         if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
5373         reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5374          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
5375         );
5376         if (reflags && SvOK(reflags)) {
5377             set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
5378         }
5379     }
5380
5381
5382 #ifdef USE_ITHREADS
5383     assert(SvPOK(PL_regex_pad[0]));
5384     if (SvCUR(PL_regex_pad[0])) {
5385         /* Pop off the "packed" IV from the end.  */
5386         SV *const repointer_list = PL_regex_pad[0];
5387         const char *p = SvEND(repointer_list) - sizeof(IV);
5388         const IV offset = *((IV*)p);
5389
5390         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
5391
5392         SvEND_set(repointer_list, p);
5393
5394         pmop->op_pmoffset = offset;
5395         /* This slot should be free, so assert this:  */
5396         assert(PL_regex_pad[offset] == &PL_sv_undef);
5397     } else {
5398         SV * const repointer = &PL_sv_undef;
5399         av_push(PL_regex_padav, repointer);
5400         pmop->op_pmoffset = av_tindex(PL_regex_padav);
5401         PL_regex_pad = AvARRAY(PL_regex_padav);
5402     }
5403 #endif
5404
5405     return CHECKOP(type, pmop);
5406 }
5407
5408 static void
5409 S_set_haseval(pTHX)
5410 {
5411     PADOFFSET i = 1;
5412     PL_cv_has_eval = 1;
5413     /* Any pad names in scope are potentially lvalues.  */
5414     for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
5415         PADNAME *pn = PAD_COMPNAME_SV(i);
5416         if (!pn || !PadnameLEN(pn))
5417             continue;
5418         if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
5419             S_mark_padname_lvalue(aTHX_ pn);
5420     }
5421 }
5422
5423 /* Given some sort of match op o, and an expression expr containing a
5424  * pattern, either compile expr into a regex and attach it to o (if it's
5425  * constant), or convert expr into a runtime regcomp op sequence (if it's
5426  * not)
5427  *
5428  * isreg indicates that the pattern is part of a regex construct, eg
5429  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
5430  * split "pattern", which aren't. In the former case, expr will be a list
5431  * if the pattern contains more than one term (eg /a$b/).
5432  *
5433  * When the pattern has been compiled within a new anon CV (for
5434  * qr/(?{...})/ ), then floor indicates the savestack level just before
5435  * the new sub was created
5436  */
5437
5438 OP *
5439 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, bool isreg, I32 floor)
5440 {
5441     PMOP *pm;
5442     LOGOP *rcop;
5443     I32 repl_has_vars = 0;
5444     bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
5445     bool is_compiletime;
5446     bool has_code;
5447
5448     PERL_ARGS_ASSERT_PMRUNTIME;
5449
5450     if (is_trans) {
5451         return pmtrans(o, expr, repl);
5452     }
5453
5454     /* find whether we have any runtime or code elements;
5455      * at the same time, temporarily set the op_next of each DO block;
5456      * then when we LINKLIST, this will cause the DO blocks to be excluded
5457      * from the op_next chain (and from having LINKLIST recursively
5458      * applied to them). We fix up the DOs specially later */
5459
5460     is_compiletime = 1;
5461     has_code = 0;
5462     if (expr->op_type == OP_LIST) {
5463         OP *o;
5464         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
5465             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
5466                 has_code = 1;
5467                 assert(!o->op_next);
5468                 if (UNLIKELY(!OpHAS_SIBLING(o))) {
5469                     assert(PL_parser && PL_parser->error_count);
5470                     /* This can happen with qr/ (?{(^{})/.  Just fake up
5471                        the op we were expecting to see, to avoid crashing
5472                        elsewhere.  */
5473                     op_sibling_splice(expr, o, 0,
5474                                       newSVOP(OP_CONST, 0, &PL_sv_no));
5475                 }
5476                 o->op_next = OpSIBLING(o);
5477             }
5478             else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
5479                 is_compiletime = 0;
5480         }
5481     }
5482     else if (expr->op_type != OP_CONST)
5483         is_compiletime = 0;
5484
5485     LINKLIST(expr);
5486
5487     /* fix up DO blocks; treat each one as a separate little sub;
5488      * also, mark any arrays as LIST/REF */
5489
5490     if (expr->op_type == OP_LIST) {
5491         OP *o;
5492         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
5493
5494             if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
5495                 assert( !(o->op_flags  & OPf_WANT));
5496                 /* push the array rather than its contents. The regex
5497                  * engine will retrieve and join the elements later */
5498                 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
5499                 continue;
5500             }
5501
5502             if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
5503                 continue;
5504             o->op_next = NULL; /* undo temporary hack from above */
5505             scalar(o);
5506             LINKLIST(o);
5507             if (cLISTOPo->op_first->op_type == OP_LEAVE) {
5508                 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
5509                 /* skip ENTER */
5510                 assert(leaveop->op_first->op_type == OP_ENTER);
5511                 assert(OpHAS_SIBLING(leaveop->op_first));
5512                 o->op_next = OpSIBLING(leaveop->op_first);
5513                 /* skip leave */
5514                 assert(leaveop->op_flags & OPf_KIDS);
5515                 assert(leaveop->op_last->op_next == (OP*)leaveop);
5516                 leaveop->op_next = NULL; /* stop on last op */
5517                 op_null((OP*)leaveop);
5518             }
5519             else {
5520                 /* skip SCOPE */
5521                 OP *scope = cLISTOPo->op_first;
5522                 assert(scope->op_type == OP_SCOPE);
5523                 assert(scope->op_flags & OPf_KIDS);
5524                 scope->op_next = NULL; /* stop on last op */
5525                 op_null(scope);
5526             }
5527             /* have to peep the DOs individually as we've removed it from
5528              * the op_next chain */
5529             CALL_PEEP(o);
5530             S_prune_chain_head(&(o->op_next));
5531             if (is_compiletime)
5532                 /* runtime finalizes as part of finalizing whole tree */
5533                 finalize_optree(o);
5534         }
5535     }
5536     else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
5537         assert( !(expr->op_flags  & OPf_WANT));
5538         /* push the array rather than its contents. The regex
5539          * engine will retrieve and join the elements later */
5540         expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
5541     }
5542
5543     PL_hints |= HINT_BLOCK_SCOPE;
5544     pm = (PMOP*)o;
5545     assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
5546
5547     if (is_compiletime) {
5548         U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
5549         regexp_engine const *eng = current_re_engine();
5550
5551         if (o->op_flags & OPf_SPECIAL)
5552             rx_flags |= RXf_SPLIT;
5553
5554         if (!has_code || !eng->op_comp) {
5555             /* compile-time simple constant pattern */
5556
5557             if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
5558                 /* whoops! we guessed that a qr// had a code block, but we
5559                  * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
5560                  * that isn't required now. Note that we have to be pretty
5561                  * confident that nothing used that CV's pad while the
5562                  * regex was parsed, except maybe op targets for \Q etc.
5563                  * If there were any op targets, though, they should have
5564                  * been stolen by constant folding.
5565                  */
5566 #ifdef DEBUGGING
5567                 SSize_t i = 0;
5568                 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
5569                 while (++i <= AvFILLp(PL_comppad)) {
5570                     assert(!PL_curpad[i]);
5571                 }
5572 #endif
5573                 /* But we know that one op is using this CV's slab. */
5574                 cv_forget_slab(PL_compcv);
5575                 LEAVE_SCOPE(floor);
5576                 pm->op_pmflags &= ~PMf_HAS_CV;
5577             }
5578
5579             PM_SETRE(pm,
5580                 eng->op_comp
5581                     ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5582                                         rx_flags, pm->op_pmflags)
5583                     : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5584                                         rx_flags, pm->op_pmflags)
5585             );
5586             op_free(expr);
5587         }
5588         else {
5589             /* compile-time pattern that includes literal code blocks */
5590             REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5591                         rx_flags,
5592                         (pm->op_pmflags |
5593                             ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
5594                     );
5595             PM_SETRE(pm, re);
5596             if (pm->op_pmflags & PMf_HAS_CV) {
5597                 CV *cv;
5598                 /* this QR op (and the anon sub we embed it in) is never
5599                  * actually executed. It's just a placeholder where we can
5600                  * squirrel away expr in op_code_list without the peephole
5601                  * optimiser etc processing it for a second time */
5602                 OP *qr = newPMOP(OP_QR, 0);
5603                 ((PMOP*)qr)->op_code_list = expr;
5604
5605                 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
5606                 SvREFCNT_inc_simple_void(PL_compcv);
5607                 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
5608                 ReANY(re)->qr_anoncv = cv;
5609
5610                 /* attach the anon CV to the pad so that
5611                  * pad_fixup_inner_anons() can find it */
5612                 (void)pad_add_anon(cv, o->op_type);
5613                 SvREFCNT_inc_simple_void(cv);
5614             }
5615             else {
5616                 pm->op_code_list = expr;
5617             }
5618         }
5619     }
5620     else {
5621         /* runtime pattern: build chain of regcomp etc ops */
5622         bool reglist;
5623         PADOFFSET cv_targ = 0;
5624
5625         reglist = isreg && expr->op_type == OP_LIST;
5626         if (reglist)
5627             op_null(expr);
5628
5629         if (has_code) {
5630             pm->op_code_list = expr;
5631             /* don't free op_code_list; its ops are embedded elsewhere too */
5632             pm->op_pmflags |= PMf_CODELIST_PRIVATE;
5633         }
5634
5635         if (o->op_flags & OPf_SPECIAL)
5636             pm->op_pmflags |= PMf_SPLIT;
5637
5638         /* the OP_REGCMAYBE is a placeholder in the non-threaded case
5639          * to allow its op_next to be pointed past the regcomp and
5640          * preceding stacking ops;
5641          * OP_REGCRESET is there to reset taint before executing the
5642          * stacking ops */
5643         if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
5644             expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
5645
5646         if (pm->op_pmflags & PMf_HAS_CV) {
5647             /* we have a runtime qr with literal code. This means
5648              * that the qr// has been wrapped in a new CV, which
5649              * means that runtime consts, vars etc will have been compiled
5650              * against a new pad. So... we need to execute those ops
5651              * within the environment of the new CV. So wrap them in a call
5652              * to a new anon sub. i.e. for
5653              *
5654              *     qr/a$b(?{...})/,
5655              *
5656              * we build an anon sub that looks like
5657              *
5658              *     sub { "a", $b, '(?{...})' }
5659              *
5660              * and call it, passing the returned list to regcomp.
5661              * Or to put it another way, the list of ops that get executed
5662              * are:
5663              *
5664              *     normal              PMf_HAS_CV
5665              *     ------              -------------------
5666              *                         pushmark (for regcomp)
5667              *                         pushmark (for entersub)
5668              *                         anoncode
5669              *                         srefgen
5670              *                         entersub
5671              *     regcreset                  regcreset
5672              *     pushmark                   pushmark
5673              *     const("a")                 const("a")
5674              *     gvsv(b)                    gvsv(b)
5675              *     const("(?{...})")          const("(?{...})")
5676              *                                leavesub
5677              *     regcomp             regcomp
5678              */
5679
5680             SvREFCNT_inc_simple_void(PL_compcv);
5681             CvLVALUE_on(PL_compcv);
5682             /* these lines are just an unrolled newANONATTRSUB */
5683             expr = newSVOP(OP_ANONCODE, 0,
5684                     MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
5685             cv_targ = expr->op_targ;
5686             expr = newUNOP(OP_REFGEN, 0, expr);
5687
5688             expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
5689         }
5690
5691         rcop = S_alloc_LOGOP(aTHX_ OP_REGCOMP, scalar(expr), o);
5692         rcop->op_flags |=  ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
5693                            | (reglist ? OPf_STACKED : 0);
5694         rcop->op_targ = cv_targ;
5695
5696         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
5697         if (PL_hints & HINT_RE_EVAL)
5698             S_set_haseval(aTHX);
5699
5700         /* establish postfix order */
5701         if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
5702             LINKLIST(expr);
5703             rcop->op_next = expr;
5704             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
5705         }
5706         else {
5707             rcop->op_next = LINKLIST(expr);
5708             expr->op_next = (OP*)rcop;
5709         }
5710
5711         op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
5712     }
5713
5714     if (repl) {
5715         OP *curop = repl;
5716         bool konst;
5717         /* If we are looking at s//.../e with a single statement, get past
5718            the implicit do{}. */
5719         if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
5720              && cUNOPx(curop)->op_first->op_type == OP_SCOPE
5721              && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
5722          {
5723             OP *sib;
5724             OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
5725             if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
5726              && !OpHAS_SIBLING(sib))
5727                 curop = sib;
5728         }
5729         if (curop->op_type == OP_CONST)
5730             konst = TRUE;
5731         else if (( (curop->op_type == OP_RV2SV ||
5732                     curop->op_type == OP_RV2AV ||
5733                     curop->op_type == OP_RV2HV ||
5734                     curop->op_type == OP_RV2GV)
5735                    && cUNOPx(curop)->op_first
5736                    && cUNOPx(curop)->op_first->op_type == OP_GV )
5737                 || curop->op_type == OP_PADSV
5738                 || curop->op_type == OP_PADAV
5739                 || curop->op_type == OP_PADHV
5740                 || curop->op_type == OP_PADANY) {
5741             repl_has_vars = 1;
5742             konst = TRUE;
5743         }
5744         else konst = FALSE;
5745         if (konst
5746             && !(repl_has_vars
5747                  && (!PM_GETRE(pm)
5748                      || !RX_PRELEN(PM_GETRE(pm))
5749                      || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
5750         {
5751             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
5752             op_prepend_elem(o->op_type, scalar(repl), o);
5753         }
5754         else {
5755             rcop = S_alloc_LOGOP(aTHX_ OP_SUBSTCONT, scalar(repl), o);
5756             rcop->op_private = 1;
5757
5758             /* establish postfix order */
5759             rcop->op_next = LINKLIST(repl);
5760             repl->op_next = (OP*)rcop;
5761
5762             pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
5763             assert(!(pm->op_pmflags & PMf_ONCE));
5764             pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
5765             rcop->op_next = 0;
5766         }
5767     }
5768
5769     return (OP*)pm;
5770 }
5771
5772 /*
5773 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
5774
5775 Constructs, checks, and returns an op of any type that involves an
5776 embedded SV.  C<type> is the opcode.  C<flags> gives the eight bits
5777 of C<op_flags>.  C<sv> gives the SV to embed in the op; this function
5778 takes ownership of one reference to it.
5779
5780 =cut
5781 */
5782
5783 OP *
5784 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
5785 {
5786     dVAR;
5787     SVOP *svop;
5788
5789     PERL_ARGS_ASSERT_NEWSVOP;
5790
5791     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5792         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5793         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5794         || type == OP_CUSTOM);
5795
5796     NewOp(1101, svop, 1, SVOP);
5797     OpTYPE_set(svop, type);
5798     svop->op_sv = sv;
5799     svop->op_next = (OP*)svop;
5800     svop->op_flags = (U8)flags;
5801     svop->op_private = (U8)(0 | (flags >> 8));
5802     if (PL_opargs[type] & OA_RETSCALAR)
5803         scalar((OP*)svop);
5804     if (PL_opargs[type] & OA_TARGET)
5805         svop->op_targ = pad_alloc(type, SVs_PADTMP);
5806     return CHECKOP(type, svop);
5807 }
5808
5809 /*
5810 =for apidoc Am|OP *|newDEFSVOP|
5811
5812 Constructs and returns an op to access C<$_>, either as a lexical
5813 variable (if declared as C<my $_>) in the current scope, or the
5814 global C<$_>.
5815
5816 =cut
5817 */
5818
5819 OP *
5820 Perl_newDEFSVOP(pTHX)
5821 {
5822     const PADOFFSET offset = pad_findmy_pvs("$_", 0);
5823     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5824         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
5825     }
5826     else {
5827         OP * const o = newOP(OP_PADSV, 0);
5828         o->op_targ = offset;
5829         return o;
5830     }
5831 }
5832
5833 #ifdef USE_ITHREADS
5834
5835 /*
5836 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
5837
5838 Constructs, checks, and returns an op of any type that involves a
5839 reference to a pad element.  C<type> is the opcode.  C<flags> gives the
5840 eight bits of C<op_flags>.  A pad slot is automatically allocated, and
5841 is populated with C<sv>; this function takes ownership of one reference
5842 to it.
5843
5844 This function only exists if Perl has been compiled to use ithreads.
5845
5846 =cut
5847 */
5848
5849 OP *
5850 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
5851 {
5852     dVAR;
5853     PADOP *padop;
5854
5855     PERL_ARGS_ASSERT_NEWPADOP;
5856
5857     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5858         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5859         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5860         || type == OP_CUSTOM);
5861
5862     NewOp(1101, padop, 1, PADOP);
5863     OpTYPE_set(padop, type);
5864     padop->op_padix =
5865         pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
5866     SvREFCNT_dec(PAD_SVl(padop->op_padix));
5867     PAD_SETSV(padop->op_padix, sv);
5868     assert(sv);
5869     padop->op_next = (OP*)padop;
5870     padop->op_flags = (U8)flags;
5871     if (PL_opargs[type] & OA_RETSCALAR)
5872         scalar((OP*)padop);
5873     if (PL_opargs[type] & OA_TARGET)
5874         padop->op_targ = pad_alloc(type, SVs_PADTMP);
5875     return CHECKOP(type, padop);
5876 }
5877
5878 #endif /* USE_ITHREADS */
5879
5880 /*
5881 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
5882
5883 Constructs, checks, and returns an op of any type that involves an
5884 embedded reference to a GV.  C<type> is the opcode.  C<flags> gives the
5885 eight bits of C<op_flags>.  C<gv> identifies the GV that the op should
5886 reference; calling this function does not transfer ownership of any
5887 reference to it.
5888
5889 =cut
5890 */
5891
5892 OP *
5893 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
5894 {
5895     PERL_ARGS_ASSERT_NEWGVOP;
5896
5897 #ifdef USE_ITHREADS
5898     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5899 #else
5900     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5901 #endif
5902 }
5903
5904 /*
5905 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
5906
5907 Constructs, checks, and returns an op of any type that involves an
5908 embedded C-level pointer (PV).  C<type> is the opcode.  C<flags> gives
5909 the eight bits of C<op_flags>.  C<pv> supplies the C-level pointer, which
5910 must have been allocated using C<PerlMemShared_malloc>; the memory will
5911 be freed when the op is destroyed.
5912
5913 =cut
5914 */
5915
5916 OP *
5917 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
5918 {
5919     dVAR;
5920     const bool utf8 = cBOOL(flags & SVf_UTF8);
5921     PVOP *pvop;
5922
5923     flags &= ~SVf_UTF8;
5924
5925     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5926         || type == OP_RUNCV || type == OP_CUSTOM
5927         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5928
5929     NewOp(1101, pvop, 1, PVOP);
5930     OpTYPE_set(pvop, type);
5931     pvop->op_pv = pv;
5932     pvop->op_next = (OP*)pvop;
5933     pvop->op_flags = (U8)flags;
5934     pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
5935     if (PL_opargs[type] & OA_RETSCALAR)
5936         scalar((OP*)pvop);
5937     if (PL_opargs[type] & OA_TARGET)
5938         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
5939     return CHECKOP(type, pvop);
5940 }
5941
5942 void
5943 Perl_package(pTHX_ OP *o)
5944 {
5945     SV *const sv = cSVOPo->op_sv;
5946
5947     PERL_ARGS_ASSERT_PACKAGE;
5948
5949     SAVEGENERICSV(PL_curstash);
5950     save_item(PL_curstname);
5951
5952     PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
5953
5954     sv_setsv(PL_curstname, sv);
5955
5956     PL_hints |= HINT_BLOCK_SCOPE;
5957     PL_parser->copline = NOLINE;
5958
5959     op_free(o);
5960 }
5961
5962 void
5963 Perl_package_version( pTHX_ OP *v )
5964 {
5965     U32 savehints = PL_hints;
5966     PERL_ARGS_ASSERT_PACKAGE_VERSION;
5967     PL_hints &= ~HINT_STRICT_VARS;
5968     sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
5969     PL_hints = savehints;
5970     op_free(v);
5971 }
5972
5973 void
5974 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
5975 {
5976     OP *pack;
5977     OP *imop;
5978     OP *veop;
5979     SV *use_version = NULL;
5980
5981     PERL_ARGS_ASSERT_UTILIZE;
5982
5983     if (idop->op_type != OP_CONST)
5984         Perl_croak(aTHX_ "Module name must be constant");
5985
5986     veop = NULL;
5987
5988     if (version) {
5989         SV * const vesv = ((SVOP*)version)->op_sv;
5990
5991         if (!arg && !SvNIOKp(vesv)) {
5992             arg = version;
5993         }
5994         else {
5995             OP *pack;
5996             SV *meth;
5997
5998             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
5999                 Perl_croak(aTHX_ "Version number must be a constant number");
6000
6001             /* Make copy of idop so we don't free it twice */
6002             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
6003
6004             /* Fake up a method call to VERSION */
6005             meth = newSVpvs_share("VERSION");
6006             veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
6007                             op_append_elem(OP_LIST,
6008                                         op_prepend_elem(OP_LIST, pack, version),
6009                                         newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
6010         }
6011     }
6012
6013     /* Fake up an import/unimport */
6014     if (arg && arg->op_type == OP_STUB) {
6015         imop = arg;             /* no import on explicit () */
6016     }
6017     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
6018         imop = NULL;            /* use 5.0; */
6019         if (aver)
6020             use_version = ((SVOP*)idop)->op_sv;
6021         else
6022             idop->op_private |= OPpCONST_NOVER;
6023     }
6024     else {
6025         SV *meth;
6026
6027         /* Make copy of idop so we don't free it twice */
6028         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
6029
6030         /* Fake up a method call to import/unimport */
6031         meth = aver
6032             ? newSVpvs_share("import") : newSVpvs_share("unimport");
6033         imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
6034                        op_append_elem(OP_LIST,
6035                                    op_prepend_elem(OP_LIST, pack, arg),
6036                                    newMETHOP_named(OP_METHOD_NAMED, 0, meth)
6037                        ));
6038     }
6039
6040     /* Fake up the BEGIN {}, which does its thing immediately. */
6041     newATTRSUB(floor,
6042         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
6043         NULL,
6044         NULL,
6045         op_append_elem(OP_LINESEQ,
6046             op_append_elem(OP_LINESEQ,
6047                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
6048                 newSTATEOP(0, NULL, veop)),
6049             newSTATEOP(0, NULL, imop) ));
6050
6051     if (use_version) {
6052         /* Enable the
6053          * feature bundle that corresponds to the required version. */
6054         use_version = sv_2mortal(new_version(use_version));
6055         S_enable_feature_bundle(aTHX_ use_version);
6056
6057         /* If a version >= 5.11.0 is requested, strictures are on by default! */
6058         if (vcmp(use_version,
6059                  sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
6060             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
6061                 PL_hints |= HINT_STRICT_REFS;
6062             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
6063                 PL_hints |= HINT_STRICT_SUBS;
6064             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
6065                 PL_hints |= HINT_STRICT_VARS;
6066         }
6067         /* otherwise they are off */
6068         else {
6069             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
6070                 PL_hints &= ~HINT_STRICT_REFS;
6071             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
6072                 PL_hints &= ~HINT_STRICT_SUBS;
6073             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
6074                 PL_hints &= ~HINT_STRICT_VARS;
6075         }
6076     }
6077
6078     /* The "did you use incorrect case?" warning used to be here.
6079      * The problem is that on case-insensitive filesystems one
6080      * might get false positives for "use" (and "require"):
6081      * "use Strict" or "require CARP" will work.  This causes
6082      * portability problems for the script: in case-strict
6083      * filesystems the script will stop working.
6084      *
6085      * The "incorrect case" warning checked whether "use Foo"
6086      * imported "Foo" to your namespace, but that is wrong, too:
6087      * there is no requirement nor promise in the language that
6088      * a Foo.pm should or would contain anything in package "Foo".
6089      *
6090      * There is very little Configure-wise that can be done, either:
6091      * the case-sensitivity of the build filesystem of Perl does not
6092      * help in guessing the case-sensitivity of the runtime environment.
6093      */
6094
6095     PL_hints |= HINT_BLOCK_SCOPE;
6096     PL_parser->copline = NOLINE;
6097     COP_SEQMAX_INC; /* Purely for B::*'s benefit */
6098 }
6099
6100 /*
6101 =head1 Embedding Functions
6102
6103 =for apidoc load_module
6104
6105 Loads the module whose name is pointed to by the string part of name.
6106 Note that the actual module name, not its filename, should be given.
6107 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
6108 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
6109 (or 0 for no flags).  ver, if specified
6110 and not NULL, provides version semantics
6111 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
6112 arguments can be used to specify arguments to the module's import()
6113 method, similar to C<use Foo::Bar VERSION LIST>.  They must be
6114 terminated with a final NULL pointer.  Note that this list can only
6115 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
6116 Otherwise at least a single NULL pointer to designate the default
6117 import list is required.
6118
6119 The reference count for each specified C<SV*> parameter is decremented.
6120
6121 =cut */
6122
6123 void
6124 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
6125 {
6126     va_list args;
6127
6128     PERL_ARGS_ASSERT_LOAD_MODULE;
6129
6130     va_start(args, ver);
6131     vload_module(flags, name, ver, &args);
6132     va_end(args);
6133 }
6134
6135 #ifdef PERL_IMPLICIT_CONTEXT
6136 void
6137 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
6138 {
6139     dTHX;
6140     va_list args;
6141     PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
6142     va_start(args, ver);
6143     vload_module(flags, name, ver, &args);
6144     va_end(args);
6145 }
6146 #endif
6147
6148 void
6149 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
6150 {
6151     OP *veop, *imop;
6152     OP * const modname = newSVOP(OP_CONST, 0, name);
6153
6154     PERL_ARGS_ASSERT_VLOAD_MODULE;
6155
6156     modname->op_private |= OPpCONST_BARE;
6157     if (ver) {
6158         veop = newSVOP(OP_CONST, 0, ver);
6159     }
6160     else
6161         veop = NULL;
6162     if (flags & PERL_LOADMOD_NOIMPORT) {
6163         imop = sawparens(newNULLLIST());
6164     }
6165     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
6166         imop = va_arg(*args, OP*);
6167     }
6168     else {
6169         SV *sv;
6170         imop = NULL;
6171         sv = va_arg(*args, SV*);
6172         while (sv) {
6173             imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
6174             sv = va_arg(*args, SV*);
6175         }
6176     }
6177
6178     /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
6179      * that it has a PL_parser to play with while doing that, and also
6180      * that it doesn't mess with any existing parser, by creating a tmp
6181      * new parser with lex_start(). This won't actually be used for much,
6182      * since pp_require() will create another parser for the real work.
6183      * The ENTER/LEAVE pair protect callers from any side effects of use.  */
6184
6185     ENTER;
6186     SAVEVPTR(PL_curcop);
6187     lex_start(NULL, NULL, LEX_START_SAME_FILTER);
6188     utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
6189             veop, modname, imop);
6190     LEAVE;
6191 }
6192
6193 PERL_STATIC_INLINE OP *
6194 S_new_entersubop(pTHX_ GV *gv, OP *arg)
6195 {
6196     return newUNOP(OP_ENTERSUB, OPf_STACKED,
6197                    newLISTOP(OP_LIST, 0, arg,
6198                              newUNOP(OP_RV2CV, 0,
6199                                      newGVOP(OP_GV, 0, gv))));
6200 }
6201
6202 OP *
6203 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
6204 {
6205     OP *doop;
6206     GV *gv;
6207
6208     PERL_ARGS_ASSERT_DOFILE;
6209
6210     if (!force_builtin && (gv = gv_override("do", 2))) {
6211         doop = S_new_entersubop(aTHX_ gv, term);
6212     }
6213     else {
6214         doop = newUNOP(OP_DOFILE, 0, scalar(term));
6215     }
6216     return doop;
6217 }
6218
6219 /*
6220 =head1 Optree construction
6221
6222 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
6223
6224 Constructs, checks, and returns an C<lslice> (list slice) op.  C<flags>
6225 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
6226 be set automatically, and, shifted up eight bits, the eight bits of
6227 C<op_private>, except that the bit with value 1 or 2 is automatically
6228 set as required.  C<listval> and C<subscript> supply the parameters of
6229 the slice; they are consumed by this function and become part of the
6230 constructed op tree.
6231
6232 =cut
6233 */
6234
6235 OP *
6236 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
6237 {
6238     return newBINOP(OP_LSLICE, flags,
6239             list(force_list(subscript, 1)),
6240             list(force_list(listval,   1)) );
6241 }
6242
6243 #define ASSIGN_LIST   1
6244 #define ASSIGN_REF    2
6245
6246 STATIC I32
6247 S_assignment_type(pTHX_ const OP *o)
6248 {
6249     unsigned type;
6250     U8 flags;
6251     U8 ret;
6252
6253     if (!o)
6254         return TRUE;
6255
6256     if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
6257         o = cUNOPo->op_first;
6258
6259     flags = o->op_flags;
6260     type = o->op_type;
6261     if (type == OP_COND_EXPR) {
6262         OP * const sib = OpSIBLING(cLOGOPo->op_first);
6263         const I32 t = assignment_type(sib);
6264         const I32 f = assignment_type(OpSIBLING(sib));
6265
6266         if (t == ASSIGN_LIST && f == ASSIGN_LIST)
6267             return ASSIGN_LIST;
6268         if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
6269             yyerror("Assignment to both a list and a scalar");
6270         return FALSE;
6271     }
6272
6273     if (type == OP_SREFGEN)
6274     {
6275         OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
6276         type = kid->op_type;
6277         flags |= kid->op_flags;
6278         if (!(flags & OPf_PARENS)
6279           && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
6280               kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
6281             return ASSIGN_REF;
6282         ret = ASSIGN_REF;
6283     }
6284     else ret = 0;
6285
6286     if (type == OP_LIST &&
6287         (flags & OPf_WANT) == OPf_WANT_SCALAR &&
6288         o->op_private & OPpLVAL_INTRO)
6289         return ret;
6290
6291     if (type == OP_LIST || flags & OPf_PARENS ||
6292         type == OP_RV2AV || type == OP_RV2HV ||
6293         type == OP_ASLICE || type == OP_HSLICE ||
6294         type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
6295         return TRUE;
6296
6297     if (type == OP_PADAV || type == OP_PADHV)
6298         return TRUE;
6299
6300     if (type == OP_RV2SV)
6301         return ret;
6302
6303     return ret;
6304 }
6305
6306 /*
6307   Helper function for newASSIGNOP to detect commonality between the
6308   lhs and the rhs.  (It is actually called very indirectly.  newASSIGNOP
6309   flags the op and the peephole optimizer calls this helper function
6310   if the flag is set.)  Marks all variables with PL_generation.  If it
6311   returns TRUE the assignment must be able to handle common variables.
6312
6313   PL_generation sorcery:
6314   An assignment like ($a,$b) = ($c,$d) is easier than
6315   ($a,$b) = ($c,$a), since there is no need for temporary vars.
6316   To detect whether there are common vars, the global var
6317   PL_generation is incremented for each assign op we compile.
6318   Then, while compiling the assign op, we run through all the
6319   variables on both sides of the assignment, setting a spare slot
6320   in each of them to PL_generation.  If any of them already have
6321   that value, we know we've got commonality.  Also, if the
6322   generation number is already set to PERL_INT_MAX, then
6323   the variable is involved in aliasing, so we also have
6324   potential commonality in that case.  We could use a
6325   single bit marker, but then we'd have to make 2 passes, first
6326   to clear the flag, then to test and set it.  And that
6327   wouldn't help with aliasing, either.  To find somewhere
6328   to store these values, evil chicanery is done with SvUVX().
6329 */
6330 PERL_STATIC_INLINE bool
6331 S_aassign_common_vars(pTHX_ OP* o)
6332 {
6333     OP *curop;
6334     for (curop = cUNOPo->op_first; curop; curop = OpSIBLING(curop)) {
6335         if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
6336             if (curop->op_type == OP_GV || curop->op_type == OP_GVSV
6337              || curop->op_type == OP_AELEMFAST) {
6338                 GV *gv = cGVOPx_gv(curop);
6339                 if (gv == PL_defgv
6340                     || (int)GvASSIGN_GENERATION(gv) == PL_generation)
6341                     return TRUE;
6342                 GvASSIGN_GENERATION_set(gv, PL_generation);
6343             }
6344             else if (curop->op_type == OP_PADSV ||
6345                 curop->op_type == OP_PADAV ||
6346                 curop->op_type == OP_PADHV ||
6347                 curop->op_type == OP_AELEMFAST_LEX ||
6348                 curop->op_type == OP_PADANY)
6349                 {
6350                   padcheck:
6351                     if (PAD_COMPNAME_GEN(curop->op_targ)
6352                         == (STRLEN)PL_generation
6353                      || PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX)
6354                         return TRUE;
6355                     PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
6356
6357                 }
6358             else if (curop->op_type == OP_RV2CV)
6359                 return TRUE;
6360             else if (curop->op_type == OP_RV2SV ||
6361                 curop->op_type == OP_RV2AV ||
6362                 curop->op_type == OP_RV2HV ||
6363                 curop->op_type == OP_RV2GV) {
6364                 if (cUNOPx(curop)->op_first->op_type != OP_GV)  /* funny deref? */
6365                     return TRUE;
6366             }
6367             else if (curop->op_type == OP_PUSHRE) {
6368                 GV *const gv =
6369 #ifdef USE_ITHREADS
6370                     ((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff
6371                         ? MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff))
6372                         : NULL;
6373 #else
6374                     ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
6375 #endif
6376                 if (gv) {
6377                     if (gv == PL_defgv
6378                         || (int)GvASSIGN_GENERATION(gv) == PL_generation)
6379                         return TRUE;
6380                     GvASSIGN_GENERATION_set(gv, PL_generation);
6381                 }
6382                 else if (curop->op_targ)
6383                     goto padcheck;
6384             }
6385             else if (curop->op_type == OP_PADRANGE)
6386                 /* Ignore padrange; checking its siblings is sufficient. */
6387                 continue;
6388             else
6389                 return TRUE;
6390         }
6391         else if (PL_opargs[curop->op_type] & OA_TARGLEX
6392               && curop->op_private & OPpTARGET_MY)
6393             goto padcheck;
6394
6395         if (curop->op_flags & OPf_KIDS) {
6396             if (aassign_common_vars(curop))
6397                 return TRUE;
6398         }
6399     }
6400     return FALSE;
6401 }
6402
6403 /* This variant only handles lexical aliases.  It is called when
6404    newASSIGNOP decides that we don’t have any common vars, as lexical ali-
6405    ases trump that decision.  */
6406 PERL_STATIC_INLINE bool
6407 S_aassign_common_vars_aliases_only(pTHX_ OP *o)
6408 {
6409     OP *curop;
6410     for (curop = cUNOPo->op_first; curop; curop = OpSIBLING(curop)) {
6411         if ((curop->op_type == OP_PADSV ||
6412              curop->op_type == OP_PADAV ||
6413              curop->op_type == OP_PADHV ||
6414              curop->op_type == OP_AELEMFAST_LEX ||
6415              curop->op_type == OP_PADANY ||
6416              (  PL_opargs[curop->op_type] & OA_TARGLEX
6417              && curop->op_private & OPpTARGET_MY  ))
6418            && PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX)
6419             return TRUE;
6420
6421         if (curop->op_type == OP_PUSHRE && curop->op_targ
6422          && PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX)
6423             return TRUE;
6424
6425         if (curop->op_flags & OPf_KIDS) {
6426             if (S_aassign_common_vars_aliases_only(aTHX_ curop))
6427                 return TRUE;
6428         }
6429     }
6430     return FALSE;
6431 }
6432
6433 /*
6434 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
6435
6436 Constructs, checks, and returns an assignment op.  C<left> and C<right>
6437 supply the parameters of the assignment; they are consumed by this
6438 function and become part of the constructed op tree.
6439
6440 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
6441 a suitable conditional optree is constructed.  If C<optype> is the opcode
6442 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
6443 performs the binary operation and assigns the result to the left argument.
6444 Either way, if C<optype> is non-zero then C<flags> has no effect.
6445
6446 If C<optype> is zero, then a plain scalar or list assignment is
6447 constructed.  Which type of assignment it is is automatically determined.
6448 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6449 will be set automatically, and, shifted up eight bits, the eight bits
6450 of C<op_private>, except that the bit with value 1 or 2 is automatically
6451 set as required.
6452
6453 =cut
6454 */
6455
6456 OP *
6457 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
6458 {
6459     OP *o;
6460     I32 assign_type;
6461
6462     if (optype) {
6463         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
6464             return newLOGOP(optype, 0,
6465                 op_lvalue(scalar(left), optype),
6466                 newUNOP(OP_SASSIGN, 0, scalar(right)));
6467         }
6468         else {
6469             return newBINOP(optype, OPf_STACKED,
6470                 op_lvalue(scalar(left), optype), scalar(right));
6471         }
6472     }
6473
6474     if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
6475         static const char no_list_state[] = "Initialization of state variables"
6476             " in list context currently forbidden";
6477         OP *curop;
6478         bool maybe_common_vars = TRUE;
6479
6480         if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
6481             left->op_private &= ~ OPpSLICEWARNING;
6482
6483         PL_modcount = 0;
6484         left = op_lvalue(left, OP_AASSIGN);
6485         curop = list(force_list(left, 1));
6486         o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
6487         o->op_private = (U8)(0 | (flags >> 8));
6488
6489         if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
6490         {
6491             OP* lop = ((LISTOP*)left)->op_first;
6492             maybe_common_vars = FALSE;
6493             while (lop) {
6494                 if (lop->op_type == OP_PADSV ||
6495                     lop->op_type == OP_PADAV ||
6496                     lop->op_type == OP_PADHV ||
6497                     lop->op_type == OP_PADANY) {
6498                     if (!(lop->op_private & OPpLVAL_INTRO))
6499                         maybe_common_vars = TRUE;
6500
6501                     if (lop->op_private & OPpPAD_STATE) {
6502                         if (left->op_private & OPpLVAL_INTRO) {
6503                             /* Each variable in state($a, $b, $c) = ... */
6504                         }
6505                         else {
6506                             /* Each state variable in
6507                                (state $a, my $b, our $c, $d, undef) = ... */
6508                         }
6509                         yyerror(no_list_state);
6510                     } else {
6511                         /* Each my variable in
6512                            (state $a, my $b, our $c, $d, undef) = ... */
6513                     }
6514                 } else if (lop->op_type == OP_UNDEF ||
6515                            OP_TYPE_IS_OR_WAS(lop, OP_PUSHMARK)) {
6516                     /* undef may be interesting in
6517                        (state $a, undef, state $c) */
6518                 } else {
6519                     /* Other ops in the list. */
6520                     maybe_common_vars = TRUE;
6521                 }
6522                 lop = OpSIBLING(lop);
6523             }
6524         }
6525         else if ((left->op_private & OPpLVAL_INTRO)
6526                 && (   left->op_type == OP_PADSV
6527                     || left->op_type == OP_PADAV
6528                     || left->op_type == OP_PADHV
6529                     || left->op_type == OP_PADANY))
6530         {
6531             if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
6532             if (left->op_private & OPpPAD_STATE) {
6533                 /* All single variable list context state assignments, hence
6534                    state ($a) = ...
6535                    (state $a) = ...
6536                    state @a = ...
6537                    state (@a) = ...
6538                    (state @a) = ...
6539                    state %a = ...
6540                    state (%a) = ...
6541                    (state %a) = ...
6542                 */
6543                 yyerror(no_list_state);
6544             }
6545         }
6546
6547         if (maybe_common_vars) {
6548                 /* The peephole optimizer will do the full check and pos-
6549                    sibly turn this off.  */
6550                 o->op_private |= OPpASSIGN_COMMON;
6551         }
6552
6553         if (right && right->op_type == OP_SPLIT
6554          && !(right->op_flags & OPf_STACKED)) {
6555             OP* tmpop = ((LISTOP*)right)->op_first;
6556             PMOP * const pm = (PMOP*)tmpop;
6557             assert (tmpop && (tmpop->op_type == OP_PUSHRE));
6558             if (
6559 #ifdef USE_ITHREADS
6560                     !pm->op_pmreplrootu.op_pmtargetoff
6561 #else
6562                     !pm->op_pmreplrootu.op_pmtargetgv
6563 #endif
6564                  && !pm->op_targ
6565                 ) {
6566                     if (!(left->op_private & OPpLVAL_INTRO) &&
6567                         ( (left->op_type == OP_RV2AV &&
6568                           (tmpop=((UNOP*)left)->op_first)->op_type==OP_GV)
6569                         || left->op_type == OP_PADAV )
6570                         ) {
6571                         if (tmpop != (OP *)pm) {
6572 #ifdef USE_ITHREADS
6573                           pm->op_pmreplrootu.op_pmtargetoff
6574                             = cPADOPx(tmpop)->op_padix;
6575                           cPADOPx(tmpop)->op_padix = 0; /* steal it */
6576 #else
6577                           pm->op_pmreplrootu.op_pmtargetgv
6578                             = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
6579                           cSVOPx(tmpop)->op_sv = NULL;  /* steal it */
6580 #endif
6581                           right->op_private |=
6582                             left->op_private & OPpOUR_INTRO;
6583                         }
6584                         else {
6585                             pm->op_targ = left->op_targ;
6586                             left->op_targ = 0; /* filch it */
6587                         }
6588                       detach_split:
6589                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
6590                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
6591                         /* detach rest of siblings from o subtree,
6592                          * and free subtree */
6593                         op_sibling_splice(cUNOPo->op_first, tmpop, -1, NULL);
6594                         op_free(o);                     /* blow off assign */
6595                         right->op_flags &= ~OPf_WANT;
6596                                 /* "I don't know and I don't care." */
6597                         return right;
6598                     }
6599                     else if (left->op_type == OP_RV2AV
6600                           || left->op_type == OP_PADAV)
6601                     {
6602                         /* Detach the array.  */
6603 #ifdef DEBUGGING
6604                         OP * const ary =
6605 #endif
6606                         op_sibling_splice(cBINOPo->op_last,
6607                                           cUNOPx(cBINOPo->op_last)
6608                                                 ->op_first, 1, NULL);
6609                         assert(ary == left);
6610                         /* Attach it to the split.  */
6611                         op_sibling_splice(right, cLISTOPx(right)->op_last,
6612                                           0, left);
6613                         right->op_flags |= OPf_STACKED;
6614                         /* Detach split and expunge aassign as above.  */
6615                         goto detach_split;
6616                     }
6617                     else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
6618                             ((LISTOP*)right)->op_last->op_type == OP_CONST)
6619                     {
6620                         SV ** const svp =
6621                             &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
6622                         SV * const sv = *svp;
6623                         if (SvIOK(sv) && SvIVX(sv) == 0)
6624                         {
6625                           if (right->op_private & OPpSPLIT_IMPLIM) {
6626                             /* our own SV, created in ck_split */
6627                             SvREADONLY_off(sv);
6628                             sv_setiv(sv, PL_modcount+1);
6629                           }
6630                           else {
6631                             /* SV may belong to someone else */
6632                             SvREFCNT_dec(sv);
6633                             *svp = newSViv(PL_modcount+1);
6634                           }
6635                         }
6636                     }
6637             }
6638         }
6639         return o;
6640     }
6641     if (assign_type == ASSIGN_REF)
6642         return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
6643     if (!right)
6644         right = newOP(OP_UNDEF, 0);
6645     if (right->op_type == OP_READLINE) {
6646         right->op_flags |= OPf_STACKED;
6647         return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
6648                 scalar(right));
6649     }
6650     else {
6651         o = newBINOP(OP_SASSIGN, flags,
6652             scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
6653     }
6654     return o;
6655 }
6656
6657 /*
6658 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
6659
6660 Constructs a state op (COP).  The state op is normally a C<nextstate> op,
6661 but will be a C<dbstate> op if debugging is enabled for currently-compiled
6662 code.  The state op is populated from C<PL_curcop> (or C<PL_compiling>).
6663 If C<label> is non-null, it supplies the name of a label to attach to
6664 the state op; this function takes ownership of the memory pointed at by
6665 C<label>, and will free it.  C<flags> gives the eight bits of C<op_flags>
6666 for the state op.
6667
6668 If C<o> is null, the state op is returned.  Otherwise the state op is
6669 combined with C<o> into a C<lineseq> list op, which is returned.  C<o>
6670 is consumed by this function and becomes part of the returned op tree.
6671
6672 =cut
6673 */
6674
6675 OP *
6676 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
6677 {
6678     dVAR;
6679     const U32 seq = intro_my();
6680     const U32 utf8 = flags & SVf_UTF8;
6681     COP *cop;
6682
6683     PL_parser->parsed_sub = 0;
6684
6685     flags &= ~SVf_UTF8;
6686
6687     NewOp(1101, cop, 1, COP);
6688     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
6689         OpTYPE_set(cop, OP_DBSTATE);
6690     }
6691     else {
6692         OpTYPE_set(cop, OP_NEXTSTATE);
6693     }
6694     cop->op_flags = (U8)flags;
6695     CopHINTS_set(cop, PL_hints);
6696 #ifdef VMS
6697     if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
6698 #endif
6699     cop->op_next = (OP*)cop;
6700
6701     cop->cop_seq = seq;
6702     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
6703     CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
6704     if (label) {
6705         Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
6706
6707         PL_hints |= HINT_BLOCK_SCOPE;
6708         /* It seems that we need to defer freeing this pointer, as other parts
6709            of the grammar end up wanting to copy it after this op has been
6710            created. */
6711         SAVEFREEPV(label);
6712     }
6713
6714     if (PL_parser->preambling != NOLINE) {
6715         CopLINE_set(cop, PL_parser->preambling);
6716         PL_parser->copline = NOLINE;
6717     }
6718     else if (PL_parser->copline == NOLINE)
6719         CopLINE_set(cop, CopLINE(PL_curcop));
6720     else {
6721         CopLINE_set(cop, PL_parser->copline);
6722         PL_parser->copline = NOLINE;
6723     }
6724 #ifdef USE_ITHREADS
6725     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
6726 #else
6727     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
6728 #endif
6729     CopSTASH_set(cop, PL_curstash);
6730
6731     if (cop->op_type == OP_DBSTATE) {
6732         /* this line can have a breakpoint - store the cop in IV */
6733         AV *av = CopFILEAVx(PL_curcop);
6734         if (av) {
6735             SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
6736             if (svp && *svp != &PL_sv_undef ) {
6737                 (void)SvIOK_on(*svp);
6738                 SvIV_set(*svp, PTR2IV(cop));
6739             }
6740         }
6741     }
6742
6743     if (flags & OPf_SPECIAL)
6744         op_null((OP*)cop);
6745     return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
6746 }
6747
6748 /*
6749 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
6750
6751 Constructs, checks, and returns a logical (flow control) op.  C<type>
6752 is the opcode.  C<flags> gives the eight bits of C<op_flags>, except
6753 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6754 the eight bits of C<op_private>, except that the bit with value 1 is
6755 automatically set.  C<first> supplies the expression controlling the
6756 flow, and C<other> supplies the side (alternate) chain of ops; they are
6757 consumed by this function and become part of the constructed op tree.
6758
6759 =cut
6760 */
6761
6762 OP *
6763 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
6764 {
6765     PERL_ARGS_ASSERT_NEWLOGOP;
6766
6767     return new_logop(type, flags, &first, &other);
6768 }
6769
6770 STATIC OP *
6771 S_search_const(pTHX_ OP *o)
6772 {
6773     PERL_ARGS_ASSERT_SEARCH_CONST;
6774
6775     switch (o->op_type) {
6776         case OP_CONST:
6777             return o;
6778         case OP_NULL:
6779             if (o->op_flags & OPf_KIDS)
6780                 return search_const(cUNOPo->op_first);
6781             break;
6782         case OP_LEAVE:
6783         case OP_SCOPE:
6784         case OP_LINESEQ:
6785         {
6786             OP *kid;
6787             if (!(o->op_flags & OPf_KIDS))
6788                 return NULL;
6789             kid = cLISTOPo->op_first;
6790             do {
6791                 switch (kid->op_type) {
6792                     case OP_ENTER:
6793                     case OP_NULL:
6794                     case OP_NEXTSTATE:
6795                         kid = OpSIBLING(kid);
6796                         break;
6797                     default:
6798                         if (kid != cLISTOPo->op_last)
6799                             return NULL;
6800                         goto last;
6801                 }
6802             } while (kid);
6803             if (!kid)
6804                 kid = cLISTOPo->op_last;
6805           last:
6806             return search_const(kid);
6807         }
6808     }
6809
6810     return NULL;
6811 }
6812
6813 STATIC OP *
6814 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
6815 {
6816     dVAR;
6817     LOGOP *logop;
6818     OP *o;
6819     OP *first;
6820     OP *other;
6821     OP *cstop = NULL;
6822     int prepend_not = 0;
6823
6824     PERL_ARGS_ASSERT_NEW_LOGOP;
6825
6826     first = *firstp;
6827     other = *otherp;
6828
6829     /* [perl #59802]: Warn about things like "return $a or $b", which
6830        is parsed as "(return $a) or $b" rather than "return ($a or
6831        $b)".  NB: This also applies to xor, which is why we do it
6832        here.
6833      */
6834     switch (first->op_type) {
6835     case OP_NEXT:
6836     case OP_LAST:
6837     case OP_REDO:
6838         /* XXX: Perhaps we should emit a stronger warning for these.
6839            Even with the high-precedence operator they don't seem to do
6840            anything sensible.
6841
6842            But until we do, fall through here.
6843          */
6844     case OP_RETURN:
6845     case OP_EXIT:
6846     case OP_DIE:
6847     case OP_GOTO:
6848         /* XXX: Currently we allow people to "shoot themselves in the
6849            foot" by explicitly writing "(return $a) or $b".
6850
6851            Warn unless we are looking at the result from folding or if
6852            the programmer explicitly grouped the operators like this.
6853            The former can occur with e.g.
6854
6855                 use constant FEATURE => ( $] >= ... );
6856                 sub { not FEATURE and return or do_stuff(); }
6857          */
6858         if (!first->op_folded && !(first->op_flags & OPf_PARENS))
6859             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6860                            "Possible precedence issue with control flow operator");
6861         /* XXX: Should we optimze this to "return $a;" (i.e. remove
6862            the "or $b" part)?
6863         */
6864         break;
6865     }
6866
6867     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
6868         return newBINOP(type, flags, scalar(first), scalar(other));
6869
6870     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
6871         || type == OP_CUSTOM);
6872
6873     scalarboolean(first);
6874     /* optimize AND and OR ops that have NOTs as children */
6875     if (first->op_type == OP_NOT
6876         && (first->op_flags & OPf_KIDS)
6877         && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
6878             || (other->op_type == OP_NOT))  /* if (!$x && !$y) { } */
6879         ) {
6880         if (type == OP_AND || type == OP_OR) {
6881             if (type == OP_AND)
6882                 type = OP_OR;
6883             else
6884                 type = OP_AND;
6885             op_null(first);
6886             if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
6887                 op_null(other);
6888                 prepend_not = 1; /* prepend a NOT op later */
6889             }
6890         }
6891     }
6892     /* search for a constant op that could let us fold the test */
6893     if ((cstop = search_const(first))) {
6894         if (cstop->op_private & OPpCONST_STRICT)
6895             no_bareword_allowed(cstop);
6896         else if ((cstop->op_private & OPpCONST_BARE))
6897                 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
6898         if ((type == OP_AND &&  SvTRUE(((SVOP*)cstop)->op_sv)) ||
6899             (type == OP_OR  && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
6900             (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
6901             *firstp = NULL;
6902             if (other->op_type == OP_CONST)
6903                 other->op_private |= OPpCONST_SHORTCIRCUIT;
6904             op_free(first);
6905             if (other->op_type == OP_LEAVE)
6906                 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
6907             else if (other->op_type == OP_MATCH
6908                   || other->op_type == OP_SUBST
6909                   || other->op_type == OP_TRANSR
6910                   || other->op_type == OP_TRANS)
6911                 /* Mark the op as being unbindable with =~ */
6912                 other->op_flags |= OPf_SPECIAL;
6913
6914             other->op_folded = 1;
6915             return other;
6916         }
6917         else {
6918             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
6919             const OP *o2 = other;
6920             if ( ! (o2->op_type == OP_LIST
6921                     && (( o2 = cUNOPx(o2)->op_first))
6922                     && o2->op_type == OP_PUSHMARK
6923                     && (( o2 = OpSIBLING(o2))) )
6924             )
6925                 o2 = other;
6926             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
6927                         || o2->op_type == OP_PADHV)
6928                 && o2->op_private & OPpLVAL_INTRO
6929                 && !(o2->op_private & OPpPAD_STATE))
6930             {
6931                 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6932                                  "Deprecated use of my() in false conditional");
6933             }
6934
6935             *otherp = NULL;
6936             if (cstop->op_type == OP_CONST)
6937                 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
6938                 op_free(other);
6939             return first;
6940         }
6941     }
6942     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
6943         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
6944     {
6945         const OP * const k1 = ((UNOP*)first)->op_first;
6946         const OP * const k2 = OpSIBLING(k1);
6947         OPCODE warnop = 0;
6948         switch (first->op_type)
6949         {
6950         case OP_NULL:
6951             if (k2 && k2->op_type == OP_READLINE
6952                   && (k2->op_flags & OPf_STACKED)
6953                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6954             {
6955                 warnop = k2->op_type;
6956             }
6957             break;
6958
6959         case OP_SASSIGN:
6960             if (k1->op_type == OP_READDIR
6961                   || k1->op_type == OP_GLOB
6962                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6963                  || k1->op_type == OP_EACH
6964                  || k1->op_type == OP_AEACH)
6965             {
6966                 warnop = ((k1->op_type == OP_NULL)
6967                           ? (OPCODE)k1->op_targ : k1->op_type);
6968             }
6969             break;
6970         }
6971         if (warnop) {
6972             const line_t oldline = CopLINE(PL_curcop);
6973             /* This ensures that warnings are reported at the first line
6974                of the construction, not the last.  */
6975             CopLINE_set(PL_curcop, PL_parser->copline);
6976             Perl_warner(aTHX_ packWARN(WARN_MISC),
6977                  "Value of %s%s can be \"0\"; test with defined()",
6978                  PL_op_desc[warnop],
6979                  ((warnop == OP_READLINE || warnop == OP_GLOB)
6980                   ? " construct" : "() operator"));
6981             CopLINE_set(PL_curcop, oldline);
6982         }
6983     }
6984
6985     if (!other)
6986         return first;
6987
6988     if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
6989         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
6990
6991     logop = S_alloc_LOGOP(aTHX_ type, first, LINKLIST(other));
6992     logop->op_flags |= (U8)flags;
6993     logop->op_private = (U8)(1 | (flags >> 8));
6994
6995     /* establish postfix order */
6996     logop->op_next = LINKLIST(first);
6997     first->op_next = (OP*)logop;
6998     assert(!OpHAS_SIBLING(first));
6999     op_sibling_splice((OP*)logop, first, 0, other);
7000
7001     CHECKOP(type,logop);
7002
7003     o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
7004                 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
7005                 (OP*)logop);
7006     other->op_next = o;
7007
7008     return o;
7009 }
7010
7011 /*
7012 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
7013
7014 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
7015 op.  C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
7016 will be set automatically, and, shifted up eight bits, the eight bits of
7017 C<op_private>, except that the bit with value 1 is automatically set.
7018 C<first> supplies the expression selecting between the two branches,
7019 and C<trueop> and C<falseop> supply the branches; they are consumed by
7020 this function and become part of the constructed op tree.
7021
7022 =cut
7023 */
7024
7025 OP *
7026 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
7027 {
7028     dVAR;
7029     LOGOP *logop;
7030     OP *start;
7031     OP *o;
7032     OP *cstop;
7033
7034     PERL_ARGS_ASSERT_NEWCONDOP;
7035
7036     if (!falseop)
7037         return newLOGOP(OP_AND, 0, first, trueop);
7038     if (!trueop)
7039         return newLOGOP(OP_OR, 0, first, falseop);
7040
7041     scalarboolean(first);
7042     if ((cstop = search_const(first))) {
7043         /* Left or right arm of the conditional?  */
7044         const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
7045         OP *live = left ? trueop : falseop;
7046         OP *const dead = left ? falseop : trueop;
7047         if (cstop->op_private & OPpCONST_BARE &&
7048             cstop->op_private & OPpCONST_STRICT) {
7049             no_bareword_allowed(cstop);
7050         }
7051         op_free(first);
7052         op_free(dead);
7053         if (live->op_type == OP_LEAVE)
7054             live = newUNOP(OP_NULL, OPf_SPECIAL, live);
7055         else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
7056               || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
7057             /* Mark the op as being unbindable with =~ */
7058             live->op_flags |= OPf_SPECIAL;
7059         live->op_folded = 1;
7060         return live;
7061     }
7062     logop = S_alloc_LOGOP(aTHX_ OP_COND_EXPR, first, LINKLIST(trueop));
7063     logop->op_flags |= (U8)flags;
7064     logop->op_private = (U8)(1 | (flags >> 8));
7065     logop->op_next = LINKLIST(falseop);
7066
7067     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
7068             logop);
7069
7070     /* establish postfix order */
7071     start = LINKLIST(first);
7072     first->op_next = (OP*)logop;
7073
7074     /* make first, trueop, falseop siblings */
7075     op_sibling_splice((OP*)logop, first,  0, trueop);
7076     op_sibling_splice((OP*)logop, trueop, 0, falseop);
7077
7078     o = newUNOP(OP_NULL, 0, (OP*)logop);
7079
7080     trueop->op_next = falseop->op_next = o;
7081
7082     o->op_next = start;
7083     return o;
7084 }
7085
7086 /*
7087 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
7088
7089 Constructs and returns a C<range> op, with subordinate C<flip> and
7090 C<flop> ops.  C<flags> gives the eight bits of C<op_flags> for the
7091 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
7092 for both the C<flip> and C<range> ops, except that the bit with value
7093 1 is automatically set.  C<left> and C<right> supply the expressions
7094 controlling the endpoints of the range; they are consumed by this function
7095 and become part of the constructed op tree.
7096
7097 =cut
7098 */
7099
7100 OP *
7101 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
7102 {
7103     LOGOP *range;
7104     OP *flip;
7105     OP *flop;
7106     OP *leftstart;
7107     OP *o;
7108
7109     PERL_ARGS_ASSERT_NEWRANGE;
7110
7111     range = S_alloc_LOGOP(aTHX_ OP_RANGE, left, LINKLIST(right));
7112     range->op_flags = OPf_KIDS;
7113     leftstart = LINKLIST(left);
7114     range->op_private = (U8)(1 | (flags >> 8));
7115
7116     /* make left and right siblings */
7117     op_sibling_splice((OP*)range, left, 0, right);
7118
7119     range->op_next = (OP*)range;
7120     flip = newUNOP(OP_FLIP, flags, (OP*)range);
7121     flop = newUNOP(OP_FLOP, 0, flip);
7122     o = newUNOP(OP_NULL, 0, flop);
7123     LINKLIST(flop);
7124     range->op_next = leftstart;
7125
7126     left->op_next = flip;
7127     right->op_next = flop;
7128
7129     range->op_targ =
7130         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
7131     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
7132     flip->op_targ =
7133         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
7134     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
7135     SvPADTMP_on(PAD_SV(flip->op_targ));
7136
7137     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
7138     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
7139
7140     /* check barewords before they might be optimized aways */
7141     if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
7142         no_bareword_allowed(left);
7143     if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
7144         no_bareword_allowed(right);
7145
7146     flip->op_next = o;
7147     if (!flip->op_private || !flop->op_private)
7148         LINKLIST(o);            /* blow off optimizer unless constant */
7149
7150     return o;
7151 }
7152
7153 /*
7154 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
7155
7156 Constructs, checks, and returns an op tree expressing a loop.  This is
7157 only a loop in the control flow through the op tree; it does not have
7158 the heavyweight loop structure that allows exiting the loop by C<last>
7159 and suchlike.  C<flags> gives the eight bits of C<op_flags> for the
7160 top-level op, except that some bits will be set automatically as required.
7161 C<expr> supplies the expression controlling loop iteration, and C<block>
7162 supplies the body of the loop; they are consumed by this function and
7163 become part of the constructed op tree.  C<debuggable> is currently
7164 unused and should always be 1.
7165
7166 =cut
7167 */
7168
7169 OP *
7170 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
7171 {
7172     OP* listop;
7173     OP* o;
7174     const bool once = block && block->op_flags & OPf_SPECIAL &&
7175                       block->op_type == OP_NULL;
7176
7177     PERL_UNUSED_ARG(debuggable);
7178
7179     if (expr) {
7180         if (once && (
7181               (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
7182            || (  expr->op_type == OP_NOT
7183               && cUNOPx(expr)->op_first->op_type == OP_CONST
7184               && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
7185               )
7186            ))
7187             /* Return the block now, so that S_new_logop does not try to
7188                fold it away. */
7189             return block;       /* do {} while 0 does once */
7190         if (expr->op_type == OP_READLINE
7191             || expr->op_type == OP_READDIR
7192             || expr->op_type == OP_GLOB
7193             || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
7194             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
7195             expr = newUNOP(OP_DEFINED, 0,
7196                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
7197         } else if (expr->op_flags & OPf_KIDS) {
7198             const OP * const k1 = ((UNOP*)expr)->op_first;
7199             const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
7200             switch (expr->op_type) {
7201               case OP_NULL:
7202                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
7203                       && (k2->op_flags & OPf_STACKED)
7204                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7205                     expr = newUNOP(OP_DEFINED, 0, expr);
7206                 break;
7207
7208               case OP_SASSIGN:
7209                 if (k1 && (k1->op_type == OP_READDIR
7210                       || k1->op_type == OP_GLOB
7211                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7212                      || k1->op_type == OP_EACH
7213                      || k1->op_type == OP_AEACH))
7214                     expr = newUNOP(OP_DEFINED, 0, expr);
7215                 break;
7216             }
7217         }
7218     }
7219
7220     /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
7221      * op, in listop. This is wrong. [perl #27024] */
7222     if (!block)
7223         block = newOP(OP_NULL, 0);
7224     listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
7225     o = new_logop(OP_AND, 0, &expr, &listop);
7226
7227     if (once) {
7228         ASSUME(listop);
7229     }
7230
7231     if (listop)
7232         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
7233
7234     if (once && o != listop)
7235     {
7236         assert(cUNOPo->op_first->op_type == OP_AND
7237             || cUNOPo->op_first->op_type == OP_OR);
7238         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
7239     }
7240
7241     if (o == listop)
7242         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
7243
7244     o->op_flags |= flags;
7245     o = op_scope(o);
7246     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
7247     return o;
7248 }
7249
7250 /*
7251 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
7252
7253 Constructs, checks, and returns an op tree expressing a C<while> loop.
7254 This is a heavyweight loop, with structure that allows exiting the loop
7255 by C<last> and suchlike.
7256
7257 C<loop> is an optional preconstructed C<enterloop> op to use in the
7258 loop; if it is null then a suitable op will be constructed automatically.
7259 C<expr> supplies the loop's controlling expression.  C<block> supplies the
7260 main body of the loop, and C<cont> optionally supplies a C<continue> block
7261 that operates as a second half of the body.  All of these optree inputs
7262 are consumed by this function and become part of the constructed op tree.
7263
7264 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7265 op and, shifted up eight bits, the eight bits of C<op_private> for
7266 the C<leaveloop> op, except that (in both cases) some bits will be set
7267 automatically.  C<debuggable> is currently unused and should always be 1.
7268 C<has_my> can be supplied as true to force the
7269 loop body to be enclosed in its own scope.
7270
7271 =cut
7272 */
7273
7274 OP *
7275 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
7276         OP *expr, OP *block, OP *cont, I32 has_my)
7277 {
7278     dVAR;
7279     OP *redo;
7280     OP *next = NULL;
7281     OP *listop;
7282     OP *o;
7283     U8 loopflags = 0;
7284
7285     PERL_UNUSED_ARG(debuggable);
7286
7287     if (expr) {
7288         if (expr->op_type == OP_READLINE
7289          || expr->op_type == OP_READDIR
7290          || expr->op_type == OP_GLOB
7291          || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
7292                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
7293             expr = newUNOP(OP_DEFINED, 0,
7294                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
7295         } else if (expr->op_flags & OPf_KIDS) {
7296             const OP * const k1 = ((UNOP*)expr)->op_first;
7297             const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
7298             switch (expr->op_type) {
7299               case OP_NULL:
7300                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
7301                       && (k2->op_flags & OPf_STACKED)
7302                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7303                     expr = newUNOP(OP_DEFINED, 0, expr);
7304                 break;
7305
7306               case OP_SASSIGN:
7307                 if (k1 && (k1->op_type == OP_READDIR
7308                       || k1->op_type == OP_GLOB
7309                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7310                      || k1->op_type == OP_EACH
7311                      || k1->op_type == OP_AEACH))
7312                     expr = newUNOP(OP_DEFINED, 0, expr);
7313                 break;
7314             }
7315         }
7316     }
7317
7318     if (!block)
7319         block = newOP(OP_NULL, 0);
7320     else if (cont || has_my) {
7321         block = op_scope(block);
7322     }
7323
7324     if (cont) {
7325         next = LINKLIST(cont);
7326     }
7327     if (expr) {
7328         OP * const unstack = newOP(OP_UNSTACK, 0);
7329         if (!next)
7330             next = unstack;
7331         cont = op_append_elem(OP_LINESEQ, cont, unstack);
7332     }
7333
7334     assert(block);
7335     listop = op_append_list(OP_LINESEQ, block, cont);
7336     assert(listop);
7337     redo = LINKLIST(listop);
7338
7339     if (expr) {
7340         scalar(listop);
7341         o = new_logop(OP_AND, 0, &expr, &listop);
7342         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
7343             op_free((OP*)loop);
7344             return expr;                /* listop already freed by new_logop */
7345         }
7346         if (listop)
7347             ((LISTOP*)listop)->op_last->op_next =
7348                 (o == listop ? redo : LINKLIST(o));
7349     }
7350     else
7351         o = listop;
7352
7353     if (!loop) {
7354         NewOp(1101,loop,1,LOOP);
7355         OpTYPE_set(loop, OP_ENTERLOOP);
7356         loop->op_private = 0;
7357         loop->op_next = (OP*)loop;
7358     }
7359
7360     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
7361
7362     loop->op_redoop = redo;
7363     loop->op_lastop = o;
7364     o->op_private |= loopflags;
7365
7366     if (next)
7367         loop->op_nextop = next;
7368     else
7369         loop->op_nextop = o;
7370
7371     o->op_flags |= flags;
7372     o->op_private |= (flags >> 8);
7373     return o;
7374 }
7375
7376 /*
7377 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
7378
7379 Constructs, checks, and returns an op tree expressing a C<foreach>
7380 loop (iteration through a list of values).  This is a heavyweight loop,
7381 with structure that allows exiting the loop by C<last> and suchlike.
7382
7383 C<sv> optionally supplies the variable that will be aliased to each
7384 item in turn; if null, it defaults to C<$_> (either lexical or global).
7385 C<expr> supplies the list of values to iterate over.  C<block> supplies
7386 the main body of the loop, and C<cont> optionally supplies a C<continue>
7387 block that operates as a second half of the body.  All of these optree
7388 inputs are consumed by this function and become part of the constructed
7389 op tree.
7390
7391 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7392 op and, shifted up eight bits, the eight bits of C<op_private> for
7393 the C<leaveloop> op, except that (in both cases) some bits will be set
7394 automatically.
7395
7396 =cut
7397 */
7398
7399 OP *
7400 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
7401 {
7402     dVAR;
7403     LOOP *loop;
7404     OP *wop;
7405     PADOFFSET padoff = 0;
7406     I32 iterflags = 0;
7407     I32 iterpflags = 0;
7408
7409     PERL_ARGS_ASSERT_NEWFOROP;
7410
7411     if (sv) {
7412         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
7413             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
7414             OpTYPE_set(sv, OP_RV2GV);
7415
7416             /* The op_type check is needed to prevent a possible segfault
7417              * if the loop variable is undeclared and 'strict vars' is in
7418              * effect. This is illegal but is nonetheless parsed, so we
7419              * may reach this point with an OP_CONST where we're expecting
7420              * an OP_GV.
7421              */
7422             if (cUNOPx(sv)->op_first->op_type == OP_GV
7423              && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
7424                 iterpflags |= OPpITER_DEF;
7425         }
7426         else if (sv->op_type == OP_PADSV) { /* private variable */
7427             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
7428             padoff = sv->op_targ;
7429             sv->op_targ = 0;
7430             op_free(sv);
7431             sv = NULL;
7432             PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
7433         }
7434         else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
7435             NOOP;
7436         else
7437             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
7438         if (padoff) {
7439             PADNAME * const pn = PAD_COMPNAME(padoff);
7440             const char * const name = PadnamePV(pn);
7441
7442             if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
7443                 iterpflags |= OPpITER_DEF;
7444         }
7445     }
7446     else {
7447         const PADOFFSET offset = pad_findmy_pvs("$_", 0);
7448         if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7449             sv = newGVOP(OP_GV, 0, PL_defgv);
7450         }
7451         else {
7452             padoff = offset;
7453         }
7454         iterpflags |= OPpITER_DEF;
7455     }
7456
7457     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
7458         expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
7459         iterflags |= OPf_STACKED;
7460     }
7461     else if (expr->op_type == OP_NULL &&
7462              (expr->op_flags & OPf_KIDS) &&
7463              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
7464     {
7465         /* Basically turn for($x..$y) into the same as for($x,$y), but we
7466          * set the STACKED flag to indicate that these values are to be
7467          * treated as min/max values by 'pp_enteriter'.
7468          */
7469         const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
7470         LOGOP* const range = (LOGOP*) flip->op_first;
7471         OP* const left  = range->op_first;
7472         OP* const right = OpSIBLING(left);
7473         LISTOP* listop;
7474
7475         range->op_flags &= ~OPf_KIDS;
7476         /* detach range's children */
7477         op_sibling_splice((OP*)range, NULL, -1, NULL);
7478
7479         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
7480         listop->op_first->op_next = range->op_next;
7481         left->op_next = range->op_other;
7482         right->op_next = (OP*)listop;
7483         listop->op_next = listop->op_first;
7484
7485         op_free(expr);
7486         expr = (OP*)(listop);
7487         op_null(expr);
7488         iterflags |= OPf_STACKED;
7489     }
7490     else {
7491         expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
7492     }
7493
7494     loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
7495                                   op_append_elem(OP_LIST, list(expr),
7496                                                  scalar(sv)));
7497     assert(!loop->op_next);
7498     /* for my  $x () sets OPpLVAL_INTRO;
7499      * for our $x () sets OPpOUR_INTRO */
7500     loop->op_private = (U8)iterpflags;
7501     if (loop->op_slabbed
7502      && DIFF(loop, OpSLOT(loop)->opslot_next)
7503          < SIZE_TO_PSIZE(sizeof(LOOP)))
7504     {
7505         LOOP *tmp;
7506         NewOp(1234,tmp,1,LOOP);
7507         Copy(loop,tmp,1,LISTOP);
7508 #ifdef PERL_OP_PARENT
7509         assert(loop->op_last->op_sibparent == (OP*)loop);
7510         OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
7511 #endif
7512         S_op_destroy(aTHX_ (OP*)loop);
7513         loop = tmp;
7514     }
7515     else if (!loop->op_slabbed)
7516     {
7517         loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
7518 #ifdef PERL_OP_PARENT
7519         OpLASTSIB_set(loop->op_last, (OP*)loop);
7520 #endif
7521     }
7522     loop->op_targ = padoff;
7523     wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
7524     return wop;
7525 }
7526
7527 /*
7528 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
7529
7530 Constructs, checks, and returns a loop-exiting op (such as C<goto>
7531 or C<last>).  C<type> is the opcode.  C<label> supplies the parameter
7532 determining the target of the op; it is consumed by this function and
7533 becomes part of the constructed op tree.
7534
7535 =cut
7536 */
7537
7538 OP*
7539 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
7540 {
7541     OP *o = NULL;
7542
7543     PERL_ARGS_ASSERT_NEWLOOPEX;
7544
7545     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
7546         || type == OP_CUSTOM);
7547
7548     if (type != OP_GOTO) {
7549         /* "last()" means "last" */
7550         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
7551             o = newOP(type, OPf_SPECIAL);
7552         }
7553     }
7554     else {
7555         /* Check whether it's going to be a goto &function */
7556         if (label->op_type == OP_ENTERSUB
7557                 && !(label->op_flags & OPf_STACKED))
7558             label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
7559     }
7560
7561     /* Check for a constant argument */
7562     if (label->op_type == OP_CONST) {
7563             SV * const sv = ((SVOP *)label)->op_sv;
7564             STRLEN l;
7565             const char *s = SvPV_const(sv,l);
7566             if (l == strlen(s)) {
7567                 o = newPVOP(type,
7568                             SvUTF8(((SVOP*)label)->op_sv),
7569                             savesharedpv(
7570                                 SvPV_nolen_const(((SVOP*)label)->op_sv)));
7571             }
7572     }
7573
7574     /* If we have already created an op, we do not need the label. */
7575     if (o)
7576                 op_free(label);
7577     else o = newUNOP(type, OPf_STACKED, label);
7578
7579     PL_hints |= HINT_BLOCK_SCOPE;
7580     return o;
7581 }
7582
7583 /* if the condition is a literal array or hash
7584    (or @{ ... } etc), make a reference to it.
7585  */
7586 STATIC OP *
7587 S_ref_array_or_hash(pTHX_ OP *cond)
7588 {
7589     if (cond
7590     && (cond->op_type == OP_RV2AV
7591     ||  cond->op_type == OP_PADAV
7592     ||  cond->op_type == OP_RV2HV
7593     ||  cond->op_type == OP_PADHV))
7594
7595         return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
7596
7597     else if(cond
7598     && (cond->op_type == OP_ASLICE
7599     ||  cond->op_type == OP_KVASLICE
7600     ||  cond->op_type == OP_HSLICE
7601     ||  cond->op_type == OP_KVHSLICE)) {
7602
7603         /* anonlist now needs a list from this op, was previously used in
7604          * scalar context */
7605         cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
7606         cond->op_flags |= OPf_WANT_LIST;
7607
7608         return newANONLIST(op_lvalue(cond, OP_ANONLIST));
7609     }
7610
7611     else
7612         return cond;
7613 }
7614
7615 /* These construct the optree fragments representing given()
7616    and when() blocks.
7617
7618    entergiven and enterwhen are LOGOPs; the op_other pointer
7619    points up to the associated leave op. We need this so we
7620    can put it in the context and make break/continue work.
7621    (Also, of course, pp_enterwhen will jump straight to
7622    op_other if the match fails.)
7623  */
7624
7625 STATIC OP *
7626 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
7627                    I32 enter_opcode, I32 leave_opcode,
7628                    PADOFFSET entertarg)
7629 {
7630     dVAR;
7631     LOGOP *enterop;
7632     OP *o;
7633
7634     PERL_ARGS_ASSERT_NEWGIVWHENOP;
7635
7636     enterop = S_alloc_LOGOP(aTHX_ enter_opcode, block, NULL);
7637     enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
7638     enterop->op_private = 0;
7639
7640     o = newUNOP(leave_opcode, 0, (OP *) enterop);
7641
7642     if (cond) {
7643         /* prepend cond if we have one */
7644         op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
7645
7646         o->op_next = LINKLIST(cond);
7647         cond->op_next = (OP *) enterop;
7648     }
7649     else {
7650         /* This is a default {} block */
7651         enterop->op_flags |= OPf_SPECIAL;
7652         o      ->op_flags |= OPf_SPECIAL;
7653
7654         o->op_next = (OP *) enterop;
7655     }
7656
7657     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
7658                                        entergiven and enterwhen both
7659                                        use ck_null() */
7660
7661     enterop->op_next = LINKLIST(block);
7662     block->op_next = enterop->op_other = o;
7663
7664     return o;
7665 }
7666
7667 /* Does this look like a boolean operation? For these purposes
7668    a boolean operation is:
7669      - a subroutine call [*]
7670      - a logical connective
7671      - a comparison operator
7672      - a filetest operator, with the exception of -s -M -A -C
7673      - defined(), exists() or eof()
7674      - /$re/ or $foo =~ /$re/
7675
7676    [*] possibly surprising
7677  */
7678 STATIC bool
7679 S_looks_like_bool(pTHX_ const OP *o)
7680 {
7681     PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
7682
7683     switch(o->op_type) {
7684         case OP_OR:
7685         case OP_DOR:
7686             return looks_like_bool(cLOGOPo->op_first);
7687
7688         case OP_AND:
7689         {
7690             OP* sibl = OpSIBLING(cLOGOPo->op_first);
7691             ASSUME(sibl);
7692             return (
7693                 looks_like_bool(cLOGOPo->op_first)
7694              && looks_like_bool(sibl));
7695         }
7696
7697         case OP_NULL:
7698         case OP_SCALAR:
7699             return (
7700                 o->op_flags & OPf_KIDS
7701             && looks_like_bool(cUNOPo->op_first));
7702
7703         case OP_ENTERSUB:
7704
7705         case OP_NOT:    case OP_XOR:
7706
7707         case OP_EQ:     case OP_NE:     case OP_LT:
7708         case OP_GT:     case OP_LE:     case OP_GE:
7709
7710         case OP_I_EQ:   case OP_I_NE:   case OP_I_LT:
7711         case OP_I_GT:   case OP_I_LE:   case OP_I_GE:
7712
7713         case OP_SEQ:    case OP_SNE:    case OP_SLT:
7714         case OP_SGT:    case OP_SLE:    case OP_SGE:
7715
7716         case OP_SMARTMATCH:
7717
7718         case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
7719         case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
7720         case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
7721         case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
7722         case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
7723         case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
7724         case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
7725         case OP_FTTEXT:   case OP_FTBINARY:
7726
7727         case OP_DEFINED: case OP_EXISTS:
7728         case OP_MATCH:   case OP_EOF:
7729
7730         case OP_FLOP:
7731
7732             return TRUE;
7733
7734         case OP_CONST:
7735             /* Detect comparisons that have been optimized away */
7736             if (cSVOPo->op_sv == &PL_sv_yes
7737             ||  cSVOPo->op_sv == &PL_sv_no)
7738
7739                 return TRUE;
7740             else
7741                 return FALSE;
7742
7743         /* FALLTHROUGH */
7744         default:
7745             return FALSE;
7746     }
7747 }
7748
7749 /*
7750 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
7751
7752 Constructs, checks, and returns an op tree expressing a C<given> block.
7753 C<cond> supplies the expression that will be locally assigned to a lexical
7754 variable, and C<block> supplies the body of the C<given> construct; they
7755 are consumed by this function and become part of the constructed op tree.
7756 C<defsv_off> is the pad offset of the scalar lexical variable that will
7757 be affected.  If it is 0, the global $_ will be used.
7758
7759 =cut
7760 */
7761
7762 OP *
7763 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
7764 {
7765     PERL_ARGS_ASSERT_NEWGIVENOP;
7766     return newGIVWHENOP(
7767         ref_array_or_hash(cond),
7768         block,
7769         OP_ENTERGIVEN, OP_LEAVEGIVEN,
7770         defsv_off);
7771 }
7772
7773 /*
7774 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
7775
7776 Constructs, checks, and returns an op tree expressing a C<when> block.
7777 C<cond> supplies the test expression, and C<block> supplies the block
7778 that will be executed if the test evaluates to true; they are consumed
7779 by this function and become part of the constructed op tree.  C<cond>
7780 will be interpreted DWIMically, often as a comparison against C<$_>,
7781 and may be null to generate a C<default> block.
7782
7783 =cut
7784 */
7785
7786 OP *
7787 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
7788 {
7789     const bool cond_llb = (!cond || looks_like_bool(cond));
7790     OP *cond_op;
7791
7792     PERL_ARGS_ASSERT_NEWWHENOP;
7793
7794     if (cond_llb)
7795         cond_op = cond;
7796     else {
7797         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
7798                 newDEFSVOP(),
7799                 scalar(ref_array_or_hash(cond)));
7800     }
7801
7802     return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
7803 }
7804
7805 /* must not conflict with SVf_UTF8 */
7806 #define CV_CKPROTO_CURSTASH     0x1
7807
7808 void
7809 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
7810                     const STRLEN len, const U32 flags)
7811 {
7812     SV *name = NULL, *msg;
7813     const char * cvp = SvROK(cv)
7814                         ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
7815                            ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
7816                            : ""
7817                         : CvPROTO(cv);
7818     STRLEN clen = CvPROTOLEN(cv), plen = len;
7819
7820     PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
7821
7822     if (p == NULL && cvp == NULL)
7823         return;
7824
7825     if (!ckWARN_d(WARN_PROTOTYPE))
7826         return;
7827
7828     if (p && cvp) {
7829         p = S_strip_spaces(aTHX_ p, &plen);
7830         cvp = S_strip_spaces(aTHX_ cvp, &clen);
7831         if ((flags & SVf_UTF8) == SvUTF8(cv)) {
7832             if (plen == clen && memEQ(cvp, p, plen))
7833                 return;
7834         } else {
7835             if (flags & SVf_UTF8) {
7836                 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
7837                     return;
7838             }
7839             else {
7840                 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
7841                     return;
7842             }
7843         }
7844     }
7845
7846     msg = sv_newmortal();
7847
7848     if (gv)
7849     {
7850         if (isGV(gv))
7851             gv_efullname3(name = sv_newmortal(), gv, NULL);
7852         else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
7853             name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
7854         else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
7855             name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
7856             sv_catpvs(name, "::");
7857             if (SvROK(gv)) {
7858                 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
7859                 assert (CvNAMED(SvRV_const(gv)));
7860                 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
7861             }
7862             else sv_catsv(name, (SV *)gv);
7863         }
7864         else name = (SV *)gv;
7865     }
7866     sv_setpvs(msg, "Prototype mismatch:");
7867     if (name)
7868         Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
7869     if (cvp)
7870         Perl_sv_catpvf(aTHX_ msg, " (%"UTF8f")",
7871             UTF8fARG(SvUTF8(cv),clen,cvp)
7872         );
7873     else
7874         sv_catpvs(msg, ": none");
7875     sv_catpvs(msg, " vs ");
7876     if (p)
7877         Perl_sv_catpvf(aTHX_ msg, "(%"UTF8f")", UTF8fARG(flags & SVf_UTF8,len,p));
7878     else
7879         sv_catpvs(msg, "none");
7880     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
7881 }
7882
7883 static void const_sv_xsub(pTHX_ CV* cv);
7884 static void const_av_xsub(pTHX_ CV* cv);
7885
7886 /*
7887
7888 =head1 Optree Manipulation Functions
7889
7890 =for apidoc cv_const_sv
7891
7892 If C<cv> is a constant sub eligible for inlining, returns the constant
7893 value returned by the sub.  Otherwise, returns NULL.
7894
7895 Constant subs can be created with C<newCONSTSUB> or as described in
7896 L<perlsub/"Constant Functions">.
7897
7898 =cut
7899 */
7900 SV *
7901 Perl_cv_const_sv(const CV *const cv)
7902 {
7903     SV *sv;
7904     if (!cv)
7905         return NULL;
7906     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
7907         return NULL;
7908     sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7909     if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
7910     return sv;
7911 }
7912
7913 SV *
7914 Perl_cv_const_sv_or_av(const CV * const cv)
7915 {
7916     if (!cv)
7917         return NULL;
7918     if (SvROK(cv)) return SvRV((SV *)cv);
7919     assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
7920     return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7921 }
7922
7923 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
7924  * Can be called in 2 ways:
7925  *
7926  * !allow_lex
7927  *      look for a single OP_CONST with attached value: return the value
7928  *
7929  * allow_lex && !CvCONST(cv);
7930  *
7931  *      examine the clone prototype, and if contains only a single
7932  *      OP_CONST, return the value; or if it contains a single PADSV ref-
7933  *      erencing an outer lexical, turn on CvCONST to indicate the CV is
7934  *      a candidate for "constizing" at clone time, and return NULL.
7935  */
7936
7937 static SV *
7938 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
7939 {
7940     SV *sv = NULL;
7941     bool padsv = FALSE;
7942
7943     assert(o);
7944     assert(cv);
7945
7946     for (; o; o = o->op_next) {
7947         const OPCODE type = o->op_type;
7948
7949         if (type == OP_NEXTSTATE || type == OP_LINESEQ
7950              || type == OP_NULL
7951              || type == OP_PUSHMARK)
7952                 continue;
7953         if (type == OP_DBSTATE)
7954                 continue;
7955         if (type == OP_LEAVESUB)
7956             break;
7957         if (sv)
7958             return NULL;
7959         if (type == OP_CONST && cSVOPo->op_sv)
7960             sv = cSVOPo->op_sv;
7961         else if (type == OP_UNDEF && !o->op_private) {
7962             sv = newSV(0);
7963             SAVEFREESV(sv);
7964         }
7965         else if (allow_lex && type == OP_PADSV) {
7966                 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
7967                 {
7968                     sv = &PL_sv_undef; /* an arbitrary non-null value */
7969                     padsv = TRUE;
7970                 }
7971                 else
7972                     return NULL;
7973         }
7974         else {
7975             return NULL;
7976         }
7977     }
7978     if (padsv) {
7979         CvCONST_on(cv);
7980         return NULL;
7981     }
7982     return sv;
7983 }
7984
7985 static bool
7986 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
7987                         PADNAME * const name, SV ** const const_svp)
7988 {
7989     assert (cv);
7990     assert (o || name);
7991     assert (const_svp);
7992     if ((!block
7993          )) {
7994         if (CvFLAGS(PL_compcv)) {
7995             /* might have had built-in attrs applied */
7996             const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
7997             if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
7998              && ckWARN(WARN_MISC))
7999             {
8000                 /* protect against fatal warnings leaking compcv */
8001                 SAVEFREESV(PL_compcv);
8002                 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
8003                 SvREFCNT_inc_simple_void_NN(PL_compcv);
8004             }
8005             CvFLAGS(cv) |=
8006                 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
8007                   & ~(CVf_LVALUE * pureperl));
8008         }
8009         return FALSE;
8010     }
8011
8012     /* redundant check for speed: */
8013     if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
8014         const line_t oldline = CopLINE(PL_curcop);
8015         SV *namesv = o
8016             ? cSVOPo->op_sv
8017             : sv_2mortal(newSVpvn_utf8(
8018                 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
8019               ));
8020         if (PL_parser && PL_parser->copline != NOLINE)
8021             /* This ensures that warnings are reported at the first
8022                line of a redefinition, not the last.  */
8023             CopLINE_set(PL_curcop, PL_parser->copline);
8024         /* protect against fatal warnings leaking compcv */
8025         SAVEFREESV(PL_compcv);
8026         report_redefined_cv(namesv, cv, const_svp);
8027         SvREFCNT_inc_simple_void_NN(PL_compcv);
8028         CopLINE_set(PL_curcop, oldline);
8029     }
8030     SAVEFREESV(cv);
8031     return TRUE;
8032 }
8033
8034 CV *
8035 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
8036 {
8037     CV **spot;
8038     SV **svspot;
8039     const char *ps;
8040     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
8041     U32 ps_utf8 = 0;
8042     CV *cv = NULL;
8043     CV *compcv = PL_compcv;
8044     SV *const_sv;
8045     PADNAME *name;
8046     PADOFFSET pax = o->op_targ;
8047     CV *outcv = CvOUTSIDE(PL_compcv);
8048     CV *clonee = NULL;
8049     HEK *hek = NULL;
8050     bool reusable = FALSE;
8051     OP *start = NULL;
8052 #ifdef PERL_DEBUG_READONLY_OPS
8053     OPSLAB *slab = NULL;
8054 #endif
8055
8056     PERL_ARGS_ASSERT_NEWMYSUB;
8057
8058     /* Find the pad slot for storing the new sub.
8059        We cannot use PL_comppad, as it is the pad owned by the new sub.  We
8060        need to look in CvOUTSIDE and find the pad belonging to the enclos-
8061        ing sub.  And then we need to dig deeper if this is a lexical from
8062        outside, as in:
8063            my sub foo; sub { sub foo { } }
8064      */
8065    redo:
8066     name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
8067     if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
8068         pax = PARENT_PAD_INDEX(name);
8069         outcv = CvOUTSIDE(outcv);
8070         assert(outcv);
8071         goto redo;
8072     }
8073     svspot =
8074         &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
8075                         [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
8076     spot = (CV **)svspot;
8077
8078     if (!(PL_parser && PL_parser->error_count))
8079         move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name));
8080
8081     if (proto) {
8082         assert(proto->op_type == OP_CONST);
8083         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
8084         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
8085     }
8086     else
8087         ps = NULL;
8088
8089     if (proto)
8090         SAVEFREEOP(proto);
8091     if (attrs)
8092         SAVEFREEOP(attrs);
8093
8094     if (PL_parser && PL_parser->error_count) {
8095         op_free(block);
8096         SvREFCNT_dec(PL_compcv);
8097         PL_compcv = 0;
8098         goto done;
8099     }
8100
8101     if (CvDEPTH(outcv) && CvCLONE(compcv)) {
8102         cv = *spot;
8103         svspot = (SV **)(spot = &clonee);
8104     }
8105     else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
8106         cv = *spot;
8107     else {
8108         assert (SvTYPE(*spot) == SVt_PVCV);
8109         if (CvNAMED(*spot))
8110             hek = CvNAME_HEK(*spot);
8111         else {
8112             dVAR;
8113             U32 hash;
8114             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
8115             CvNAME_HEK_set(*spot, hek =
8116                 share_hek(
8117                     PadnamePV(name)+1,
8118                     (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
8119                     hash
8120                 )
8121             );
8122             CvLEXICAL_on(*spot);
8123         }
8124         cv = PadnamePROTOCV(name);
8125         svspot = (SV **)(spot = &PadnamePROTOCV(name));
8126     }
8127
8128     if (block) {
8129         /* This makes sub {}; work as expected.  */
8130         if (block->op_type == OP_STUB) {
8131             const line_t l = PL_parser->copline;
8132             op_free(block);
8133             block = newSTATEOP(0, NULL, 0);
8134             PL_parser->copline = l;
8135         }
8136         block = CvLVALUE(compcv)
8137              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
8138                    ? newUNOP(OP_LEAVESUBLV, 0,
8139                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
8140                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
8141         start = LINKLIST(block);
8142         block->op_next = 0;
8143         if (ps && !*ps && !attrs && !CvLVALUE(compcv))
8144             const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
8145         else
8146             const_sv = NULL;
8147     }
8148     else
8149         const_sv = NULL;
8150
8151     if (cv) {
8152         const bool exists = CvROOT(cv) || CvXSUB(cv);
8153
8154         /* if the subroutine doesn't exist and wasn't pre-declared
8155          * with a prototype, assume it will be AUTOLOADed,
8156          * skipping the prototype check
8157          */
8158         if (exists || SvPOK(cv))
8159             cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
8160                                  ps_utf8);
8161         /* already defined? */
8162         if (exists) {
8163             if (S_already_defined(aTHX_ cv,block,NULL,name,&const_sv))
8164                 cv = NULL;
8165             else {
8166                 if (attrs) goto attrs;
8167                 /* just a "sub foo;" when &foo is already defined */
8168                 SAVEFREESV(compcv);
8169                 goto done;
8170             }
8171         }
8172         else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
8173             cv = NULL;
8174             reusable = TRUE;
8175         }
8176     }
8177     if (const_sv) {
8178         SvREFCNT_inc_simple_void_NN(const_sv);
8179         SvFLAGS(const_sv) |= SVs_PADTMP;
8180         if (cv) {
8181             assert(!CvROOT(cv) && !CvCONST(cv));
8182             cv_forget_slab(cv);
8183         }
8184         else {
8185             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8186             CvFILE_set_from_cop(cv, PL_curcop);
8187             CvSTASH_set(cv, PL_curstash);
8188             *spot = cv;
8189         }
8190         sv_setpvs(MUTABLE_SV(cv), "");  /* prototype is "" */
8191         CvXSUBANY(cv).any_ptr = const_sv;
8192         CvXSUB(cv) = const_sv_xsub;
8193         CvCONST_on(cv);
8194         CvISXSUB_on(cv);
8195         PoisonPADLIST(cv);
8196         CvFLAGS(cv) |= CvMETHOD(compcv);
8197         op_free(block);
8198         SvREFCNT_dec(compcv);
8199         PL_compcv = NULL;
8200         goto setname;
8201     }
8202     /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
8203        determine whether this sub definition is in the same scope as its
8204        declaration.  If this sub definition is inside an inner named pack-
8205        age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
8206        the package sub.  So check PadnameOUTER(name) too.
8207      */
8208     if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
8209         assert(!CvWEAKOUTSIDE(compcv));
8210         SvREFCNT_dec(CvOUTSIDE(compcv));
8211         CvWEAKOUTSIDE_on(compcv);
8212     }
8213     /* XXX else do we have a circular reference? */
8214     if (cv) {   /* must reuse cv in case stub is referenced elsewhere */
8215         /* transfer PL_compcv to cv */
8216         if (block
8217         ) {
8218             cv_flags_t preserved_flags =
8219                 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
8220             PADLIST *const temp_padl = CvPADLIST(cv);
8221             CV *const temp_cv = CvOUTSIDE(cv);
8222             const cv_flags_t other_flags =
8223                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8224             OP * const cvstart = CvSTART(cv);
8225
8226             SvPOK_off(cv);
8227             CvFLAGS(cv) =
8228                 CvFLAGS(compcv) | preserved_flags;
8229             CvOUTSIDE(cv) = CvOUTSIDE(compcv);
8230             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
8231             CvPADLIST_set(cv, CvPADLIST(compcv));
8232             CvOUTSIDE(compcv) = temp_cv;
8233             CvPADLIST_set(compcv, temp_padl);
8234             CvSTART(cv) = CvSTART(compcv);
8235             CvSTART(compcv) = cvstart;
8236             CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8237             CvFLAGS(compcv) |= other_flags;
8238
8239             if (CvFILE(cv) && CvDYNFILE(cv)) {
8240                 Safefree(CvFILE(cv));
8241             }
8242
8243             /* inner references to compcv must be fixed up ... */
8244             pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
8245             if (PERLDB_INTER)/* Advice debugger on the new sub. */
8246               ++PL_sub_generation;
8247         }
8248         else {
8249             /* Might have had built-in attributes applied -- propagate them. */
8250             CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
8251         }
8252         /* ... before we throw it away */
8253         SvREFCNT_dec(compcv);
8254         PL_compcv = compcv = cv;
8255     }
8256     else {
8257         cv = compcv;
8258         *spot = cv;
8259     }
8260    setname:
8261     CvLEXICAL_on(cv);
8262     if (!CvNAME_HEK(cv)) {
8263         if (hek) (void)share_hek_hek(hek);
8264         else {
8265             dVAR;
8266             U32 hash;
8267             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
8268             hek = share_hek(PadnamePV(name)+1,
8269                       (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
8270                       hash);
8271         }
8272         CvNAME_HEK_set(cv, hek);
8273     }
8274     if (const_sv) goto clone;
8275
8276     CvFILE_set_from_cop(cv, PL_curcop);
8277     CvSTASH_set(cv, PL_curstash);
8278
8279     if (ps) {
8280         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8281         if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
8282     }
8283
8284     if (!block)
8285         goto attrs;
8286
8287     /* If we assign an optree to a PVCV, then we've defined a subroutine that
8288        the debugger could be able to set a breakpoint in, so signal to
8289        pp_entereval that it should not throw away any saved lines at scope
8290        exit.  */
8291
8292     PL_breakable_sub_gen++;
8293     CvROOT(cv) = block;
8294     CvROOT(cv)->op_private |= OPpREFCOUNTED;
8295     OpREFCNT_set(CvROOT(cv), 1);
8296     /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8297        itself has a refcount. */
8298     CvSLABBED_off(cv);
8299     OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8300 #ifdef PERL_DEBUG_READONLY_OPS
8301     slab = (OPSLAB *)CvSTART(cv);
8302 #endif
8303     CvSTART(cv) = start;
8304     CALL_PEEP(start);
8305     finalize_optree(CvROOT(cv));
8306     S_prune_chain_head(&CvSTART(cv));
8307
8308     /* now that optimizer has done its work, adjust pad values */
8309
8310     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8311
8312   attrs:
8313     if (attrs) {
8314         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8315         apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
8316     }
8317
8318     if (block) {
8319         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8320             SV * const tmpstr = sv_newmortal();
8321             GV * const db_postponed = gv_fetchpvs("DB::postponed",
8322                                                   GV_ADDMULTI, SVt_PVHV);
8323             HV *hv;
8324             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8325                                           CopFILE(PL_curcop),
8326                                           (long)PL_subline,
8327                                           (long)CopLINE(PL_curcop));
8328             if (HvNAME_HEK(PL_curstash)) {
8329                 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
8330                 sv_catpvs(tmpstr, "::");
8331             }
8332             else sv_setpvs(tmpstr, "__ANON__::");
8333             sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
8334                             PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
8335             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8336                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8337             hv = GvHVn(db_postponed);
8338             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8339                 CV * const pcv = GvCV(db_postponed);
8340                 if (pcv) {
8341                     dSP;
8342                     PUSHMARK(SP);
8343                     XPUSHs(tmpstr);
8344                     PUTBACK;
8345                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
8346                 }
8347             }
8348         }
8349     }
8350
8351   clone:
8352     if (clonee) {
8353         assert(CvDEPTH(outcv));
8354         spot = (CV **)
8355             &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
8356         if (reusable) cv_clone_into(clonee, *spot);
8357         else *spot = cv_clone(clonee);
8358         SvREFCNT_dec_NN(clonee);
8359         cv = *spot;
8360     }
8361     if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
8362         PADOFFSET depth = CvDEPTH(outcv);
8363         while (--depth) {
8364             SV *oldcv;
8365             svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
8366             oldcv = *svspot;
8367             *svspot = SvREFCNT_inc_simple_NN(cv);
8368             SvREFCNT_dec(oldcv);
8369         }
8370     }
8371
8372   done:
8373     if (PL_parser)
8374         PL_parser->copline = NOLINE;
8375     LEAVE_SCOPE(floor);
8376 #ifdef PERL_DEBUG_READONLY_OPS
8377     if (slab)
8378         Slab_to_ro(slab);
8379 #endif
8380     op_free(o);
8381     return cv;
8382 }
8383
8384 /* _x = extended */
8385 CV *
8386 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
8387                             OP *block, bool o_is_gv)
8388 {
8389     GV *gv;
8390     const char *ps;
8391     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
8392     U32 ps_utf8 = 0;
8393     CV *cv = NULL;
8394     SV *const_sv;
8395     const bool ec = PL_parser && PL_parser->error_count;
8396     /* If the subroutine has no body, no attributes, and no builtin attributes
8397        then it's just a sub declaration, and we may be able to get away with
8398        storing with a placeholder scalar in the symbol table, rather than a
8399        full CV.  If anything is present then it will take a full CV to
8400        store it.  */
8401     const I32 gv_fetch_flags
8402         = ec ? GV_NOADD_NOINIT :
8403         (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
8404         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
8405     STRLEN namlen = 0;
8406     const char * const name =
8407          o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
8408     bool has_name;
8409     bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
8410     bool evanescent = FALSE;
8411     OP *start = NULL;
8412 #ifdef PERL_DEBUG_READONLY_OPS
8413     OPSLAB *slab = NULL;
8414 #endif
8415
8416     if (o_is_gv) {
8417         gv = (GV*)o;
8418         o = NULL;
8419         has_name = TRUE;
8420     } else if (name) {
8421         /* Try to optimise and avoid creating a GV.  Instead, the CV’s name
8422            hek and CvSTASH pointer together can imply the GV.  If the name
8423            contains a package name, then GvSTASH(CvGV(cv)) may differ from
8424            CvSTASH, so forego the optimisation if we find any.
8425            Also, we may be called from load_module at run time, so
8426            PL_curstash (which sets CvSTASH) may not point to the stash the
8427            sub is stored in.  */
8428         const I32 flags =
8429            ec ? GV_NOADD_NOINIT
8430               :   PL_curstash != CopSTASH(PL_curcop)
8431                || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
8432                     ? gv_fetch_flags
8433                     : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
8434         gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
8435         has_name = TRUE;
8436     } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
8437         SV * const sv = sv_newmortal();
8438         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
8439                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
8440                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
8441         gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
8442         has_name = TRUE;
8443     } else if (PL_curstash) {
8444         gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
8445         has_name = FALSE;
8446     } else {
8447         gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
8448         has_name = FALSE;
8449     }
8450     if (!ec) {
8451         if (isGV(gv)) {
8452             move_proto_attr(&proto, &attrs, gv);
8453         } else {
8454             assert(cSVOPo);
8455             move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv);
8456         }
8457     }
8458
8459     if (proto) {
8460         assert(proto->op_type == OP_CONST);
8461         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
8462         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
8463     }
8464     else
8465         ps = NULL;
8466
8467     if (o)
8468         SAVEFREEOP(o);
8469     if (proto)
8470         SAVEFREEOP(proto);
8471     if (attrs)
8472         SAVEFREEOP(attrs);
8473
8474     if (ec) {
8475         op_free(block);
8476         if (name) SvREFCNT_dec(PL_compcv);
8477         else cv = PL_compcv;
8478         PL_compcv = 0;
8479         if (name && block) {
8480             const char *s = strrchr(name, ':');
8481             s = s ? s+1 : name;
8482             if (strEQ(s, "BEGIN")) {
8483                 if (PL_in_eval & EVAL_KEEPERR)
8484                     Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
8485                 else {
8486                     SV * const errsv = ERRSV;
8487                     /* force display of errors found but not reported */
8488                     sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
8489                     Perl_croak_nocontext("%"SVf, SVfARG(errsv));
8490                 }
8491             }
8492         }
8493         goto done;
8494     }
8495
8496     if (!block && SvTYPE(gv) != SVt_PVGV) {
8497       /* If we are not defining a new sub and the existing one is not a
8498          full GV + CV... */
8499       if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
8500         /* We are applying attributes to an existing sub, so we need it
8501            upgraded if it is a constant.  */
8502         if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
8503             gv_init_pvn(gv, PL_curstash, name, namlen,
8504                         SVf_UTF8 * name_is_utf8);
8505       }
8506       else {                    /* Maybe prototype now, and had at maximum
8507                                    a prototype or const/sub ref before.  */
8508         if (SvTYPE(gv) > SVt_NULL) {
8509             cv_ckproto_len_flags((const CV *)gv,
8510                                  o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8511                                  ps_len, ps_utf8);
8512         }
8513         if (!SvROK(gv)) {
8514           if (ps) {
8515             sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
8516             if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
8517           }
8518           else
8519             sv_setiv(MUTABLE_SV(gv), -1);
8520         }
8521
8522         SvREFCNT_dec(PL_compcv);
8523         cv = PL_compcv = NULL;
8524         goto done;
8525       }
8526     }
8527
8528     cv = (!name || (isGV(gv) && GvCVGEN(gv)))
8529         ? NULL
8530         : isGV(gv)
8531             ? GvCV(gv)
8532             : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
8533                 ? (CV *)SvRV(gv)
8534                 : NULL;
8535
8536     if (block) {
8537         /* This makes sub {}; work as expected.  */
8538         if (block->op_type == OP_STUB) {
8539             const line_t l = PL_parser->copline;
8540             op_free(block);
8541             block = newSTATEOP(0, NULL, 0);
8542             PL_parser->copline = l;
8543         }
8544         block = CvLVALUE(PL_compcv)
8545              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
8546                     && (!isGV(gv) || !GvASSUMECV(gv)))
8547                    ? newUNOP(OP_LEAVESUBLV, 0,
8548                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
8549                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
8550         start = LINKLIST(block);
8551         block->op_next = 0;
8552         if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
8553             const_sv =
8554                 S_op_const_sv(aTHX_ start, PL_compcv, CvCLONE(PL_compcv));
8555         else
8556             const_sv = NULL;
8557     }
8558     else
8559         const_sv = NULL;
8560
8561     if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
8562         assert (block);
8563         cv_ckproto_len_flags((const CV *)gv,
8564                              o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8565                              ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
8566         if (SvROK(gv)) {
8567             /* All the other code for sub redefinition warnings expects the
8568                clobbered sub to be a CV.  Instead of making all those code
8569                paths more complex, just inline the RV version here.  */
8570             const line_t oldline = CopLINE(PL_curcop);
8571             assert(IN_PERL_COMPILETIME);
8572             if (PL_parser && PL_parser->copline != NOLINE)
8573                 /* This ensures that warnings are reported at the first
8574                    line of a redefinition, not the last.  */
8575                 CopLINE_set(PL_curcop, PL_parser->copline);
8576             /* protect against fatal warnings leaking compcv */
8577             SAVEFREESV(PL_compcv);
8578
8579             if (ckWARN(WARN_REDEFINE)
8580              || (  ckWARN_d(WARN_REDEFINE)
8581                 && (  !const_sv || SvRV(gv) == const_sv
8582                    || sv_cmp(SvRV(gv), const_sv)  )))
8583                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8584                           "Constant subroutine %"SVf" redefined",
8585                           SVfARG(cSVOPo->op_sv));
8586
8587             SvREFCNT_inc_simple_void_NN(PL_compcv);
8588             CopLINE_set(PL_curcop, oldline);
8589             SvREFCNT_dec(SvRV(gv));
8590         }
8591     }
8592
8593     if (cv) {
8594         const bool exists = CvROOT(cv) || CvXSUB(cv);
8595
8596         /* if the subroutine doesn't exist and wasn't pre-declared
8597          * with a prototype, assume it will be AUTOLOADed,
8598          * skipping the prototype check
8599          */
8600         if (exists || SvPOK(cv))
8601             cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
8602         /* already defined (or promised)? */
8603         if (exists || (isGV(gv) && GvASSUMECV(gv))) {
8604             if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv))
8605                 cv = NULL;
8606             else {
8607                 if (attrs) goto attrs;
8608                 /* just a "sub foo;" when &foo is already defined */
8609                 SAVEFREESV(PL_compcv);
8610                 goto done;
8611             }
8612         }
8613     }
8614     if (const_sv) {
8615         SvREFCNT_inc_simple_void_NN(const_sv);
8616         SvFLAGS(const_sv) |= SVs_PADTMP;
8617         if (cv) {
8618             assert(!CvROOT(cv) && !CvCONST(cv));
8619             cv_forget_slab(cv);
8620             sv_setpvs(MUTABLE_SV(cv), "");  /* prototype is "" */
8621             CvXSUBANY(cv).any_ptr = const_sv;
8622             CvXSUB(cv) = const_sv_xsub;
8623             CvCONST_on(cv);
8624             CvISXSUB_on(cv);
8625             PoisonPADLIST(cv);
8626             CvFLAGS(cv) |= CvMETHOD(PL_compcv);
8627         }
8628         else {
8629             if (isGV(gv) || CvMETHOD(PL_compcv)) {
8630                 if (name && isGV(gv))
8631                     GvCV_set(gv, NULL);
8632                 cv = newCONSTSUB_flags(
8633                     NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
8634                     const_sv
8635                 );
8636                 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
8637             }
8638             else {
8639                 if (!SvROK(gv)) {
8640                     SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8641                     prepare_SV_for_RV((SV *)gv);
8642                     SvOK_off((SV *)gv);
8643                     SvROK_on(gv);
8644                 }
8645                 SvRV_set(gv, const_sv);
8646             }
8647         }
8648         op_free(block);
8649         SvREFCNT_dec(PL_compcv);
8650         PL_compcv = NULL;
8651         goto done;
8652     }
8653     if (cv) {                           /* must reuse cv if autoloaded */
8654         /* transfer PL_compcv to cv */
8655         if (block
8656         ) {
8657             cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
8658             PADLIST *const temp_av = CvPADLIST(cv);
8659             CV *const temp_cv = CvOUTSIDE(cv);
8660             const cv_flags_t other_flags =
8661                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8662             OP * const cvstart = CvSTART(cv);
8663
8664             if (isGV(gv)) {
8665                 CvGV_set(cv,gv);
8666                 assert(!CvCVGV_RC(cv));
8667                 assert(CvGV(cv) == gv);
8668             }
8669             else {
8670                 dVAR;
8671                 U32 hash;
8672                 PERL_HASH(hash, name, namlen);
8673                 CvNAME_HEK_set(cv,
8674                                share_hek(name,
8675                                          name_is_utf8
8676                                             ? -(SSize_t)namlen
8677                                             :  (SSize_t)namlen,
8678                                          hash));
8679             }
8680
8681             SvPOK_off(cv);
8682             CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
8683                                              | CvNAMED(cv);
8684             CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
8685             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
8686             CvPADLIST_set(cv,CvPADLIST(PL_compcv));
8687             CvOUTSIDE(PL_compcv) = temp_cv;
8688             CvPADLIST_set(PL_compcv, temp_av);
8689             CvSTART(cv) = CvSTART(PL_compcv);
8690             CvSTART(PL_compcv) = cvstart;
8691             CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8692             CvFLAGS(PL_compcv) |= other_flags;
8693
8694             if (CvFILE(cv) && CvDYNFILE(cv)) {
8695                 Safefree(CvFILE(cv));
8696     }
8697             CvFILE_set_from_cop(cv, PL_curcop);
8698             CvSTASH_set(cv, PL_curstash);
8699
8700             /* inner references to PL_compcv must be fixed up ... */
8701             pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
8702             if (PERLDB_INTER)/* Advice debugger on the new sub. */
8703               ++PL_sub_generation;
8704         }
8705         else {
8706             /* Might have had built-in attributes applied -- propagate them. */
8707             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
8708         }
8709         /* ... before we throw it away */
8710         SvREFCNT_dec(PL_compcv);
8711         PL_compcv = cv;
8712     }
8713     else {
8714         cv = PL_compcv;
8715         if (name && isGV(gv)) {
8716             GvCV_set(gv, cv);
8717             GvCVGEN(gv) = 0;
8718             if (HvENAME_HEK(GvSTASH(gv)))
8719                 /* sub Foo::bar { (shift)+1 } */
8720                 gv_method_changed(gv);
8721         }
8722         else if (name) {
8723             if (!SvROK(gv)) {
8724                 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8725                 prepare_SV_for_RV((SV *)gv);
8726                 SvOK_off((SV *)gv);
8727                 SvROK_on(gv);
8728             }
8729             SvRV_set(gv, (SV *)cv);
8730         }
8731     }
8732     if (!CvHASGV(cv)) {
8733         if (isGV(gv)) CvGV_set(cv, gv);
8734         else {
8735             dVAR;
8736             U32 hash;
8737             PERL_HASH(hash, name, namlen);
8738             CvNAME_HEK_set(cv, share_hek(name,
8739                                          name_is_utf8
8740                                             ? -(SSize_t)namlen
8741                                             :  (SSize_t)namlen,
8742                                          hash));
8743         }
8744         CvFILE_set_from_cop(cv, PL_curcop);
8745         CvSTASH_set(cv, PL_curstash);
8746     }
8747
8748     if (ps) {
8749         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8750         if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
8751     }
8752
8753     if (!block)
8754         goto attrs;
8755
8756     /* If we assign an optree to a PVCV, then we've defined a subroutine that
8757        the debugger could be able to set a breakpoint in, so signal to
8758        pp_entereval that it should not throw away any saved lines at scope
8759        exit.  */
8760
8761     PL_breakable_sub_gen++;
8762     CvROOT(cv) = block;
8763     CvROOT(cv)->op_private |= OPpREFCOUNTED;
8764     OpREFCNT_set(CvROOT(cv), 1);
8765     /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8766        itself has a refcount. */
8767     CvSLABBED_off(cv);
8768     OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8769 #ifdef PERL_DEBUG_READONLY_OPS
8770     slab = (OPSLAB *)CvSTART(cv);
8771 #endif
8772     CvSTART(cv) = start;
8773     CALL_PEEP(start);
8774     finalize_optree(CvROOT(cv));
8775     S_prune_chain_head(&CvSTART(cv));
8776
8777     /* now that optimizer has done its work, adjust pad values */
8778
8779     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8780
8781   attrs:
8782     if (attrs) {
8783         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8784         HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
8785                         ? GvSTASH(CvGV(cv))
8786                         : PL_curstash;
8787         if (!name) SAVEFREESV(cv);
8788         apply_attrs(stash, MUTABLE_SV(cv), attrs);
8789         if (!name) SvREFCNT_inc_simple_void_NN(cv);
8790     }
8791
8792     if (block && has_name) {
8793         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8794             SV * const tmpstr = cv_name(cv,NULL,0);
8795             GV * const db_postponed = gv_fetchpvs("DB::postponed",
8796                                                   GV_ADDMULTI, SVt_PVHV);
8797             HV *hv;
8798             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8799                                           CopFILE(PL_curcop),
8800                                           (long)PL_subline,
8801                                           (long)CopLINE(PL_curcop));
8802             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8803                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8804             hv = GvHVn(db_postponed);
8805             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8806                 CV * const pcv = GvCV(db_postponed);
8807                 if (pcv) {
8808                     dSP;
8809                     PUSHMARK(SP);
8810                     XPUSHs(tmpstr);
8811                     PUTBACK;
8812                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
8813                 }
8814             }
8815         }
8816
8817         if (name) {
8818             if (PL_parser && PL_parser->error_count)
8819                 clear_special_blocks(name, gv, cv);
8820             else
8821                 evanescent =
8822                     process_special_blocks(floor, name, gv, cv);
8823         }
8824     }
8825
8826   done:
8827     if (PL_parser)
8828         PL_parser->copline = NOLINE;
8829     LEAVE_SCOPE(floor);
8830     if (!evanescent) {
8831 #ifdef PERL_DEBUG_READONLY_OPS
8832       if (slab)
8833         Slab_to_ro(slab);
8834 #endif
8835       if (cv && name && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
8836         pad_add_weakref(cv);
8837     }
8838     return cv;
8839 }
8840
8841 STATIC void
8842 S_clear_special_blocks(pTHX_ const char *const fullname,
8843                        GV *const gv, CV *const cv) {
8844     const char *colon;
8845     const char *name;
8846
8847     PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
8848
8849     colon = strrchr(fullname,':');
8850     name = colon ? colon + 1 : fullname;
8851
8852     if ((*name == 'B' && strEQ(name, "BEGIN"))
8853         || (*name == 'E' && strEQ(name, "END"))
8854         || (*name == 'U' && strEQ(name, "UNITCHECK"))
8855         || (*name == 'C' && strEQ(name, "CHECK"))
8856         || (*name == 'I' && strEQ(name, "INIT"))) {
8857         if (!isGV(gv)) {
8858             (void)CvGV(cv);
8859             assert(isGV(gv));
8860         }
8861         GvCV_set(gv, NULL);
8862         SvREFCNT_dec_NN(MUTABLE_SV(cv));
8863     }
8864 }
8865
8866 /* Returns true if the sub has been freed.  */
8867 STATIC bool
8868 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
8869                          GV *const gv,
8870                          CV *const cv)
8871 {
8872     const char *const colon = strrchr(fullname,':');
8873     const char *const name = colon ? colon + 1 : fullname;
8874
8875     PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
8876
8877     if (*name == 'B') {
8878         if (strEQ(name, "BEGIN")) {
8879             const I32 oldscope = PL_scopestack_ix;
8880             dSP;
8881             (void)CvGV(cv);
8882             if (floor) LEAVE_SCOPE(floor);
8883             ENTER;
8884             PUSHSTACKi(PERLSI_REQUIRE);
8885             SAVECOPFILE(&PL_compiling);
8886             SAVECOPLINE(&PL_compiling);
8887             SAVEVPTR(PL_curcop);
8888
8889             DEBUG_x( dump_sub(gv) );
8890             Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
8891             GvCV_set(gv,0);             /* cv has been hijacked */
8892             call_list(oldscope, PL_beginav);
8893
8894             POPSTACK;
8895             LEAVE;
8896             return !PL_savebegin;
8897         }
8898         else
8899             return FALSE;
8900     } else {
8901         if (*name == 'E') {
8902             if strEQ(name, "END") {
8903                 DEBUG_x( dump_sub(gv) );
8904                 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
8905             } else
8906                 return FALSE;
8907         } else if (*name == 'U') {
8908             if (strEQ(name, "UNITCHECK")) {
8909                 /* It's never too late to run a unitcheck block */
8910                 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
8911             }
8912             else
8913                 return FALSE;
8914         } else if (*name == 'C') {
8915             if (strEQ(name, "CHECK")) {
8916                 if (PL_main_start)
8917                     /* diag_listed_as: Too late to run %s block */
8918                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8919                                    "Too late to run CHECK block");
8920                 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
8921             }
8922             else
8923                 return FALSE;
8924         } else if (*name == 'I') {
8925             if (strEQ(name, "INIT")) {
8926                 if (PL_main_start)
8927                     /* diag_listed_as: Too late to run %s block */
8928                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8929                                    "Too late to run INIT block");
8930                 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
8931             }
8932             else
8933                 return FALSE;
8934         } else
8935             return FALSE;
8936         DEBUG_x( dump_sub(gv) );
8937         (void)CvGV(cv);
8938         GvCV_set(gv,0);         /* cv has been hijacked */
8939         return FALSE;
8940     }
8941 }
8942
8943 /*
8944 =for apidoc newCONSTSUB
8945
8946 See L</newCONSTSUB_flags>.
8947
8948 =cut
8949 */
8950
8951 CV *
8952 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
8953 {
8954     return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
8955 }
8956
8957 /*
8958 =for apidoc newCONSTSUB_flags
8959
8960 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
8961 eligible for inlining at compile-time.
8962
8963 Currently, the only useful value for C<flags> is SVf_UTF8.
8964
8965 The newly created subroutine takes ownership of a reference to the passed in
8966 SV.
8967
8968 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
8969 which won't be called if used as a destructor, but will suppress the overhead
8970 of a call to C<AUTOLOAD>.  (This form, however, isn't eligible for inlining at
8971 compile time.)
8972
8973 =cut
8974 */
8975
8976 CV *
8977 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
8978                              U32 flags, SV *sv)
8979 {
8980     CV* cv;
8981     const char *const file = CopFILE(PL_curcop);
8982
8983     ENTER;
8984
8985     if (IN_PERL_RUNTIME) {
8986         /* at runtime, it's not safe to manipulate PL_curcop: it may be
8987          * an op shared between threads. Use a non-shared COP for our
8988          * dirty work */
8989          SAVEVPTR(PL_curcop);
8990          SAVECOMPILEWARNINGS();
8991          PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
8992          PL_curcop = &PL_compiling;
8993     }
8994     SAVECOPLINE(PL_curcop);
8995     CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
8996
8997     SAVEHINTS();
8998     PL_hints &= ~HINT_BLOCK_SCOPE;
8999
9000     if (stash) {
9001         SAVEGENERICSV(PL_curstash);
9002         PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
9003     }
9004
9005     /* Protect sv against leakage caused by fatal warnings. */
9006     if (sv) SAVEFREESV(sv);
9007
9008     /* file becomes the CvFILE. For an XS, it's usually static storage,
9009        and so doesn't get free()d.  (It's expected to be from the C pre-
9010        processor __FILE__ directive). But we need a dynamically allocated one,
9011        and we need it to get freed.  */
9012     cv = newXS_len_flags(name, len,
9013                          sv && SvTYPE(sv) == SVt_PVAV
9014                              ? const_av_xsub
9015                              : const_sv_xsub,
9016                          file ? file : "", "",
9017                          &sv, XS_DYNAMIC_FILENAME | flags);
9018     CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
9019     CvCONST_on(cv);
9020
9021     LEAVE;
9022
9023     return cv;
9024 }
9025
9026 /*
9027 =for apidoc U||newXS
9028
9029 Used by C<xsubpp> to hook up XSUBs as Perl subs.  C<filename> needs to be
9030 static storage, as it is used directly as CvFILE(), without a copy being made.
9031
9032 =cut
9033 */
9034
9035 CV *
9036 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
9037 {
9038     PERL_ARGS_ASSERT_NEWXS;
9039     return newXS_len_flags(
9040         name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
9041     );
9042 }
9043
9044 CV *
9045 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
9046                  const char *const filename, const char *const proto,
9047                  U32 flags)
9048 {
9049     PERL_ARGS_ASSERT_NEWXS_FLAGS;
9050     return newXS_len_flags(
9051        name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
9052     );
9053 }
9054
9055 CV *
9056 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
9057 {
9058     PERL_ARGS_ASSERT_NEWXS_DEFFILE;
9059     return newXS_len_flags(
9060         name, strlen(name), subaddr, NULL, NULL, NULL, 0
9061     );
9062 }
9063
9064 CV *
9065 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
9066                            XSUBADDR_t subaddr, const char *const filename,
9067                            const char *const proto, SV **const_svp,
9068                            U32 flags)
9069 {
9070     CV *cv;
9071     bool interleave = FALSE;
9072
9073     PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
9074
9075     {
9076         GV * const gv = gv_fetchpvn(
9077                             name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
9078                             name ? len : PL_curstash ? sizeof("__ANON__") - 1:
9079                                 sizeof("__ANON__::__ANON__") - 1,
9080                             GV_ADDMULTI | flags, SVt_PVCV);
9081
9082         if ((cv = (name ? GvCV(gv) : NULL))) {
9083             if (GvCVGEN(gv)) {
9084                 /* just a cached method */
9085                 SvREFCNT_dec(cv);
9086                 cv = NULL;
9087             }
9088             else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
9089                 /* already defined (or promised) */
9090                 /* Redundant check that allows us to avoid creating an SV
9091                    most of the time: */
9092                 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
9093                     report_redefined_cv(newSVpvn_flags(
9094                                          name,len,(flags&SVf_UTF8)|SVs_TEMP
9095                                         ),
9096                                         cv, const_svp);
9097                 }
9098                 interleave = TRUE;
9099                 ENTER;
9100                 SAVEFREESV(cv);
9101                 cv = NULL;
9102             }
9103         }
9104
9105         if (cv)                         /* must reuse cv if autoloaded */
9106             cv_undef(cv);
9107         else {
9108             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9109             if (name) {
9110                 GvCV_set(gv,cv);
9111                 GvCVGEN(gv) = 0;
9112                 if (HvENAME_HEK(GvSTASH(gv)))
9113                     gv_method_changed(gv); /* newXS */
9114             }
9115         }
9116
9117         CvGV_set(cv, gv);
9118         if(filename) {
9119             (void)gv_fetchfile(filename);
9120             assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
9121             if (flags & XS_DYNAMIC_FILENAME) {
9122                 CvDYNFILE_on(cv);
9123                 CvFILE(cv) = savepv(filename);
9124             } else {
9125             /* NOTE: not copied, as it is expected to be an external constant string */
9126                 CvFILE(cv) = (char *)filename;
9127             }
9128         } else {
9129             assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
9130             CvFILE(cv) = (char*)PL_xsubfilename;
9131         }
9132         CvISXSUB_on(cv);
9133         CvXSUB(cv) = subaddr;
9134 #ifndef PERL_IMPLICIT_CONTEXT
9135         CvHSCXT(cv) = &PL_stack_sp;
9136 #else
9137         PoisonPADLIST(cv);
9138 #endif
9139
9140         if (name)
9141             process_special_blocks(0, name, gv, cv);
9142         else
9143             CvANON_on(cv);
9144     } /* <- not a conditional branch */
9145
9146
9147     sv_setpv(MUTABLE_SV(cv), proto);
9148     if (interleave) LEAVE;
9149     return cv;
9150 }
9151
9152 CV *
9153 Perl_newSTUB(pTHX_ GV *gv, bool fake)
9154 {
9155     CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9156     GV *cvgv;
9157     PERL_ARGS_ASSERT_NEWSTUB;
9158     assert(!GvCVu(gv));
9159     GvCV_set(gv, cv);
9160     GvCVGEN(gv) = 0;
9161     if (!fake && HvENAME_HEK(GvSTASH(gv)))
9162         gv_method_changed(gv);
9163     if (SvFAKE(gv)) {
9164         cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
9165         SvFAKE_off(cvgv);
9166     }
9167     else cvgv = gv;
9168     CvGV_set(cv, cvgv);
9169     CvFILE_set_from_cop(cv, PL_curcop);
9170     CvSTASH_set(cv, PL_curstash);
9171     GvMULTI_on(gv);
9172     return cv;
9173 }
9174
9175 void
9176 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
9177 {
9178     CV *cv;
9179
9180     GV *gv;
9181
9182     if (PL_parser && PL_parser->error_count) {
9183         op_free(block);
9184         goto finish;
9185     }
9186
9187     gv = o
9188         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
9189         : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
9190
9191     GvMULTI_on(gv);
9192     if ((cv = GvFORM(gv))) {
9193         if (ckWARN(WARN_REDEFINE)) {
9194             const line_t oldline = CopLINE(PL_curcop);
9195             if (PL_parser && PL_parser->copline != NOLINE)
9196                 CopLINE_set(PL_curcop, PL_parser->copline);
9197             if (o) {
9198                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9199                             "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
9200             } else {
9201                 /* diag_listed_as: Format %s redefined */
9202                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9203                             "Format STDOUT redefined");
9204             }
9205             CopLINE_set(PL_curcop, oldline);
9206         }
9207         SvREFCNT_dec(cv);
9208     }
9209     cv = PL_compcv;
9210     GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
9211     CvGV_set(cv, gv);
9212     CvFILE_set_from_cop(cv, PL_curcop);
9213
9214
9215     pad_tidy(padtidy_FORMAT);
9216     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
9217     CvROOT(cv)->op_private |= OPpREFCOUNTED;
9218     OpREFCNT_set(CvROOT(cv), 1);
9219     CvSTART(cv) = LINKLIST(CvROOT(cv));
9220     CvROOT(cv)->op_next = 0;
9221     CALL_PEEP(CvSTART(cv));
9222     finalize_optree(CvROOT(cv));
9223     S_prune_chain_head(&CvSTART(cv));
9224     cv_forget_slab(cv);
9225
9226   finish:
9227     op_free(o);
9228     if (PL_parser)
9229         PL_parser->copline = NOLINE;
9230     LEAVE_SCOPE(floor);
9231     PL_compiling.cop_seq = 0;
9232 }
9233
9234 OP *
9235 Perl_newANONLIST(pTHX_ OP *o)
9236 {
9237     return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
9238 }
9239
9240 OP *
9241 Perl_newANONHASH(pTHX_ OP *o)
9242 {
9243     return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
9244 }
9245
9246 OP *
9247 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
9248 {
9249     return newANONATTRSUB(floor, proto, NULL, block);
9250 }
9251
9252 OP *
9253 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
9254 {
9255     SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
9256     OP * anoncode =
9257         newSVOP(OP_ANONCODE, 0,
9258                 cv);
9259     if (CvANONCONST(cv))
9260         anoncode = newUNOP(OP_ANONCONST, 0,
9261                            op_convert_list(OP_ENTERSUB,
9262                                            OPf_STACKED|OPf_WANT_SCALAR,
9263                                            anoncode));
9264     return newUNOP(OP_REFGEN, 0, anoncode);
9265 }
9266
9267 OP *
9268 Perl_oopsAV(pTHX_ OP *o)
9269 {
9270     dVAR;
9271
9272     PERL_ARGS_ASSERT_OOPSAV;
9273
9274     switch (o->op_type) {
9275     case OP_PADSV:
9276     case OP_PADHV:
9277         OpTYPE_set(o, OP_PADAV);
9278         return ref(o, OP_RV2AV);
9279
9280     case OP_RV2SV:
9281     case OP_RV2HV:
9282         OpTYPE_set(o, OP_RV2AV);
9283         ref(o, OP_RV2AV);
9284         break;
9285
9286     default:
9287         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
9288         break;
9289     }
9290     return o;
9291 }
9292
9293 OP *
9294 Perl_oopsHV(pTHX_ OP *o)
9295 {
9296     dVAR;
9297
9298     PERL_ARGS_ASSERT_OOPSHV;
9299
9300     switch (o->op_type) {
9301     case OP_PADSV:
9302     case OP_PADAV:
9303         OpTYPE_set(o, OP_PADHV);
9304         return ref(o, OP_RV2HV);
9305
9306     case OP_RV2SV:
9307     case OP_RV2AV:
9308         OpTYPE_set(o, OP_RV2HV);
9309         ref(o, OP_RV2HV);
9310         break;
9311
9312     default:
9313         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
9314         break;
9315     }
9316     return o;
9317 }
9318
9319 OP *
9320 Perl_newAVREF(pTHX_ OP *o)
9321 {
9322     dVAR;
9323
9324     PERL_ARGS_ASSERT_NEWAVREF;
9325
9326     if (o->op_type == OP_PADANY) {
9327         OpTYPE_set(o, OP_PADAV);
9328         return o;
9329     }
9330     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
9331         Perl_croak(aTHX_ "Can't use an array as a reference");
9332     }
9333     return newUNOP(OP_RV2AV, 0, scalar(o));
9334 }
9335
9336 OP *
9337 Perl_newGVREF(pTHX_ I32 type, OP *o)
9338 {
9339     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
9340         return newUNOP(OP_NULL, 0, o);
9341     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
9342 }
9343
9344 OP *
9345 Perl_newHVREF(pTHX_ OP *o)
9346 {
9347     dVAR;
9348
9349     PERL_ARGS_ASSERT_NEWHVREF;
9350
9351     if (o->op_type == OP_PADANY) {
9352         OpTYPE_set(o, OP_PADHV);
9353         return o;
9354     }
9355     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
9356         Perl_croak(aTHX_ "Can't use a hash as a reference");
9357     }
9358     return newUNOP(OP_RV2HV, 0, scalar(o));
9359 }
9360
9361 OP *
9362 Perl_newCVREF(pTHX_ I32 flags, OP *o)
9363 {
9364     if (o->op_type == OP_PADANY) {
9365         dVAR;
9366         OpTYPE_set(o, OP_PADCV);
9367     }
9368     return newUNOP(OP_RV2CV, flags, scalar(o));
9369 }
9370
9371 OP *
9372 Perl_newSVREF(pTHX_ OP *o)
9373 {
9374     dVAR;
9375
9376     PERL_ARGS_ASSERT_NEWSVREF;
9377
9378     if (o->op_type == OP_PADANY) {
9379         OpTYPE_set(o, OP_PADSV);
9380         scalar(o);
9381         return o;
9382     }
9383     return newUNOP(OP_RV2SV, 0, scalar(o));
9384 }
9385
9386 /* Check routines. See the comments at the top of this file for details
9387  * on when these are called */
9388
9389 OP *
9390 Perl_ck_anoncode(pTHX_ OP *o)
9391 {
9392     PERL_ARGS_ASSERT_CK_ANONCODE;
9393
9394     cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
9395     cSVOPo->op_sv = NULL;
9396     return o;
9397 }
9398
9399 static void
9400 S_io_hints(pTHX_ OP *o)
9401 {
9402 #if O_BINARY != 0 || O_TEXT != 0
9403     HV * const table =
9404         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
9405     if (table) {
9406         SV **svp = hv_fetchs(table, "open_IN", FALSE);
9407         if (svp && *svp) {
9408             STRLEN len = 0;
9409             const char *d = SvPV_const(*svp, len);
9410             const I32 mode = mode_from_discipline(d, len);
9411             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9412 #  if O_BINARY != 0
9413             if (mode & O_BINARY)
9414                 o->op_private |= OPpOPEN_IN_RAW;
9415 #  endif
9416 #  if O_TEXT != 0
9417             if (mode & O_TEXT)
9418                 o->op_private |= OPpOPEN_IN_CRLF;
9419 #  endif
9420         }
9421
9422         svp = hv_fetchs(table, "open_OUT", FALSE);
9423         if (svp && *svp) {
9424             STRLEN len = 0;
9425             const char *d = SvPV_const(*svp, len);
9426             const I32 mode = mode_from_discipline(d, len);
9427             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9428 #  if O_BINARY != 0
9429             if (mode & O_BINARY)
9430                 o->op_private |= OPpOPEN_OUT_RAW;
9431 #  endif
9432 #  if O_TEXT != 0
9433             if (mode & O_TEXT)
9434                 o->op_private |= OPpOPEN_OUT_CRLF;
9435 #  endif
9436         }
9437     }
9438 #else
9439     PERL_UNUSED_CONTEXT;
9440     PERL_UNUSED_ARG(o);
9441 #endif
9442 }
9443
9444 OP *
9445 Perl_ck_backtick(pTHX_ OP *o)
9446 {
9447     GV *gv;
9448     OP *newop = NULL;
9449     OP *sibl;
9450     PERL_ARGS_ASSERT_CK_BACKTICK;
9451     /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
9452     if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
9453      && (gv = gv_override("readpipe",8)))
9454     {
9455         /* detach rest of siblings from o and its first child */
9456         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
9457         newop = S_new_entersubop(aTHX_ gv, sibl);
9458     }
9459     else if (!(o->op_flags & OPf_KIDS))
9460         newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
9461     if (newop) {
9462         op_free(o);
9463         return newop;
9464     }
9465     S_io_hints(aTHX_ o);
9466     return o;
9467 }
9468
9469 OP *
9470 Perl_ck_bitop(pTHX_ OP *o)
9471 {
9472     PERL_ARGS_ASSERT_CK_BITOP;
9473
9474     o->op_private = (U8)(PL_hints & HINT_INTEGER);
9475
9476     if (o->op_type == OP_NBIT_OR     || o->op_type == OP_SBIT_OR
9477      || o->op_type == OP_NBIT_XOR    || o->op_type == OP_SBIT_XOR
9478      || o->op_type == OP_NBIT_AND    || o->op_type == OP_SBIT_AND
9479      || o->op_type == OP_NCOMPLEMENT || o->op_type == OP_SCOMPLEMENT)
9480         Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__BITWISE),
9481                               "The bitwise feature is experimental");
9482     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
9483             && OP_IS_INFIX_BIT(o->op_type))
9484     {
9485         const OP * const left = cBINOPo->op_first;
9486         const OP * const right = OpSIBLING(left);
9487         if ((OP_IS_NUMCOMPARE(left->op_type) &&
9488                 (left->op_flags & OPf_PARENS) == 0) ||
9489             (OP_IS_NUMCOMPARE(right->op_type) &&
9490                 (right->op_flags & OPf_PARENS) == 0))
9491             Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
9492                           "Possible precedence problem on bitwise %s operator",
9493                            o->op_type ==  OP_BIT_OR
9494                          ||o->op_type == OP_NBIT_OR  ? "|"
9495                         :  o->op_type ==  OP_BIT_AND
9496                          ||o->op_type == OP_NBIT_AND ? "&"
9497                         :  o->op_type ==  OP_BIT_XOR
9498                          ||o->op_type == OP_NBIT_XOR ? "^"
9499                         :  o->op_type == OP_SBIT_OR  ? "|."
9500                         :  o->op_type == OP_SBIT_AND ? "&." : "^."
9501                            );
9502     }
9503     return o;
9504 }
9505
9506 PERL_STATIC_INLINE bool
9507 is_dollar_bracket(pTHX_ const OP * const o)
9508 {
9509     const OP *kid;
9510     PERL_UNUSED_CONTEXT;
9511     return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
9512         && (kid = cUNOPx(o)->op_first)
9513         && kid->op_type == OP_GV
9514         && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
9515 }
9516
9517 OP *
9518 Perl_ck_cmp(pTHX_ OP *o)
9519 {
9520     PERL_ARGS_ASSERT_CK_CMP;
9521     if (ckWARN(WARN_SYNTAX)) {
9522         const OP *kid = cUNOPo->op_first;
9523         if (kid &&
9524             (
9525                 (   is_dollar_bracket(aTHX_ kid)
9526                  && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
9527                 )
9528              || (   kid->op_type == OP_CONST
9529                  && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
9530                 )
9531            )
9532         )
9533             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9534                         "$[ used in %s (did you mean $] ?)", OP_DESC(o));
9535     }
9536     return o;
9537 }
9538
9539 OP *
9540 Perl_ck_concat(pTHX_ OP *o)
9541 {
9542     const OP * const kid = cUNOPo->op_first;
9543
9544     PERL_ARGS_ASSERT_CK_CONCAT;
9545     PERL_UNUSED_CONTEXT;
9546
9547     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
9548             !(kUNOP->op_first->op_flags & OPf_MOD))
9549         o->op_flags |= OPf_STACKED;
9550     return o;
9551 }
9552
9553 OP *
9554 Perl_ck_spair(pTHX_ OP *o)
9555 {
9556     dVAR;
9557
9558     PERL_ARGS_ASSERT_CK_SPAIR;
9559
9560     if (o->op_flags & OPf_KIDS) {
9561         OP* newop;
9562         OP* kid;
9563         OP* kidkid;
9564         const OPCODE type = o->op_type;
9565         o = modkids(ck_fun(o), type);
9566         kid    = cUNOPo->op_first;
9567         kidkid = kUNOP->op_first;
9568         newop = OpSIBLING(kidkid);
9569         if (newop) {
9570             const OPCODE type = newop->op_type;
9571             if (OpHAS_SIBLING(newop))
9572                 return o;
9573             if (o->op_type == OP_REFGEN
9574              && (  type == OP_RV2CV
9575                 || (  !(newop->op_flags & OPf_PARENS)
9576                    && (  type == OP_RV2AV || type == OP_PADAV
9577                       || type == OP_RV2HV || type == OP_PADHV))))
9578                 NOOP; /* OK (allow srefgen for \@a and \%h) */
9579             else if (OP_GIMME(newop,0) != G_SCALAR)
9580                 return o;
9581         }
9582         /* excise first sibling */
9583         op_sibling_splice(kid, NULL, 1, NULL);
9584         op_free(kidkid);
9585     }
9586     /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
9587      * and OP_CHOMP into OP_SCHOMP */
9588     o->op_ppaddr = PL_ppaddr[++o->op_type];
9589     return ck_fun(o);
9590 }
9591
9592 OP *
9593 Perl_ck_delete(pTHX_ OP *o)
9594 {
9595     PERL_ARGS_ASSERT_CK_DELETE;
9596
9597     o = ck_fun(o);
9598     o->op_private = 0;
9599     if (o->op_flags & OPf_KIDS) {
9600         OP * const kid = cUNOPo->op_first;
9601         switch (kid->op_type) {
9602         case OP_ASLICE:
9603             o->op_flags |= OPf_SPECIAL;
9604             /* FALLTHROUGH */
9605         case OP_HSLICE:
9606             o->op_private |= OPpSLICE;
9607             break;
9608         case OP_AELEM:
9609             o->op_flags |= OPf_SPECIAL;
9610             /* FALLTHROUGH */
9611         case OP_HELEM:
9612             break;
9613         case OP_KVASLICE:
9614             Perl_croak(aTHX_ "delete argument is index/value array slice,"
9615                              " use array slice");
9616         case OP_KVHSLICE:
9617             Perl_croak(aTHX_ "delete argument is key/value hash slice, use"
9618                              " hash slice");
9619         default:
9620             Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
9621                              "element or slice");
9622         }
9623         if (kid->op_private & OPpLVAL_INTRO)
9624             o->op_private |= OPpLVAL_INTRO;
9625         op_null(kid);
9626     }
9627     return o;
9628 }
9629
9630 OP *
9631 Perl_ck_eof(pTHX_ OP *o)
9632 {
9633     PERL_ARGS_ASSERT_CK_EOF;
9634
9635     if (o->op_flags & OPf_KIDS) {
9636         OP *kid;
9637         if (cLISTOPo->op_first->op_type == OP_STUB) {
9638             OP * const newop
9639                 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
9640             op_free(o);
9641             o = newop;
9642         }
9643         o = ck_fun(o);
9644         kid = cLISTOPo->op_first;
9645         if (kid->op_type == OP_RV2GV)
9646             kid->op_private |= OPpALLOW_FAKE;
9647     }
9648     return o;
9649 }
9650
9651 OP *
9652 Perl_ck_eval(pTHX_ OP *o)
9653 {
9654     dVAR;
9655
9656     PERL_ARGS_ASSERT_CK_EVAL;
9657
9658     PL_hints |= HINT_BLOCK_SCOPE;
9659     if (o->op_flags & OPf_KIDS) {
9660         SVOP * const kid = (SVOP*)cUNOPo->op_first;
9661         assert(kid);
9662
9663         if (o->op_type == OP_ENTERTRY) {
9664             LOGOP *enter;
9665
9666             /* cut whole sibling chain free from o */
9667             op_sibling_splice(o, NULL, -1, NULL);
9668             op_free(o);
9669
9670             enter = S_alloc_LOGOP(aTHX_ OP_ENTERTRY, NULL, NULL);
9671
9672             /* establish postfix order */
9673             enter->op_next = (OP*)enter;
9674
9675             o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
9676             OpTYPE_set(o, OP_LEAVETRY);
9677             enter->op_other = o;
9678             return o;
9679         }
9680         else {
9681             scalar((OP*)kid);
9682             S_set_haseval(aTHX);
9683         }
9684     }
9685     else {
9686         const U8 priv = o->op_private;
9687         op_free(o);
9688         /* the newUNOP will recursively call ck_eval(), which will handle
9689          * all the stuff at the end of this function, like adding
9690          * OP_HINTSEVAL
9691          */
9692         return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
9693     }
9694     o->op_targ = (PADOFFSET)PL_hints;
9695     if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
9696     if ((PL_hints & HINT_LOCALIZE_HH) != 0
9697      && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
9698         /* Store a copy of %^H that pp_entereval can pick up. */
9699         OP *hhop = newSVOP(OP_HINTSEVAL, 0,
9700                            MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
9701         /* append hhop to only child  */
9702         op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
9703
9704         o->op_private |= OPpEVAL_HAS_HH;
9705     }
9706     if (!(o->op_private & OPpEVAL_BYTES)
9707          && FEATURE_UNIEVAL_IS_ENABLED)
9708             o->op_private |= OPpEVAL_UNICODE;
9709     return o;
9710 }
9711
9712 OP *
9713 Perl_ck_exec(pTHX_ OP *o)
9714 {
9715     PERL_ARGS_ASSERT_CK_EXEC;
9716
9717     if (o->op_flags & OPf_STACKED) {
9718         OP *kid;
9719         o = ck_fun(o);
9720         kid = OpSIBLING(cUNOPo->op_first);
9721         if (kid->op_type == OP_RV2GV)
9722             op_null(kid);
9723     }
9724     else
9725         o = listkids(o);
9726     return o;
9727 }
9728
9729 OP *
9730 Perl_ck_exists(pTHX_ OP *o)
9731 {
9732     PERL_ARGS_ASSERT_CK_EXISTS;
9733
9734     o = ck_fun(o);
9735     if (o->op_flags & OPf_KIDS) {
9736         OP * const kid = cUNOPo->op_first;
9737         if (kid->op_type == OP_ENTERSUB) {
9738             (void) ref(kid, o->op_type);
9739             if (kid->op_type != OP_RV2CV
9740                         && !(PL_parser && PL_parser->error_count))
9741                 Perl_croak(aTHX_
9742                           "exists argument is not a subroutine name");
9743             o->op_private |= OPpEXISTS_SUB;
9744         }
9745         else if (kid->op_type == OP_AELEM)
9746             o->op_flags |= OPf_SPECIAL;
9747         else if (kid->op_type != OP_HELEM)
9748             Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
9749                              "element or a subroutine");
9750         op_null(kid);
9751     }
9752     return o;
9753 }
9754
9755 OP *
9756 Perl_ck_rvconst(pTHX_ OP *o)
9757 {
9758     dVAR;
9759     SVOP * const kid = (SVOP*)cUNOPo->op_first;
9760
9761     PERL_ARGS_ASSERT_CK_RVCONST;
9762
9763     o->op_private |= (PL_hints & HINT_STRICT_REFS);
9764
9765     if (kid->op_type == OP_CONST) {
9766         int iscv;
9767         GV *gv;
9768         SV * const kidsv = kid->op_sv;
9769
9770         /* Is it a constant from cv_const_sv()? */
9771         if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
9772             return o;
9773         }
9774         if (SvTYPE(kidsv) == SVt_PVAV) return o;
9775         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
9776             const char *badthing;
9777             switch (o->op_type) {
9778             case OP_RV2SV:
9779                 badthing = "a SCALAR";
9780                 break;
9781             case OP_RV2AV:
9782                 badthing = "an ARRAY";
9783                 break;
9784             case OP_RV2HV:
9785                 badthing = "a HASH";
9786                 break;
9787             default:
9788                 badthing = NULL;
9789                 break;
9790             }
9791             if (badthing)
9792                 Perl_croak(aTHX_
9793                            "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
9794                            SVfARG(kidsv), badthing);
9795         }
9796         /*
9797          * This is a little tricky.  We only want to add the symbol if we
9798          * didn't add it in the lexer.  Otherwise we get duplicate strict
9799          * warnings.  But if we didn't add it in the lexer, we must at
9800          * least pretend like we wanted to add it even if it existed before,
9801          * or we get possible typo warnings.  OPpCONST_ENTERED says
9802          * whether the lexer already added THIS instance of this symbol.
9803          */
9804         iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
9805         gv = gv_fetchsv(kidsv,
9806                 o->op_type == OP_RV2CV
9807                         && o->op_private & OPpMAY_RETURN_CONSTANT
9808                     ? GV_NOEXPAND
9809                     : iscv | !(kid->op_private & OPpCONST_ENTERED),
9810                 iscv
9811                     ? SVt_PVCV
9812                     : o->op_type == OP_RV2SV
9813                         ? SVt_PV
9814                         : o->op_type == OP_RV2AV
9815                             ? SVt_PVAV
9816                             : o->op_type == OP_RV2HV
9817                                 ? SVt_PVHV
9818                                 : SVt_PVGV);
9819         if (gv) {
9820             if (!isGV(gv)) {
9821                 assert(iscv);
9822                 assert(SvROK(gv));
9823                 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
9824                   && SvTYPE(SvRV(gv)) != SVt_PVCV)
9825                     gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
9826             }
9827             OpTYPE_set(kid, OP_GV);
9828             SvREFCNT_dec(kid->op_sv);
9829 #ifdef USE_ITHREADS
9830             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
9831             STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
9832             kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
9833             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
9834             PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
9835 #else
9836             kid->op_sv = SvREFCNT_inc_simple_NN(gv);
9837 #endif
9838             kid->op_private = 0;
9839             /* FAKE globs in the symbol table cause weird bugs (#77810) */
9840             SvFAKE_off(gv);
9841         }
9842     }
9843     return o;
9844 }
9845
9846 OP *
9847 Perl_ck_ftst(pTHX_ OP *o)
9848 {
9849     dVAR;
9850     const I32 type = o->op_type;
9851
9852     PERL_ARGS_ASSERT_CK_FTST;
9853
9854     if (o->op_flags & OPf_REF) {
9855         NOOP;
9856     }
9857     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
9858         SVOP * const kid = (SVOP*)cUNOPo->op_first;
9859         const OPCODE kidtype = kid->op_type;
9860
9861         if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
9862          && !kid->op_folded) {
9863             OP * const newop = newGVOP(type, OPf_REF,
9864                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
9865             op_free(o);
9866             return newop;
9867         }
9868         if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
9869             o->op_private |= OPpFT_ACCESS;
9870         if (type != OP_STAT && type != OP_LSTAT
9871             && PL_check[kidtype] == Perl_ck_ftst
9872             && kidtype != OP_STAT && kidtype != OP_LSTAT
9873         ) {
9874             o->op_private |= OPpFT_STACKED;
9875             kid->op_private |= OPpFT_STACKING;
9876             if (kidtype == OP_FTTTY && (
9877                    !(kid->op_private & OPpFT_STACKED)
9878                 || kid->op_private & OPpFT_AFTER_t
9879                ))
9880                 o->op_private |= OPpFT_AFTER_t;
9881         }
9882     }
9883     else {
9884         op_free(o);
9885         if (type == OP_FTTTY)
9886             o = newGVOP(type, OPf_REF, PL_stdingv);
9887         else
9888             o = newUNOP(type, 0, newDEFSVOP());
9889     }
9890     return o;
9891 }
9892
9893 OP *
9894 Perl_ck_fun(pTHX_ OP *o)
9895 {
9896     const int type = o->op_type;
9897     I32 oa = PL_opargs[type] >> OASHIFT;
9898
9899     PERL_ARGS_ASSERT_CK_FUN;
9900
9901     if (o->op_flags & OPf_STACKED) {
9902         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
9903             oa &= ~OA_OPTIONAL;
9904         else
9905             return no_fh_allowed(o);
9906     }
9907
9908     if (o->op_flags & OPf_KIDS) {
9909         OP *prev_kid = NULL;
9910         OP *kid = cLISTOPo->op_first;
9911         I32 numargs = 0;
9912         bool seen_optional = FALSE;
9913
9914         if (kid->op_type == OP_PUSHMARK ||
9915             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
9916         {
9917             prev_kid = kid;
9918             kid = OpSIBLING(kid);
9919         }
9920         if (kid && kid->op_type == OP_COREARGS) {
9921             bool optional = FALSE;
9922             while (oa) {
9923                 numargs++;
9924                 if (oa & OA_OPTIONAL) optional = TRUE;
9925                 oa = oa >> 4;
9926             }
9927             if (optional) o->op_private |= numargs;
9928             return o;
9929         }
9930
9931         while (oa) {
9932             if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
9933                 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
9934                     kid = newDEFSVOP();
9935                     /* append kid to chain */
9936                     op_sibling_splice(o, prev_kid, 0, kid);
9937                 }
9938                 seen_optional = TRUE;
9939             }
9940             if (!kid) break;
9941
9942             numargs++;
9943             switch (oa & 7) {
9944             case OA_SCALAR:
9945                 /* list seen where single (scalar) arg expected? */
9946                 if (numargs == 1 && !(oa >> 4)
9947                     && kid->op_type == OP_LIST && type != OP_SCALAR)
9948                 {
9949                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
9950                 }
9951                 if (type != OP_DELETE) scalar(kid);
9952                 break;
9953             case OA_LIST:
9954                 if (oa < 16) {
9955                     kid = 0;
9956                     continue;
9957                 }
9958                 else
9959                     list(kid);
9960                 break;
9961             case OA_AVREF:
9962                 if ((type == OP_PUSH || type == OP_UNSHIFT)
9963                     && !OpHAS_SIBLING(kid))
9964                     Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
9965                                    "Useless use of %s with no values",
9966                                    PL_op_desc[type]);
9967
9968                 if (kid->op_type == OP_CONST
9969                       && (  !SvROK(cSVOPx_sv(kid))
9970                          || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV  )
9971                         )
9972                     bad_type_pv(numargs, "array", o, kid);
9973                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
9974                     yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
9975                                          PL_op_desc[type]), 0);
9976                 }
9977                 else {
9978                     op_lvalue(kid, type);
9979                 }
9980                 break;
9981             case OA_HVREF:
9982                 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
9983                     bad_type_pv(numargs, "hash", o, kid);
9984                 op_lvalue(kid, type);
9985                 break;
9986             case OA_CVREF:
9987                 {
9988                     /* replace kid with newop in chain */
9989                     OP * const newop =
9990                         S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
9991                     newop->op_next = newop;
9992                     kid = newop;
9993                 }
9994                 break;
9995             case OA_FILEREF:
9996                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
9997                     if (kid->op_type == OP_CONST &&
9998                         (kid->op_private & OPpCONST_BARE))
9999                     {
10000                         OP * const newop = newGVOP(OP_GV, 0,
10001                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
10002                         /* replace kid with newop in chain */
10003                         op_sibling_splice(o, prev_kid, 1, newop);
10004                         op_free(kid);
10005                         kid = newop;
10006                     }
10007                     else if (kid->op_type == OP_READLINE) {
10008                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
10009                         bad_type_pv(numargs, "HANDLE", o, kid);
10010                     }
10011                     else {
10012                         I32 flags = OPf_SPECIAL;
10013                         I32 priv = 0;
10014                         PADOFFSET targ = 0;
10015
10016                         /* is this op a FH constructor? */
10017                         if (is_handle_constructor(o,numargs)) {
10018                             const char *name = NULL;
10019                             STRLEN len = 0;
10020                             U32 name_utf8 = 0;
10021                             bool want_dollar = TRUE;
10022
10023                             flags = 0;
10024                             /* Set a flag to tell rv2gv to vivify
10025                              * need to "prove" flag does not mean something
10026                              * else already - NI-S 1999/05/07
10027                              */
10028                             priv = OPpDEREF;
10029                             if (kid->op_type == OP_PADSV) {
10030                                 PADNAME * const pn
10031                                     = PAD_COMPNAME_SV(kid->op_targ);
10032                                 name = PadnamePV (pn);
10033                                 len  = PadnameLEN(pn);
10034                                 name_utf8 = PadnameUTF8(pn);
10035                             }
10036                             else if (kid->op_type == OP_RV2SV
10037                                      && kUNOP->op_first->op_type == OP_GV)
10038                             {
10039                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
10040                                 name = GvNAME(gv);
10041                                 len = GvNAMELEN(gv);
10042                                 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
10043                             }
10044                             else if (kid->op_type == OP_AELEM
10045                                      || kid->op_type == OP_HELEM)
10046                             {
10047                                  OP *firstop;
10048                                  OP *op = ((BINOP*)kid)->op_first;
10049                                  name = NULL;
10050                                  if (op) {
10051                                       SV *tmpstr = NULL;
10052                                       const char * const a =
10053                                            kid->op_type == OP_AELEM ?
10054                                            "[]" : "{}";
10055                                       if (((op->op_type == OP_RV2AV) ||
10056                                            (op->op_type == OP_RV2HV)) &&
10057                                           (firstop = ((UNOP*)op)->op_first) &&
10058                                           (firstop->op_type == OP_GV)) {
10059                                            /* packagevar $a[] or $h{} */
10060                                            GV * const gv = cGVOPx_gv(firstop);
10061                                            if (gv)
10062                                                 tmpstr =
10063                                                      Perl_newSVpvf(aTHX_
10064                                                                    "%s%c...%c",
10065                                                                    GvNAME(gv),
10066                                                                    a[0], a[1]);
10067                                       }
10068                                       else if (op->op_type == OP_PADAV
10069                                                || op->op_type == OP_PADHV) {
10070                                            /* lexicalvar $a[] or $h{} */
10071                                            const char * const padname =
10072                                                 PAD_COMPNAME_PV(op->op_targ);
10073                                            if (padname)
10074                                                 tmpstr =
10075                                                      Perl_newSVpvf(aTHX_
10076                                                                    "%s%c...%c",
10077                                                                    padname + 1,
10078                                                                    a[0], a[1]);
10079                                       }
10080                                       if (tmpstr) {
10081                                            name = SvPV_const(tmpstr, len);
10082                                            name_utf8 = SvUTF8(tmpstr);
10083                                            sv_2mortal(tmpstr);
10084                                       }
10085                                  }
10086                                  if (!name) {
10087                                       name = "__ANONIO__";
10088                                       len = 10;
10089                                       want_dollar = FALSE;
10090                                  }
10091                                  op_lvalue(kid, type);
10092                             }
10093                             if (name) {
10094                                 SV *namesv;
10095                                 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
10096                                 namesv = PAD_SVl(targ);
10097                                 if (want_dollar && *name != '$')
10098                                     sv_setpvs(namesv, "$");
10099                                 else
10100                                     sv_setpvs(namesv, "");
10101                                 sv_catpvn(namesv, name, len);
10102                                 if ( name_utf8 ) SvUTF8_on(namesv);
10103                             }
10104                         }
10105                         scalar(kid);
10106                         kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
10107                                     OP_RV2GV, flags);
10108                         kid->op_targ = targ;
10109                         kid->op_private |= priv;
10110                     }
10111                 }
10112                 scalar(kid);
10113                 break;
10114             case OA_SCALARREF:
10115                 if ((type == OP_UNDEF || type == OP_POS)
10116                     && numargs == 1 && !(oa >> 4)
10117                     && kid->op_type == OP_LIST)
10118                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
10119                 op_lvalue(scalar(kid), type);
10120                 break;
10121             }
10122             oa >>= 4;
10123             prev_kid = kid;
10124             kid = OpSIBLING(kid);
10125         }
10126         /* FIXME - should the numargs or-ing move after the too many
10127          * arguments check? */
10128         o->op_private |= numargs;
10129         if (kid)
10130             return too_many_arguments_pv(o,OP_DESC(o), 0);
10131         listkids(o);
10132     }
10133     else if (PL_opargs[type] & OA_DEFGV) {
10134         /* Ordering of these two is important to keep f_map.t passing.  */
10135         op_free(o);
10136         return newUNOP(type, 0, newDEFSVOP());
10137     }
10138
10139     if (oa) {
10140         while (oa & OA_OPTIONAL)
10141             oa >>= 4;
10142         if (oa && oa != OA_LIST)
10143             return too_few_arguments_pv(o,OP_DESC(o), 0);
10144     }
10145     return o;
10146 }
10147
10148 OP *
10149 Perl_ck_glob(pTHX_ OP *o)
10150 {
10151     GV *gv;
10152
10153     PERL_ARGS_ASSERT_CK_GLOB;
10154
10155     o = ck_fun(o);
10156     if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
10157         op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
10158
10159     if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
10160     {
10161         /* convert
10162          *     glob
10163          *       \ null - const(wildcard)
10164          * into
10165          *     null
10166          *       \ enter
10167          *            \ list
10168          *                 \ mark - glob - rv2cv
10169          *                             |        \ gv(CORE::GLOBAL::glob)
10170          *                             |
10171          *                              \ null - const(wildcard)
10172          */
10173         o->op_flags |= OPf_SPECIAL;
10174         o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
10175         o = S_new_entersubop(aTHX_ gv, o);
10176         o = newUNOP(OP_NULL, 0, o);
10177         o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
10178         return o;
10179     }
10180     else o->op_flags &= ~OPf_SPECIAL;
10181 #if !defined(PERL_EXTERNAL_GLOB)
10182     if (!PL_globhook) {
10183         ENTER;
10184         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
10185                                newSVpvs("File::Glob"), NULL, NULL, NULL);
10186         LEAVE;
10187     }
10188 #endif /* !PERL_EXTERNAL_GLOB */
10189     gv = (GV *)newSV(0);
10190     gv_init(gv, 0, "", 0, 0);
10191     gv_IOadd(gv);
10192     op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
10193     SvREFCNT_dec_NN(gv); /* newGVOP increased it */
10194     scalarkids(o);
10195     return o;
10196 }
10197
10198 OP *
10199 Perl_ck_grep(pTHX_ OP *o)
10200 {
10201     LOGOP *gwop;
10202     OP *kid;
10203     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
10204     PADOFFSET offset;
10205
10206     PERL_ARGS_ASSERT_CK_GREP;
10207
10208     /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
10209
10210     if (o->op_flags & OPf_STACKED) {
10211         kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
10212         if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
10213             return no_fh_allowed(o);
10214         o->op_flags &= ~OPf_STACKED;
10215     }
10216     kid = OpSIBLING(cLISTOPo->op_first);
10217     if (type == OP_MAPWHILE)
10218         list(kid);
10219     else
10220         scalar(kid);
10221     o = ck_fun(o);
10222     if (PL_parser && PL_parser->error_count)
10223         return o;
10224     kid = OpSIBLING(cLISTOPo->op_first);
10225     if (kid->op_type != OP_NULL)
10226         Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
10227     kid = kUNOP->op_first;
10228
10229     gwop = S_alloc_LOGOP(aTHX_ type, o, LINKLIST(kid));
10230     kid->op_next = (OP*)gwop;
10231     offset = pad_findmy_pvs("$_", 0);
10232     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
10233         o->op_private = gwop->op_private = 0;
10234         gwop->op_targ = pad_alloc(type, SVs_PADTMP);
10235     }
10236     else {
10237         o->op_private = gwop->op_private = OPpGREP_LEX;
10238         gwop->op_targ = o->op_targ = offset;
10239     }
10240
10241     kid = OpSIBLING(cLISTOPo->op_first);
10242     for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
10243         op_lvalue(kid, OP_GREPSTART);
10244
10245     return (OP*)gwop;
10246 }
10247
10248 OP *
10249 Perl_ck_index(pTHX_ OP *o)
10250 {
10251     PERL_ARGS_ASSERT_CK_INDEX;
10252
10253     if (o->op_flags & OPf_KIDS) {
10254         OP *kid = OpSIBLING(cLISTOPo->op_first);        /* get past pushmark */
10255         if (kid)
10256             kid = OpSIBLING(kid);                       /* get past "big" */
10257         if (kid && kid->op_type == OP_CONST) {
10258             const bool save_taint = TAINT_get;
10259             SV *sv = kSVOP->op_sv;
10260             if ((!SvPOK(sv) || SvNIOKp(sv)) && SvOK(sv) && !SvROK(sv)) {
10261                 sv = newSV(0);
10262                 sv_copypv(sv, kSVOP->op_sv);
10263                 SvREFCNT_dec_NN(kSVOP->op_sv);
10264                 kSVOP->op_sv = sv;
10265             }
10266             if (SvOK(sv)) fbm_compile(sv, 0);
10267             TAINT_set(save_taint);
10268 #ifdef NO_TAINT_SUPPORT
10269             PERL_UNUSED_VAR(save_taint);
10270 #endif
10271         }
10272     }
10273     return ck_fun(o);
10274 }
10275
10276 OP *
10277 Perl_ck_lfun(pTHX_ OP *o)
10278 {
10279     const OPCODE type = o->op_type;
10280
10281     PERL_ARGS_ASSERT_CK_LFUN;
10282
10283     return modkids(ck_fun(o), type);
10284 }
10285
10286 OP *
10287 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
10288 {
10289     PERL_ARGS_ASSERT_CK_DEFINED;
10290
10291     if ((o->op_flags & OPf_KIDS)) {
10292         switch (cUNOPo->op_first->op_type) {
10293         case OP_RV2AV:
10294         case OP_PADAV:
10295             Perl_croak(aTHX_ "Can't use 'defined(@array)'"
10296                              " (Maybe you should just omit the defined()?)");
10297         break;
10298         case OP_RV2HV:
10299         case OP_PADHV:
10300             Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
10301                              " (Maybe you should just omit the defined()?)");
10302             break;
10303         default:
10304             /* no warning */
10305             break;
10306         }
10307     }
10308     return ck_rfun(o);
10309 }
10310
10311 OP *
10312 Perl_ck_readline(pTHX_ OP *o)
10313 {
10314     PERL_ARGS_ASSERT_CK_READLINE;
10315
10316     if (o->op_flags & OPf_KIDS) {
10317          OP *kid = cLISTOPo->op_first;
10318          if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
10319     }
10320     else {
10321         OP * const newop
10322             = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
10323         op_free(o);
10324         return newop;
10325     }
10326     return o;
10327 }
10328
10329 OP *
10330 Perl_ck_rfun(pTHX_ OP *o)
10331 {
10332     const OPCODE type = o->op_type;
10333
10334     PERL_ARGS_ASSERT_CK_RFUN;
10335
10336     return refkids(ck_fun(o), type);
10337 }
10338
10339 OP *
10340 Perl_ck_listiob(pTHX_ OP *o)
10341 {
10342     OP *kid;
10343
10344     PERL_ARGS_ASSERT_CK_LISTIOB;
10345
10346     kid = cLISTOPo->op_first;
10347     if (!kid) {
10348         o = force_list(o, 1);
10349         kid = cLISTOPo->op_first;
10350     }
10351     if (kid->op_type == OP_PUSHMARK)
10352         kid = OpSIBLING(kid);
10353     if (kid && o->op_flags & OPf_STACKED)
10354         kid = OpSIBLING(kid);
10355     else if (kid && !OpHAS_SIBLING(kid)) {              /* print HANDLE; */
10356         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
10357          && !kid->op_folded) {
10358             o->op_flags |= OPf_STACKED; /* make it a filehandle */
10359             scalar(kid);
10360             /* replace old const op with new OP_RV2GV parent */
10361             kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
10362                                         OP_RV2GV, OPf_REF);
10363             kid = OpSIBLING(kid);
10364         }
10365     }
10366
10367     if (!kid)
10368         op_append_elem(o->op_type, o, newDEFSVOP());
10369
10370     if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
10371     return listkids(o);
10372 }
10373
10374 OP *
10375 Perl_ck_smartmatch(pTHX_ OP *o)
10376 {
10377     dVAR;
10378     PERL_ARGS_ASSERT_CK_SMARTMATCH;
10379     if (0 == (o->op_flags & OPf_SPECIAL)) {
10380         OP *first  = cBINOPo->op_first;
10381         OP *second = OpSIBLING(first);
10382
10383         /* Implicitly take a reference to an array or hash */
10384
10385         /* remove the original two siblings, then add back the
10386          * (possibly different) first and second sibs.
10387          */
10388         op_sibling_splice(o, NULL, 1, NULL);
10389         op_sibling_splice(o, NULL, 1, NULL);
10390         first  = ref_array_or_hash(first);
10391         second = ref_array_or_hash(second);
10392         op_sibling_splice(o, NULL, 0, second);
10393         op_sibling_splice(o, NULL, 0, first);
10394
10395         /* Implicitly take a reference to a regular expression */
10396         if (first->op_type == OP_MATCH) {
10397             OpTYPE_set(first, OP_QR);
10398         }
10399         if (second->op_type == OP_MATCH) {
10400             OpTYPE_set(second, OP_QR);
10401         }
10402     }
10403
10404     return o;
10405 }
10406
10407
10408 static OP *
10409 S_maybe_targlex(pTHX_ OP *o)
10410 {
10411     OP * const kid = cLISTOPo->op_first;
10412     /* has a disposable target? */
10413     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
10414         && !(kid->op_flags & OPf_STACKED)
10415         /* Cannot steal the second time! */
10416         && !(kid->op_private & OPpTARGET_MY)
10417         )
10418     {
10419         OP * const kkid = OpSIBLING(kid);
10420
10421         /* Can just relocate the target. */
10422         if (kkid && kkid->op_type == OP_PADSV
10423             && (!(kkid->op_private & OPpLVAL_INTRO)
10424                || kkid->op_private & OPpPAD_STATE))
10425         {
10426             kid->op_targ = kkid->op_targ;
10427             kkid->op_targ = 0;
10428             /* Now we do not need PADSV and SASSIGN.
10429              * Detach kid and free the rest. */
10430             op_sibling_splice(o, NULL, 1, NULL);
10431             op_free(o);
10432             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
10433             return kid;
10434         }
10435     }
10436     return o;
10437 }
10438
10439 OP *
10440 Perl_ck_sassign(pTHX_ OP *o)
10441 {
10442     dVAR;
10443     OP * const kid = cLISTOPo->op_first;
10444
10445     PERL_ARGS_ASSERT_CK_SASSIGN;
10446
10447     if (OpHAS_SIBLING(kid)) {
10448         OP *kkid = OpSIBLING(kid);
10449         /* For state variable assignment with attributes, kkid is a list op
10450            whose op_last is a padsv. */
10451         if ((kkid->op_type == OP_PADSV ||
10452              (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
10453               (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
10454              )
10455             )
10456                 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
10457                     == (OPpLVAL_INTRO|OPpPAD_STATE)) {
10458             const PADOFFSET target = kkid->op_targ;
10459             OP *const other = newOP(OP_PADSV,
10460                                     kkid->op_flags
10461                                     | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
10462             OP *const first = newOP(OP_NULL, 0);
10463             OP *const nullop =
10464                 newCONDOP(0, first, o, other);
10465             /* XXX targlex disabled for now; see ticket #124160
10466                 newCONDOP(0, first, S_maybe_targlex(aTHX_ o), other);
10467              */
10468             OP *const condop = first->op_next;
10469
10470             OpTYPE_set(condop, OP_ONCE);
10471             other->op_targ = target;
10472             nullop->op_flags |= OPf_WANT_SCALAR;
10473
10474             /* Store the initializedness of state vars in a separate
10475                pad entry.  */
10476             condop->op_targ =
10477               pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
10478             /* hijacking PADSTALE for uninitialized state variables */
10479             SvPADSTALE_on(PAD_SVl(condop->op_targ));
10480
10481             return nullop;
10482         }
10483     }
10484     return S_maybe_targlex(aTHX_ o);
10485 }
10486
10487 OP *
10488 Perl_ck_match(pTHX_ OP *o)
10489 {
10490     PERL_ARGS_ASSERT_CK_MATCH;
10491
10492     if (o->op_type != OP_QR && PL_compcv) {
10493         const PADOFFSET offset = pad_findmy_pvs("$_", 0);
10494         if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
10495             o->op_targ = offset;
10496             o->op_private |= OPpTARGET_MY;
10497         }
10498     }
10499     if (o->op_type == OP_MATCH || o->op_type == OP_QR)
10500         o->op_private |= OPpRUNTIME;
10501     return o;
10502 }
10503
10504 OP *
10505 Perl_ck_method(pTHX_ OP *o)
10506 {
10507     SV *sv, *methsv, *rclass;
10508     const char* method;
10509     char* compatptr;
10510     int utf8;
10511     STRLEN len, nsplit = 0, i;
10512     OP* new_op;
10513     OP * const kid = cUNOPo->op_first;
10514
10515     PERL_ARGS_ASSERT_CK_METHOD;
10516     if (kid->op_type != OP_CONST) return o;
10517
10518     sv = kSVOP->op_sv;
10519
10520     /* replace ' with :: */
10521     while ((compatptr = strchr(SvPVX(sv), '\''))) {
10522         *compatptr = ':';
10523         sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
10524     }
10525
10526     method = SvPVX_const(sv);
10527     len = SvCUR(sv);
10528     utf8 = SvUTF8(sv) ? -1 : 1;
10529
10530     for (i = len - 1; i > 0; --i) if (method[i] == ':') {
10531         nsplit = i+1;
10532         break;
10533     }
10534
10535     methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
10536
10537     if (!nsplit) { /* $proto->method() */
10538         op_free(o);
10539         return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
10540     }
10541
10542     if (nsplit == 7 && memEQ(method, "SUPER::", nsplit)) { /* $proto->SUPER::method() */
10543         op_free(o);
10544         return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
10545     }
10546
10547     /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
10548     if (nsplit >= 9 && strnEQ(method+nsplit-9, "::SUPER::", 9)) {
10549         rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
10550         new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
10551     } else {
10552         rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
10553         new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
10554     }
10555 #ifdef USE_ITHREADS
10556     op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
10557 #else
10558     cMETHOPx(new_op)->op_rclass_sv = rclass;
10559 #endif
10560     op_free(o);
10561     return new_op;
10562 }
10563
10564 OP *
10565 Perl_ck_null(pTHX_ OP *o)
10566 {
10567     PERL_ARGS_ASSERT_CK_NULL;
10568     PERL_UNUSED_CONTEXT;
10569     return o;
10570 }
10571
10572 OP *
10573 Perl_ck_open(pTHX_ OP *o)
10574 {
10575     PERL_ARGS_ASSERT_CK_OPEN;
10576
10577     S_io_hints(aTHX_ o);
10578     {
10579          /* In case of three-arg dup open remove strictness
10580           * from the last arg if it is a bareword. */
10581          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
10582          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
10583          OP *oa;
10584          const char *mode;
10585
10586          if ((last->op_type == OP_CONST) &&             /* The bareword. */
10587              (last->op_private & OPpCONST_BARE) &&
10588              (last->op_private & OPpCONST_STRICT) &&
10589              (oa = OpSIBLING(first)) &&         /* The fh. */
10590              (oa = OpSIBLING(oa)) &&                    /* The mode. */
10591              (oa->op_type == OP_CONST) &&
10592              SvPOK(((SVOP*)oa)->op_sv) &&
10593              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
10594              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
10595              (last == OpSIBLING(oa)))                   /* The bareword. */
10596               last->op_private &= ~OPpCONST_STRICT;
10597     }
10598     return ck_fun(o);
10599 }
10600
10601 OP *
10602 Perl_ck_prototype(pTHX_ OP *o)
10603 {
10604     PERL_ARGS_ASSERT_CK_PROTOTYPE;
10605     if (!(o->op_flags & OPf_KIDS)) {
10606         op_free(o);
10607         return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
10608     }
10609     return o;
10610 }
10611
10612 OP *
10613 Perl_ck_refassign(pTHX_ OP *o)
10614 {
10615     OP * const right = cLISTOPo->op_first;
10616     OP * const left = OpSIBLING(right);
10617     OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
10618     bool stacked = 0;
10619
10620     PERL_ARGS_ASSERT_CK_REFASSIGN;
10621     assert (left);
10622     assert (left->op_type == OP_SREFGEN);
10623
10624     o->op_private = varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE);
10625
10626     switch (varop->op_type) {
10627     case OP_PADAV:
10628         o->op_private |= OPpLVREF_AV;
10629         goto settarg;
10630     case OP_PADHV:
10631         o->op_private |= OPpLVREF_HV;
10632     case OP_PADSV:
10633       settarg:
10634         o->op_targ = varop->op_targ;
10635         varop->op_targ = 0;
10636         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
10637         break;
10638     case OP_RV2AV:
10639         o->op_private |= OPpLVREF_AV;
10640         goto checkgv;
10641         NOT_REACHED; /* NOTREACHED */
10642     case OP_RV2HV:
10643         o->op_private |= OPpLVREF_HV;
10644         /* FALLTHROUGH */
10645     case OP_RV2SV:
10646       checkgv:
10647         if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
10648       detach_and_stack:
10649         /* Point varop to its GV kid, detached.  */
10650         varop = op_sibling_splice(varop, NULL, -1, NULL);
10651         stacked = TRUE;
10652         break;
10653     case OP_RV2CV: {
10654         OP * const kidparent =
10655             OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
10656         OP * const kid = cUNOPx(kidparent)->op_first;
10657         o->op_private |= OPpLVREF_CV;
10658         if (kid->op_type == OP_GV) {
10659             varop = kidparent;
10660             goto detach_and_stack;
10661         }
10662         if (kid->op_type != OP_PADCV)   goto bad;
10663         o->op_targ = kid->op_targ;
10664         kid->op_targ = 0;
10665         break;
10666     }
10667     case OP_AELEM:
10668     case OP_HELEM:
10669         o->op_private |= OPpLVREF_ELEM;
10670         op_null(varop);
10671         stacked = TRUE;
10672         /* Detach varop.  */
10673         op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
10674         break;
10675     default:
10676       bad:
10677         /* diag_listed_as: Can't modify reference to %s in %s assignment */
10678         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
10679                                 "assignment",
10680                                  OP_DESC(varop)));
10681         return o;
10682     }
10683     if (!FEATURE_REFALIASING_IS_ENABLED)
10684         Perl_croak(aTHX_
10685                   "Experimental aliasing via reference not enabled");
10686     Perl_ck_warner_d(aTHX_
10687                      packWARN(WARN_EXPERIMENTAL__REFALIASING),
10688                     "Aliasing via reference is experimental");
10689     if (stacked) {
10690         o->op_flags |= OPf_STACKED;
10691         op_sibling_splice(o, right, 1, varop);
10692     }
10693     else {
10694         o->op_flags &=~ OPf_STACKED;
10695         op_sibling_splice(o, right, 1, NULL);
10696     }
10697     op_free(left);
10698     return o;
10699 }
10700
10701 OP *
10702 Perl_ck_repeat(pTHX_ OP *o)
10703 {
10704     PERL_ARGS_ASSERT_CK_REPEAT;
10705
10706     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
10707         OP* kids;
10708         o->op_private |= OPpREPEAT_DOLIST;
10709         kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
10710         kids = force_list(kids, 1); /* promote it to a list */
10711         op_sibling_splice(o, NULL, 0, kids); /* and add back */
10712     }
10713     else
10714         scalar(o);
10715     return o;
10716 }
10717
10718 OP *
10719 Perl_ck_require(pTHX_ OP *o)
10720 {
10721     GV* gv;
10722
10723     PERL_ARGS_ASSERT_CK_REQUIRE;
10724
10725     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
10726         SVOP * const kid = (SVOP*)cUNOPo->op_first;
10727         HEK *hek;
10728         U32 hash;
10729         char *s;
10730         STRLEN len;
10731         if (kid->op_type == OP_CONST) {
10732           SV * const sv = kid->op_sv;
10733           U32 const was_readonly = SvREADONLY(sv);
10734           if (kid->op_private & OPpCONST_BARE) {
10735             dVAR;
10736             const char *end;
10737
10738             if (was_readonly) {
10739                     SvREADONLY_off(sv);
10740             }
10741             if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
10742
10743             s = SvPVX(sv);
10744             len = SvCUR(sv);
10745             end = s + len;
10746             for (; s < end; s++) {
10747                 if (*s == ':' && s[1] == ':') {
10748                     *s = '/';
10749                     Move(s+2, s+1, end - s - 1, char);
10750                     --end;
10751                 }
10752             }
10753             SvEND_set(sv, end);
10754             sv_catpvs(sv, ".pm");
10755             PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
10756             hek = share_hek(SvPVX(sv),
10757                             (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
10758                             hash);
10759             sv_sethek(sv, hek);
10760             unshare_hek(hek);
10761             SvFLAGS(sv) |= was_readonly;
10762           }
10763           else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
10764                 && !SvVOK(sv)) {
10765             s = SvPV(sv, len);
10766             if (SvREFCNT(sv) > 1) {
10767                 kid->op_sv = newSVpvn_share(
10768                     s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
10769                 SvREFCNT_dec_NN(sv);
10770             }
10771             else {
10772                 dVAR;
10773                 if (was_readonly) SvREADONLY_off(sv);
10774                 PERL_HASH(hash, s, len);
10775                 hek = share_hek(s,
10776                                 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
10777                                 hash);
10778                 sv_sethek(sv, hek);
10779                 unshare_hek(hek);
10780                 SvFLAGS(sv) |= was_readonly;
10781             }
10782           }
10783         }
10784     }
10785
10786     if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
10787         /* handle override, if any */
10788      && (gv = gv_override("require", 7))) {
10789         OP *kid, *newop;
10790         if (o->op_flags & OPf_KIDS) {
10791             kid = cUNOPo->op_first;
10792             op_sibling_splice(o, NULL, -1, NULL);
10793         }
10794         else {
10795             kid = newDEFSVOP();
10796         }
10797         op_free(o);
10798         newop = S_new_entersubop(aTHX_ gv, kid);
10799         return newop;
10800     }
10801
10802     return ck_fun(o);
10803 }
10804
10805 OP *
10806 Perl_ck_return(pTHX_ OP *o)
10807 {
10808     OP *kid;
10809
10810     PERL_ARGS_ASSERT_CK_RETURN;
10811
10812     kid = OpSIBLING(cLISTOPo->op_first);
10813     if (CvLVALUE(PL_compcv)) {
10814         for (; kid; kid = OpSIBLING(kid))
10815             op_lvalue(kid, OP_LEAVESUBLV);
10816     }
10817
10818     return o;
10819 }
10820
10821 OP *
10822 Perl_ck_select(pTHX_ OP *o)
10823 {
10824     dVAR;
10825     OP* kid;
10826
10827     PERL_ARGS_ASSERT_CK_SELECT;
10828
10829     if (o->op_flags & OPf_KIDS) {
10830         kid = OpSIBLING(cLISTOPo->op_first);     /* get past pushmark */
10831         if (kid && OpHAS_SIBLING(kid)) {
10832             OpTYPE_set(o, OP_SSELECT);
10833             o = ck_fun(o);
10834             return fold_constants(op_integerize(op_std_init(o)));
10835         }
10836     }
10837     o = ck_fun(o);
10838     kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
10839     if (kid && kid->op_type == OP_RV2GV)
10840         kid->op_private &= ~HINT_STRICT_REFS;
10841     return o;
10842 }
10843
10844 OP *
10845 Perl_ck_shift(pTHX_ OP *o)
10846 {
10847     const I32 type = o->op_type;
10848
10849     PERL_ARGS_ASSERT_CK_SHIFT;
10850
10851     if (!(o->op_flags & OPf_KIDS)) {
10852         OP *argop;
10853
10854         if (!CvUNIQUE(PL_compcv)) {
10855             o->op_flags |= OPf_SPECIAL;
10856             return o;
10857         }
10858
10859         argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
10860         op_free(o);
10861         return newUNOP(type, 0, scalar(argop));
10862     }
10863     return scalar(ck_fun(o));
10864 }
10865
10866 OP *
10867 Perl_ck_sort(pTHX_ OP *o)
10868 {
10869     OP *firstkid;
10870     OP *kid;
10871     HV * const hinthv =
10872         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
10873     U8 stacked;
10874
10875     PERL_ARGS_ASSERT_CK_SORT;
10876
10877     if (hinthv) {
10878             SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
10879             if (svp) {
10880                 const I32 sorthints = (I32)SvIV(*svp);
10881                 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
10882                     o->op_private |= OPpSORT_QSORT;
10883                 if ((sorthints & HINT_SORT_STABLE) != 0)
10884                     o->op_private |= OPpSORT_STABLE;
10885             }
10886     }
10887
10888     if (o->op_flags & OPf_STACKED)
10889         simplify_sort(o);
10890     firstkid = OpSIBLING(cLISTOPo->op_first);           /* get past pushmark */
10891
10892     if ((stacked = o->op_flags & OPf_STACKED)) {        /* may have been cleared */
10893         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
10894
10895         /* if the first arg is a code block, process it and mark sort as
10896          * OPf_SPECIAL */
10897         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
10898             LINKLIST(kid);
10899             if (kid->op_type == OP_LEAVE)
10900                     op_null(kid);                       /* wipe out leave */
10901             /* Prevent execution from escaping out of the sort block. */
10902             kid->op_next = 0;
10903
10904             /* provide scalar context for comparison function/block */
10905             kid = scalar(firstkid);
10906             kid->op_next = kid;
10907             o->op_flags |= OPf_SPECIAL;
10908         }
10909         else if (kid->op_type == OP_CONST
10910               && kid->op_private & OPpCONST_BARE) {
10911             char tmpbuf[256];
10912             STRLEN len;
10913             PADOFFSET off;
10914             const char * const name = SvPV(kSVOP_sv, len);
10915             *tmpbuf = '&';
10916             assert (len < 256);
10917             Copy(name, tmpbuf+1, len, char);
10918             off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv));
10919             if (off != NOT_IN_PAD) {
10920                 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
10921                     SV * const fq =
10922                         newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
10923                     sv_catpvs(fq, "::");
10924                     sv_catsv(fq, kSVOP_sv);
10925                     SvREFCNT_dec_NN(kSVOP_sv);
10926                     kSVOP->op_sv = fq;
10927                 }
10928                 else {
10929                     OP * const padop = newOP(OP_PADCV, 0);
10930                     padop->op_targ = off;
10931                     /* replace the const op with the pad op */
10932                     op_sibling_splice(firstkid, NULL, 1, padop);
10933                     op_free(kid);
10934                 }
10935             }
10936         }
10937
10938         firstkid = OpSIBLING(firstkid);
10939     }
10940
10941     for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
10942         /* provide list context for arguments */
10943         list(kid);
10944         if (stacked)
10945             op_lvalue(kid, OP_GREPSTART);
10946     }
10947
10948     return o;
10949 }
10950
10951 /* for sort { X } ..., where X is one of
10952  *   $a <=> $b, $b <= $a, $a cmp $b, $b cmp $a
10953  * elide the second child of the sort (the one containing X),
10954  * and set these flags as appropriate
10955         OPpSORT_NUMERIC;
10956         OPpSORT_INTEGER;
10957         OPpSORT_DESCEND;
10958  * Also, check and warn on lexical $a, $b.
10959  */
10960
10961 STATIC void
10962 S_simplify_sort(pTHX_ OP *o)
10963 {
10964     OP *kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
10965     OP *k;
10966     int descending;
10967     GV *gv;
10968     const char *gvname;
10969     bool have_scopeop;
10970
10971     PERL_ARGS_ASSERT_SIMPLIFY_SORT;
10972
10973     kid = kUNOP->op_first;                              /* get past null */
10974     if (!(have_scopeop = kid->op_type == OP_SCOPE)
10975      && kid->op_type != OP_LEAVE)
10976         return;
10977     kid = kLISTOP->op_last;                             /* get past scope */
10978     switch(kid->op_type) {
10979         case OP_NCMP:
10980         case OP_I_NCMP:
10981         case OP_SCMP:
10982             if (!have_scopeop) goto padkids;
10983             break;
10984         default:
10985             return;
10986     }
10987     k = kid;                                            /* remember this node*/
10988     if (kBINOP->op_first->op_type != OP_RV2SV
10989      || kBINOP->op_last ->op_type != OP_RV2SV)
10990     {
10991         /*
10992            Warn about my($a) or my($b) in a sort block, *if* $a or $b is
10993            then used in a comparison.  This catches most, but not
10994            all cases.  For instance, it catches
10995                sort { my($a); $a <=> $b }
10996            but not
10997                sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
10998            (although why you'd do that is anyone's guess).
10999         */
11000
11001        padkids:
11002         if (!ckWARN(WARN_SYNTAX)) return;
11003         kid = kBINOP->op_first;
11004         do {
11005             if (kid->op_type == OP_PADSV) {
11006                 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
11007                 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
11008                  && (  PadnamePV(name)[1] == 'a'
11009                     || PadnamePV(name)[1] == 'b'  ))
11010                     /* diag_listed_as: "my %s" used in sort comparison */
11011                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11012                                      "\"%s %s\" used in sort comparison",
11013                                       PadnameIsSTATE(name)
11014                                         ? "state"
11015                                         : "my",
11016                                       PadnamePV(name));
11017             }
11018         } while ((kid = OpSIBLING(kid)));
11019         return;
11020     }
11021     kid = kBINOP->op_first;                             /* get past cmp */
11022     if (kUNOP->op_first->op_type != OP_GV)
11023         return;
11024     kid = kUNOP->op_first;                              /* get past rv2sv */
11025     gv = kGVOP_gv;
11026     if (GvSTASH(gv) != PL_curstash)
11027         return;
11028     gvname = GvNAME(gv);
11029     if (*gvname == 'a' && gvname[1] == '\0')
11030         descending = 0;
11031     else if (*gvname == 'b' && gvname[1] == '\0')
11032         descending = 1;
11033     else
11034         return;
11035
11036     kid = k;                                            /* back to cmp */
11037     /* already checked above that it is rv2sv */
11038     kid = kBINOP->op_last;                              /* down to 2nd arg */
11039     if (kUNOP->op_first->op_type != OP_GV)
11040         return;
11041     kid = kUNOP->op_first;                              /* get past rv2sv */
11042     gv = kGVOP_gv;
11043     if (GvSTASH(gv) != PL_curstash)
11044         return;
11045     gvname = GvNAME(gv);
11046     if ( descending
11047          ? !(*gvname == 'a' && gvname[1] == '\0')
11048          : !(*gvname == 'b' && gvname[1] == '\0'))
11049         return;
11050     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
11051     if (descending)
11052         o->op_private |= OPpSORT_DESCEND;
11053     if (k->op_type == OP_NCMP)
11054         o->op_private |= OPpSORT_NUMERIC;
11055     if (k->op_type == OP_I_NCMP)
11056         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
11057     kid = OpSIBLING(cLISTOPo->op_first);
11058     /* cut out and delete old block (second sibling) */
11059     op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
11060     op_free(kid);
11061 }
11062
11063 OP *
11064 Perl_ck_split(pTHX_ OP *o)
11065 {
11066     dVAR;
11067     OP *kid;
11068
11069     PERL_ARGS_ASSERT_CK_SPLIT;
11070
11071     if (o->op_flags & OPf_STACKED)
11072         return no_fh_allowed(o);
11073
11074     kid = cLISTOPo->op_first;
11075     if (kid->op_type != OP_NULL)
11076         Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
11077     /* delete leading NULL node, then add a CONST if no other nodes */
11078     op_sibling_splice(o, NULL, 1,
11079         OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
11080     op_free(kid);
11081     kid = cLISTOPo->op_first;
11082
11083     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
11084         /* remove kid, and replace with new optree */
11085         op_sibling_splice(o, NULL, 1, NULL);
11086         /* OPf_SPECIAL is used to trigger split " " behavior */
11087         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, NULL, 0, 0);
11088         op_sibling_splice(o, NULL, 0, kid);
11089     }
11090     OpTYPE_set(kid, OP_PUSHRE);
11091     /* target implies @ary=..., so wipe it */
11092     kid->op_targ = 0;
11093     scalar(kid);
11094     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
11095       Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
11096                      "Use of /g modifier is meaningless in split");
11097     }
11098
11099     if (!OpHAS_SIBLING(kid))
11100         op_append_elem(OP_SPLIT, o, newDEFSVOP());
11101
11102     kid = OpSIBLING(kid);
11103     assert(kid);
11104     scalar(kid);
11105
11106     if (!OpHAS_SIBLING(kid))
11107     {
11108         op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
11109         o->op_private |= OPpSPLIT_IMPLIM;
11110     }
11111     assert(OpHAS_SIBLING(kid));
11112
11113     kid = OpSIBLING(kid);
11114     scalar(kid);
11115
11116     if (OpHAS_SIBLING(kid))
11117         return too_many_arguments_pv(o,OP_DESC(o), 0);
11118
11119     return o;
11120 }
11121
11122 OP *
11123 Perl_ck_stringify(pTHX_ OP *o)
11124 {
11125     OP * const kid = OpSIBLING(cUNOPo->op_first);
11126     PERL_ARGS_ASSERT_CK_STRINGIFY;
11127     if ((   kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
11128          || kid->op_type == OP_LC   || kid->op_type == OP_LCFIRST
11129          || kid->op_type == OP_UC   || kid->op_type == OP_UCFIRST)
11130         && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
11131     {
11132         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
11133         op_free(o);
11134         return kid;
11135     }
11136     return ck_fun(o);
11137 }
11138
11139 OP *
11140 Perl_ck_join(pTHX_ OP *o)
11141 {
11142     OP * const kid = OpSIBLING(cLISTOPo->op_first);
11143
11144     PERL_ARGS_ASSERT_CK_JOIN;
11145
11146     if (kid && kid->op_type == OP_MATCH) {
11147         if (ckWARN(WARN_SYNTAX)) {
11148             const REGEXP *re = PM_GETRE(kPMOP);
11149             const SV *msg = re
11150                     ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
11151                                             SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
11152                     : newSVpvs_flags( "STRING", SVs_TEMP );
11153             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11154                         "/%"SVf"/ should probably be written as \"%"SVf"\"",
11155                         SVfARG(msg), SVfARG(msg));
11156         }
11157     }
11158     if (kid
11159      && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
11160         || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
11161         || (  kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
11162            && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
11163     {
11164         const OP * const bairn = OpSIBLING(kid); /* the list */
11165         if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
11166          && OP_GIMME(bairn,0) == G_SCALAR)
11167         {
11168             OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
11169                                      op_sibling_splice(o, kid, 1, NULL));
11170             op_free(o);
11171             return ret;
11172         }
11173     }
11174
11175     return ck_fun(o);
11176 }
11177
11178 /*
11179 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
11180
11181 Examines an op, which is expected to identify a subroutine at runtime,
11182 and attempts to determine at compile time which subroutine it identifies.
11183 This is normally used during Perl compilation to determine whether
11184 a prototype can be applied to a function call.  C<cvop> is the op
11185 being considered, normally an C<rv2cv> op.  A pointer to the identified
11186 subroutine is returned, if it could be determined statically, and a null
11187 pointer is returned if it was not possible to determine statically.
11188
11189 Currently, the subroutine can be identified statically if the RV that the
11190 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
11191 A C<gv> op is suitable if the GV's CV slot is populated.  A C<const> op is
11192 suitable if the constant value must be an RV pointing to a CV.  Details of
11193 this process may change in future versions of Perl.  If the C<rv2cv> op
11194 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
11195 the subroutine statically: this flag is used to suppress compile-time
11196 magic on a subroutine call, forcing it to use default runtime behaviour.
11197
11198 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
11199 of a GV reference is modified.  If a GV was examined and its CV slot was
11200 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
11201 If the op is not optimised away, and the CV slot is later populated with
11202 a subroutine having a prototype, that flag eventually triggers the warning
11203 "called too early to check prototype".
11204
11205 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
11206 of returning a pointer to the subroutine it returns a pointer to the
11207 GV giving the most appropriate name for the subroutine in this context.
11208 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
11209 (C<CvANON>) subroutine that is referenced through a GV it will be the
11210 referencing GV.  The resulting C<GV*> is cast to C<CV*> to be returned.
11211 A null pointer is returned as usual if there is no statically-determinable
11212 subroutine.
11213
11214 =cut
11215 */
11216
11217 /* shared by toke.c:yylex */
11218 CV *
11219 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
11220 {
11221     PADNAME *name = PAD_COMPNAME(off);
11222     CV *compcv = PL_compcv;
11223     while (PadnameOUTER(name)) {
11224         assert(PARENT_PAD_INDEX(name));
11225         compcv = CvOUTSIDE(compcv);
11226         name = PadlistNAMESARRAY(CvPADLIST(compcv))
11227                 [off = PARENT_PAD_INDEX(name)];
11228     }
11229     assert(!PadnameIsOUR(name));
11230     if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
11231         return PadnamePROTOCV(name);
11232     }
11233     return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
11234 }
11235
11236 CV *
11237 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
11238 {
11239     OP *rvop;
11240     CV *cv;
11241     GV *gv;
11242     PERL_ARGS_ASSERT_RV2CV_OP_CV;
11243     if (flags & ~RV2CVOPCV_FLAG_MASK)
11244         Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
11245     if (cvop->op_type != OP_RV2CV)
11246         return NULL;
11247     if (cvop->op_private & OPpENTERSUB_AMPER)
11248         return NULL;
11249     if (!(cvop->op_flags & OPf_KIDS))
11250         return NULL;
11251     rvop = cUNOPx(cvop)->op_first;
11252     switch (rvop->op_type) {
11253         case OP_GV: {
11254             gv = cGVOPx_gv(rvop);
11255             if (!isGV(gv)) {
11256                 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
11257                     cv = MUTABLE_CV(SvRV(gv));
11258                     gv = NULL;
11259                     break;
11260                 }
11261                 if (flags & RV2CVOPCV_RETURN_STUB)
11262                     return (CV *)gv;
11263                 else return NULL;
11264             }
11265             cv = GvCVu(gv);
11266             if (!cv) {
11267                 if (flags & RV2CVOPCV_MARK_EARLY)
11268                     rvop->op_private |= OPpEARLY_CV;
11269                 return NULL;
11270             }
11271         } break;
11272         case OP_CONST: {
11273             SV *rv = cSVOPx_sv(rvop);
11274             if (!SvROK(rv))
11275                 return NULL;
11276             cv = (CV*)SvRV(rv);
11277             gv = NULL;
11278         } break;
11279         case OP_PADCV: {
11280             cv = find_lexical_cv(rvop->op_targ);
11281             gv = NULL;
11282         } break;
11283         default: {
11284             return NULL;
11285         } NOT_REACHED; /* NOTREACHED */
11286     }
11287     if (SvTYPE((SV*)cv) != SVt_PVCV)
11288         return NULL;
11289     if (flags & (RV2CVOPCV_RETURN_NAME_GV|RV2CVOPCV_MAYBE_NAME_GV)) {
11290         if ((!CvANON(cv) || !gv) && !CvLEXICAL(cv)
11291          && ((flags & RV2CVOPCV_RETURN_NAME_GV) || !CvNAMED(cv)))
11292             gv = CvGV(cv);
11293         return (CV*)gv;
11294     } else {
11295         return cv;
11296     }
11297 }
11298
11299 /*
11300 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
11301
11302 Performs the default fixup of the arguments part of an C<entersub>
11303 op tree.  This consists of applying list context to each of the
11304 argument ops.  This is the standard treatment used on a call marked
11305 with C<&>, or a method call, or a call through a subroutine reference,
11306 or any other call where the callee can't be identified at compile time,
11307 or a call where the callee has no prototype.
11308
11309 =cut
11310 */
11311
11312 OP *
11313 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
11314 {
11315     OP *aop;
11316     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
11317     aop = cUNOPx(entersubop)->op_first;
11318     if (!OpHAS_SIBLING(aop))
11319         aop = cUNOPx(aop)->op_first;
11320     for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
11321         list(aop);
11322         op_lvalue(aop, OP_ENTERSUB);
11323     }
11324     return entersubop;
11325 }
11326
11327 /*
11328 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
11329
11330 Performs the fixup of the arguments part of an C<entersub> op tree
11331 based on a subroutine prototype.  This makes various modifications to
11332 the argument ops, from applying context up to inserting C<refgen> ops,
11333 and checking the number and syntactic types of arguments, as directed by
11334 the prototype.  This is the standard treatment used on a subroutine call,
11335 not marked with C<&>, where the callee can be identified at compile time
11336 and has a prototype.
11337
11338 C<protosv> supplies the subroutine prototype to be applied to the call.
11339 It may be a normal defined scalar, of which the string value will be used.
11340 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11341 that has been cast to C<SV*>) which has a prototype.  The prototype
11342 supplied, in whichever form, does not need to match the actual callee
11343 referenced by the op tree.
11344
11345 If the argument ops disagree with the prototype, for example by having
11346 an unacceptable number of arguments, a valid op tree is returned anyway.
11347 The error is reflected in the parser state, normally resulting in a single
11348 exception at the top level of parsing which covers all the compilation
11349 errors that occurred.  In the error message, the callee is referred to
11350 by the name defined by the C<namegv> parameter.
11351
11352 =cut
11353 */
11354
11355 OP *
11356 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11357 {
11358     STRLEN proto_len;
11359     const char *proto, *proto_end;
11360     OP *aop, *prev, *cvop, *parent;
11361     int optional = 0;
11362     I32 arg = 0;
11363     I32 contextclass = 0;
11364     const char *e = NULL;
11365     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
11366     if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
11367         Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
11368                    "flags=%lx", (unsigned long) SvFLAGS(protosv));
11369     if (SvTYPE(protosv) == SVt_PVCV)
11370          proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
11371     else proto = SvPV(protosv, proto_len);
11372     proto = S_strip_spaces(aTHX_ proto, &proto_len);
11373     proto_end = proto + proto_len;
11374     parent = entersubop;
11375     aop = cUNOPx(entersubop)->op_first;
11376     if (!OpHAS_SIBLING(aop)) {
11377         parent = aop;
11378         aop = cUNOPx(aop)->op_first;
11379     }
11380     prev = aop;
11381     aop = OpSIBLING(aop);
11382     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11383     while (aop != cvop) {
11384         OP* o3 = aop;
11385
11386         if (proto >= proto_end)
11387         {
11388             SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11389             yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf,
11390                                         SVfARG(namesv)), SvUTF8(namesv));
11391             return entersubop;
11392         }
11393
11394         switch (*proto) {
11395             case ';':
11396                 optional = 1;
11397                 proto++;
11398                 continue;
11399             case '_':
11400                 /* _ must be at the end */
11401                 if (proto[1] && !strchr(";@%", proto[1]))
11402                     goto oops;
11403                 /* FALLTHROUGH */
11404             case '$':
11405                 proto++;
11406                 arg++;
11407                 scalar(aop);
11408                 break;
11409             case '%':
11410             case '@':
11411                 list(aop);
11412                 arg++;
11413                 break;
11414             case '&':
11415                 proto++;
11416                 arg++;
11417                 if (    o3->op_type != OP_UNDEF
11418                     && (o3->op_type != OP_SREFGEN
11419                         || (  cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
11420                                 != OP_ANONCODE
11421                             && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
11422                                 != OP_RV2CV)))
11423                     bad_type_gv(arg, namegv, o3,
11424                             arg == 1 ? "block or sub {}" : "sub {}");
11425                 break;
11426             case '*':
11427                 /* '*' allows any scalar type, including bareword */
11428                 proto++;
11429                 arg++;
11430                 if (o3->op_type == OP_RV2GV)
11431                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
11432                 else if (o3->op_type == OP_CONST)
11433                     o3->op_private &= ~OPpCONST_STRICT;
11434                 scalar(aop);
11435                 break;
11436             case '+':
11437                 proto++;
11438                 arg++;
11439                 if (o3->op_type == OP_RV2AV ||
11440                     o3->op_type == OP_PADAV ||
11441                     o3->op_type == OP_RV2HV ||
11442                     o3->op_type == OP_PADHV
11443                 ) {
11444                     goto wrapref;
11445                 }
11446                 scalar(aop);
11447                 break;
11448             case '[': case ']':
11449                 goto oops;
11450
11451             case '\\':
11452                 proto++;
11453                 arg++;
11454             again:
11455                 switch (*proto++) {
11456                     case '[':
11457                         if (contextclass++ == 0) {
11458                             e = strchr(proto, ']');
11459                             if (!e || e == proto)
11460                                 goto oops;
11461                         }
11462                         else
11463                             goto oops;
11464                         goto again;
11465
11466                     case ']':
11467                         if (contextclass) {
11468                             const char *p = proto;
11469                             const char *const end = proto;
11470                             contextclass = 0;
11471                             while (*--p != '[')
11472                                 /* \[$] accepts any scalar lvalue */
11473                                 if (*p == '$'
11474                                  && Perl_op_lvalue_flags(aTHX_
11475                                      scalar(o3),
11476                                      OP_READ, /* not entersub */
11477                                      OP_LVALUE_NO_CROAK
11478                                     )) goto wrapref;
11479                             bad_type_gv(arg, namegv, o3,
11480                                     Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
11481                         } else
11482                             goto oops;
11483                         break;
11484                     case '*':
11485                         if (o3->op_type == OP_RV2GV)
11486                             goto wrapref;
11487                         if (!contextclass)
11488                             bad_type_gv(arg, namegv, o3, "symbol");
11489                         break;
11490                     case '&':
11491                         if (o3->op_type == OP_ENTERSUB
11492                          && !(o3->op_flags & OPf_STACKED))
11493                             goto wrapref;
11494                         if (!contextclass)
11495                             bad_type_gv(arg, namegv, o3, "subroutine");
11496                         break;
11497                     case '$':
11498                         if (o3->op_type == OP_RV2SV ||
11499                                 o3->op_type == OP_PADSV ||
11500                                 o3->op_type == OP_HELEM ||
11501                                 o3->op_type == OP_AELEM)
11502                             goto wrapref;
11503                         if (!contextclass) {
11504                             /* \$ accepts any scalar lvalue */
11505                             if (Perl_op_lvalue_flags(aTHX_
11506                                     scalar(o3),
11507                                     OP_READ,  /* not entersub */
11508                                     OP_LVALUE_NO_CROAK
11509                                )) goto wrapref;
11510                             bad_type_gv(arg, namegv, o3, "scalar");
11511                         }
11512                         break;
11513                     case '@':
11514                         if (o3->op_type == OP_RV2AV ||
11515                                 o3->op_type == OP_PADAV)
11516                         {
11517                             o3->op_flags &=~ OPf_PARENS;
11518                             goto wrapref;
11519                         }
11520                         if (!contextclass)
11521                             bad_type_gv(arg, namegv, o3, "array");
11522                         break;
11523                     case '%':
11524                         if (o3->op_type == OP_RV2HV ||
11525                                 o3->op_type == OP_PADHV)
11526                         {
11527                             o3->op_flags &=~ OPf_PARENS;
11528                             goto wrapref;
11529                         }
11530                         if (!contextclass)
11531                             bad_type_gv(arg, namegv, o3, "hash");
11532                         break;
11533                     wrapref:
11534                             aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
11535                                                 OP_REFGEN, 0);
11536                         if (contextclass && e) {
11537                             proto = e + 1;
11538                             contextclass = 0;
11539                         }
11540                         break;
11541                     default: goto oops;
11542                 }
11543                 if (contextclass)
11544                     goto again;
11545                 break;
11546             case ' ':
11547                 proto++;
11548                 continue;
11549             default:
11550             oops: {
11551                 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
11552                                   SVfARG(cv_name((CV *)namegv, NULL, 0)),
11553                                   SVfARG(protosv));
11554             }
11555         }
11556
11557         op_lvalue(aop, OP_ENTERSUB);
11558         prev = aop;
11559         aop = OpSIBLING(aop);
11560     }
11561     if (aop == cvop && *proto == '_') {
11562         /* generate an access to $_ */
11563         op_sibling_splice(parent, prev, 0, newDEFSVOP());
11564     }
11565     if (!optional && proto_end > proto &&
11566         (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
11567     {
11568         SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11569         yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf,
11570                                     SVfARG(namesv)), SvUTF8(namesv));
11571     }
11572     return entersubop;
11573 }
11574
11575 /*
11576 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
11577
11578 Performs the fixup of the arguments part of an C<entersub> op tree either
11579 based on a subroutine prototype or using default list-context processing.
11580 This is the standard treatment used on a subroutine call, not marked
11581 with C<&>, where the callee can be identified at compile time.
11582
11583 C<protosv> supplies the subroutine prototype to be applied to the call,
11584 or indicates that there is no prototype.  It may be a normal scalar,
11585 in which case if it is defined then the string value will be used
11586 as a prototype, and if it is undefined then there is no prototype.
11587 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11588 that has been cast to C<SV*>), of which the prototype will be used if it
11589 has one.  The prototype (or lack thereof) supplied, in whichever form,
11590 does not need to match the actual callee referenced by the op tree.
11591
11592 If the argument ops disagree with the prototype, for example by having
11593 an unacceptable number of arguments, a valid op tree is returned anyway.
11594 The error is reflected in the parser state, normally resulting in a single
11595 exception at the top level of parsing which covers all the compilation
11596 errors that occurred.  In the error message, the callee is referred to
11597 by the name defined by the C<namegv> parameter.
11598
11599 =cut
11600 */
11601
11602 OP *
11603 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
11604         GV *namegv, SV *protosv)
11605 {
11606     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
11607     if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
11608         return ck_entersub_args_proto(entersubop, namegv, protosv);
11609     else
11610         return ck_entersub_args_list(entersubop);
11611 }
11612
11613 OP *
11614 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11615 {
11616     int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
11617     OP *aop = cUNOPx(entersubop)->op_first;
11618
11619     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
11620
11621     if (!opnum) {
11622         OP *cvop;
11623         if (!OpHAS_SIBLING(aop))
11624             aop = cUNOPx(aop)->op_first;
11625         aop = OpSIBLING(aop);
11626         for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11627         if (aop != cvop)
11628             (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
11629
11630         op_free(entersubop);
11631         switch(GvNAME(namegv)[2]) {
11632         case 'F': return newSVOP(OP_CONST, 0,
11633                                         newSVpv(CopFILE(PL_curcop),0));
11634         case 'L': return newSVOP(
11635                            OP_CONST, 0,
11636                            Perl_newSVpvf(aTHX_
11637                              "%"IVdf, (IV)CopLINE(PL_curcop)
11638                            )
11639                          );
11640         case 'P': return newSVOP(OP_CONST, 0,
11641                                    (PL_curstash
11642                                      ? newSVhek(HvNAME_HEK(PL_curstash))
11643                                      : &PL_sv_undef
11644                                    )
11645                                 );
11646         }
11647         NOT_REACHED; /* NOTREACHED */
11648     }
11649     else {
11650         OP *prev, *cvop, *first, *parent;
11651         U32 flags = 0;
11652
11653         parent = entersubop;
11654         if (!OpHAS_SIBLING(aop)) {
11655             parent = aop;
11656             aop = cUNOPx(aop)->op_first;
11657         }
11658
11659         first = prev = aop;
11660         aop = OpSIBLING(aop);
11661         /* find last sibling */
11662         for (cvop = aop;
11663              OpHAS_SIBLING(cvop);
11664              prev = cvop, cvop = OpSIBLING(cvop))
11665             ;
11666         if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
11667             /* Usually, OPf_SPECIAL on an op with no args means that it had
11668              * parens, but these have their own meaning for that flag: */
11669             && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
11670             && opnum != OP_DELETE && opnum != OP_EXISTS)
11671                 flags |= OPf_SPECIAL;
11672         /* excise cvop from end of sibling chain */
11673         op_sibling_splice(parent, prev, 1, NULL);
11674         op_free(cvop);
11675         if (aop == cvop) aop = NULL;
11676
11677         /* detach remaining siblings from the first sibling, then
11678          * dispose of original optree */
11679
11680         if (aop)
11681             op_sibling_splice(parent, first, -1, NULL);
11682         op_free(entersubop);
11683
11684         if (opnum == OP_ENTEREVAL
11685          && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
11686             flags |= OPpEVAL_BYTES <<8;
11687
11688         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
11689         case OA_UNOP:
11690         case OA_BASEOP_OR_UNOP:
11691         case OA_FILESTATOP:
11692             return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
11693         case OA_BASEOP:
11694             if (aop) {
11695                     (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
11696                 op_free(aop);
11697             }
11698             return opnum == OP_RUNCV
11699                 ? newPVOP(OP_RUNCV,0,NULL)
11700                 : newOP(opnum,0);
11701         default:
11702             return op_convert_list(opnum,0,aop);
11703         }
11704     }
11705     NOT_REACHED; /* NOTREACHED */
11706     return entersubop;
11707 }
11708
11709 /*
11710 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
11711
11712 Retrieves the function that will be used to fix up a call to C<cv>.
11713 Specifically, the function is applied to an C<entersub> op tree for a
11714 subroutine call, not marked with C<&>, where the callee can be identified
11715 at compile time as C<cv>.
11716
11717 The C-level function pointer is returned in C<*ckfun_p>, and an SV
11718 argument for it is returned in C<*ckobj_p>.  The function is intended
11719 to be called in this manner:
11720
11721  entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
11722
11723 In this call, C<entersubop> is a pointer to the C<entersub> op,
11724 which may be replaced by the check function, and C<namegv> is a GV
11725 supplying the name that should be used by the check function to refer
11726 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11727 It is permitted to apply the check function in non-standard situations,
11728 such as to a call to a different subroutine or to a method call.
11729
11730 By default, the function is
11731 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
11732 and the SV parameter is C<cv> itself.  This implements standard
11733 prototype processing.  It can be changed, for a particular subroutine,
11734 by L</cv_set_call_checker>.
11735
11736 =cut
11737 */
11738
11739 static void
11740 S_cv_get_call_checker(CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p,
11741                       U8 *flagsp)
11742 {
11743     MAGIC *callmg;
11744     callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
11745     if (callmg) {
11746         *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
11747         *ckobj_p = callmg->mg_obj;
11748         if (flagsp) *flagsp = callmg->mg_flags;
11749     } else {
11750         *ckfun_p = Perl_ck_entersub_args_proto_or_list;
11751         *ckobj_p = (SV*)cv;
11752         if (flagsp) *flagsp = 0;
11753     }
11754 }
11755
11756 void
11757 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
11758 {
11759     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
11760     PERL_UNUSED_CONTEXT;
11761     S_cv_get_call_checker(cv, ckfun_p, ckobj_p, NULL);
11762 }
11763
11764 /*
11765 =for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 flags
11766
11767 Sets the function that will be used to fix up a call to C<cv>.
11768 Specifically, the function is applied to an C<entersub> op tree for a
11769 subroutine call, not marked with C<&>, where the callee can be identified
11770 at compile time as C<cv>.
11771
11772 The C-level function pointer is supplied in C<ckfun>, and an SV argument
11773 for it is supplied in C<ckobj>.  The function should be defined like this:
11774
11775     STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
11776
11777 It is intended to be called in this manner:
11778
11779     entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
11780
11781 In this call, C<entersubop> is a pointer to the C<entersub> op,
11782 which may be replaced by the check function, and C<namegv> supplies
11783 the name that should be used by the check function to refer
11784 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11785 It is permitted to apply the check function in non-standard situations,
11786 such as to a call to a different subroutine or to a method call.
11787
11788 C<namegv> may not actually be a GV.  For efficiency, perl may pass a
11789 CV or other SV instead.  Whatever is passed can be used as the first
11790 argument to L</cv_name>.  You can force perl to pass a GV by including
11791 C<CALL_CHECKER_REQUIRE_GV> in the C<flags>.
11792
11793 The current setting for a particular CV can be retrieved by
11794 L</cv_get_call_checker>.
11795
11796 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
11797
11798 The original form of L</cv_set_call_checker_flags>, which passes it the
11799 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.
11800
11801 =cut
11802 */
11803
11804 void
11805 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
11806 {
11807     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
11808     cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
11809 }
11810
11811 void
11812 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
11813                                      SV *ckobj, U32 flags)
11814 {
11815     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
11816     if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
11817         if (SvMAGICAL((SV*)cv))
11818             mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
11819     } else {
11820         MAGIC *callmg;
11821         sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
11822         callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
11823         assert(callmg);
11824         if (callmg->mg_flags & MGf_REFCOUNTED) {
11825             SvREFCNT_dec(callmg->mg_obj);
11826             callmg->mg_flags &= ~MGf_REFCOUNTED;
11827         }
11828         callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
11829         callmg->mg_obj = ckobj;
11830         if (ckobj != (SV*)cv) {
11831             SvREFCNT_inc_simple_void_NN(ckobj);
11832             callmg->mg_flags |= MGf_REFCOUNTED;
11833         }
11834         callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
11835                          | (U8)(flags & MGf_REQUIRE_GV) | MGf_COPY;
11836     }
11837 }
11838
11839 static void
11840 S_entersub_alloc_targ(pTHX_ OP * const o)
11841 {
11842     o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
11843     o->op_private |= OPpENTERSUB_HASTARG;
11844 }
11845
11846 OP *
11847 Perl_ck_subr(pTHX_ OP *o)
11848 {
11849     OP *aop, *cvop;
11850     CV *cv;
11851     GV *namegv;
11852     SV **const_class = NULL;
11853
11854     PERL_ARGS_ASSERT_CK_SUBR;
11855
11856     aop = cUNOPx(o)->op_first;
11857     if (!OpHAS_SIBLING(aop))
11858         aop = cUNOPx(aop)->op_first;
11859     aop = OpSIBLING(aop);
11860     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11861     cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
11862     namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
11863
11864     o->op_private &= ~1;
11865     o->op_private |= (PL_hints & HINT_STRICT_REFS);
11866     if (PERLDB_SUB && PL_curstash != PL_debstash)
11867         o->op_private |= OPpENTERSUB_DB;
11868     switch (cvop->op_type) {
11869         case OP_RV2CV:
11870             o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
11871             op_null(cvop);
11872             break;
11873         case OP_METHOD:
11874         case OP_METHOD_NAMED:
11875         case OP_METHOD_SUPER:
11876         case OP_METHOD_REDIR:
11877         case OP_METHOD_REDIR_SUPER:
11878             if (aop->op_type == OP_CONST) {
11879                 aop->op_private &= ~OPpCONST_STRICT;
11880                 const_class = &cSVOPx(aop)->op_sv;
11881             }
11882             else if (aop->op_type == OP_LIST) {
11883                 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
11884                 if (sib && sib->op_type == OP_CONST) {
11885                     sib->op_private &= ~OPpCONST_STRICT;
11886                     const_class = &cSVOPx(sib)->op_sv;
11887                 }
11888             }
11889             /* make class name a shared cow string to speedup method calls */
11890             /* constant string might be replaced with object, f.e. bigint */
11891             if (const_class && SvPOK(*const_class)) {
11892                 STRLEN len;
11893                 const char* str = SvPV(*const_class, len);
11894                 if (len) {
11895                     SV* const shared = newSVpvn_share(
11896                         str, SvUTF8(*const_class)
11897                                     ? -(SSize_t)len : (SSize_t)len,
11898                         0
11899                     );
11900                     if (SvREADONLY(*const_class))
11901                         SvREADONLY_on(shared);
11902                     SvREFCNT_dec(*const_class);
11903                     *const_class = shared;
11904                 }
11905             }
11906             break;
11907     }
11908
11909     if (!cv) {
11910         S_entersub_alloc_targ(aTHX_ o);
11911         return ck_entersub_args_list(o);
11912     } else {
11913         Perl_call_checker ckfun;
11914         SV *ckobj;
11915         U8 flags;
11916         S_cv_get_call_checker(cv, &ckfun, &ckobj, &flags);
11917         if (CvISXSUB(cv) || !CvROOT(cv))
11918             S_entersub_alloc_targ(aTHX_ o);
11919         if (!namegv) {
11920             /* The original call checker API guarantees that a GV will be
11921                be provided with the right name.  So, if the old API was
11922                used (or the REQUIRE_GV flag was passed), we have to reify
11923                the CV’s GV, unless this is an anonymous sub.  This is not
11924                ideal for lexical subs, as its stringification will include
11925                the package.  But it is the best we can do.  */
11926             if (flags & MGf_REQUIRE_GV) {
11927                 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
11928                     namegv = CvGV(cv);
11929             }
11930             else namegv = MUTABLE_GV(cv);
11931             /* After a syntax error in a lexical sub, the cv that
11932                rv2cv_op_cv returns may be a nameless stub. */
11933             if (!namegv) return ck_entersub_args_list(o);
11934
11935         }
11936         return ckfun(aTHX_ o, namegv, ckobj);
11937     }
11938 }
11939
11940 OP *
11941 Perl_ck_svconst(pTHX_ OP *o)
11942 {
11943     SV * const sv = cSVOPo->op_sv;
11944     PERL_ARGS_ASSERT_CK_SVCONST;
11945     PERL_UNUSED_CONTEXT;
11946 #ifdef PERL_COPY_ON_WRITE
11947     /* Since the read-only flag may be used to protect a string buffer, we
11948        cannot do copy-on-write with existing read-only scalars that are not
11949        already copy-on-write scalars.  To allow $_ = "hello" to do COW with
11950        that constant, mark the constant as COWable here, if it is not
11951        already read-only. */
11952     if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
11953         SvIsCOW_on(sv);
11954         CowREFCNT(sv) = 0;
11955 # ifdef PERL_DEBUG_READONLY_COW
11956         sv_buf_to_ro(sv);
11957 # endif
11958     }
11959 #endif
11960     SvREADONLY_on(sv);
11961     return o;
11962 }
11963
11964 OP *
11965 Perl_ck_trunc(pTHX_ OP *o)
11966 {
11967     PERL_ARGS_ASSERT_CK_TRUNC;
11968
11969     if (o->op_flags & OPf_KIDS) {
11970         SVOP *kid = (SVOP*)cUNOPo->op_first;
11971
11972         if (kid->op_type == OP_NULL)
11973             kid = (SVOP*)OpSIBLING(kid);
11974         if (kid && kid->op_type == OP_CONST &&
11975             (kid->op_private & OPpCONST_BARE) &&
11976             !kid->op_folded)
11977         {
11978             o->op_flags |= OPf_SPECIAL;
11979             kid->op_private &= ~OPpCONST_STRICT;
11980         }
11981     }
11982     return ck_fun(o);
11983 }
11984
11985 OP *
11986 Perl_ck_substr(pTHX_ OP *o)
11987 {
11988     PERL_ARGS_ASSERT_CK_SUBSTR;
11989
11990     o = ck_fun(o);
11991     if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
11992         OP *kid = cLISTOPo->op_first;
11993
11994         if (kid->op_type == OP_NULL)
11995             kid = OpSIBLING(kid);
11996         if (kid)
11997             kid->op_flags |= OPf_MOD;
11998
11999     }
12000     return o;
12001 }
12002
12003 OP *
12004 Perl_ck_tell(pTHX_ OP *o)
12005 {
12006     PERL_ARGS_ASSERT_CK_TELL;
12007     o = ck_fun(o);
12008     if (o->op_flags & OPf_KIDS) {
12009      OP *kid = cLISTOPo->op_first;
12010      if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
12011      if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
12012     }
12013     return o;
12014 }
12015
12016 OP *
12017 Perl_ck_each(pTHX_ OP *o)
12018 {
12019     dVAR;
12020     OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
12021     const unsigned orig_type  = o->op_type;
12022
12023     PERL_ARGS_ASSERT_CK_EACH;
12024
12025     if (kid) {
12026         switch (kid->op_type) {
12027             case OP_PADHV:
12028             case OP_RV2HV:
12029                 break;
12030             case OP_PADAV:
12031             case OP_RV2AV:
12032                 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
12033                             : orig_type == OP_KEYS ? OP_AKEYS
12034                             :                        OP_AVALUES);
12035                 break;
12036             case OP_CONST:
12037                 if (kid->op_private == OPpCONST_BARE
12038                  || !SvROK(cSVOPx_sv(kid))
12039                  || (  SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
12040                     && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV  )
12041                    )
12042                     /* we let ck_fun handle it */
12043                     break;
12044             default:
12045                 Perl_croak_nocontext(
12046                     "Experimental %s on scalar is now forbidden",
12047                     PL_op_desc[orig_type]);
12048                 break;
12049         }
12050     }
12051     return ck_fun(o);
12052 }
12053
12054 OP *
12055 Perl_ck_length(pTHX_ OP *o)
12056 {
12057     PERL_ARGS_ASSERT_CK_LENGTH;
12058
12059     o = ck_fun(o);
12060
12061     if (ckWARN(WARN_SYNTAX)) {
12062         const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
12063
12064         if (kid) {
12065             SV *name = NULL;
12066             const bool hash = kid->op_type == OP_PADHV
12067                            || kid->op_type == OP_RV2HV;
12068             switch (kid->op_type) {
12069                 case OP_PADHV:
12070                 case OP_PADAV:
12071                 case OP_RV2HV:
12072                 case OP_RV2AV:
12073                     name = S_op_varname(aTHX_ kid);
12074                     break;
12075                 default:
12076                     return o;
12077             }
12078             if (name)
12079                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12080                     "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
12081                     ")\"?)",
12082                     SVfARG(name), hash ? "keys " : "", SVfARG(name)
12083                 );
12084             else if (hash)
12085      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
12086                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12087                     "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
12088             else
12089      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
12090                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12091                     "length() used on @array (did you mean \"scalar(@array)\"?)");
12092         }
12093     }
12094
12095     return o;
12096 }
12097
12098 /* Check for in place reverse and sort assignments like "@a = reverse @a"
12099    and modify the optree to make them work inplace */
12100
12101 STATIC void
12102 S_inplace_aassign(pTHX_ OP *o) {
12103
12104     OP *modop, *modop_pushmark;
12105     OP *oright;
12106     OP *oleft, *oleft_pushmark;
12107
12108     PERL_ARGS_ASSERT_INPLACE_AASSIGN;
12109
12110     assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
12111
12112     assert(cUNOPo->op_first->op_type == OP_NULL);
12113     modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
12114     assert(modop_pushmark->op_type == OP_PUSHMARK);
12115     modop = OpSIBLING(modop_pushmark);
12116
12117     if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
12118         return;
12119
12120     /* no other operation except sort/reverse */
12121     if (OpHAS_SIBLING(modop))
12122         return;
12123
12124     assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
12125     if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
12126
12127     if (modop->op_flags & OPf_STACKED) {
12128         /* skip sort subroutine/block */
12129         assert(oright->op_type == OP_NULL);
12130         oright = OpSIBLING(oright);
12131     }
12132
12133     assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
12134     oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
12135     assert(oleft_pushmark->op_type == OP_PUSHMARK);
12136     oleft = OpSIBLING(oleft_pushmark);
12137
12138     /* Check the lhs is an array */
12139     if (!oleft ||
12140         (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
12141         || OpHAS_SIBLING(oleft)
12142         || (oleft->op_private & OPpLVAL_INTRO)
12143     )
12144         return;
12145
12146     /* Only one thing on the rhs */
12147     if (OpHAS_SIBLING(oright))
12148         return;
12149
12150     /* check the array is the same on both sides */
12151     if (oleft->op_type == OP_RV2AV) {
12152         if (oright->op_type != OP_RV2AV
12153             || !cUNOPx(oright)->op_first
12154             || cUNOPx(oright)->op_first->op_type != OP_GV
12155             || cUNOPx(oleft )->op_first->op_type != OP_GV
12156             || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
12157                cGVOPx_gv(cUNOPx(oright)->op_first)
12158         )
12159             return;
12160     }
12161     else if (oright->op_type != OP_PADAV
12162         || oright->op_targ != oleft->op_targ
12163     )
12164         return;
12165
12166     /* This actually is an inplace assignment */
12167
12168     modop->op_private |= OPpSORT_INPLACE;
12169
12170     /* transfer MODishness etc from LHS arg to RHS arg */
12171     oright->op_flags = oleft->op_flags;
12172
12173     /* remove the aassign op and the lhs */
12174     op_null(o);
12175     op_null(oleft_pushmark);
12176     if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
12177         op_null(cUNOPx(oleft)->op_first);
12178     op_null(oleft);
12179 }
12180
12181
12182
12183 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
12184  * that potentially represent a series of one or more aggregate derefs
12185  * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
12186  * the whole chain to a single OP_MULTIDEREF op (maybe with a few
12187  * additional ops left in too).
12188  *
12189  * The caller will have already verified that the first few ops in the
12190  * chain following 'start' indicate a multideref candidate, and will have
12191  * set 'orig_o' to the point further on in the chain where the first index
12192  * expression (if any) begins.  'orig_action' specifies what type of
12193  * beginning has already been determined by the ops between start..orig_o
12194  * (e.g.  $lex_ary[], $pkg_ary->{}, expr->[], etc).
12195  *
12196  * 'hints' contains any hints flags that need adding (currently just
12197  * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
12198  */
12199
12200 void
12201 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
12202 {
12203     dVAR;
12204     int pass;
12205     UNOP_AUX_item *arg_buf = NULL;
12206     bool reset_start_targ  = FALSE; /* start->op_targ needs zeroing */
12207     int index_skip         = -1;    /* don't output index arg on this action */
12208
12209     /* similar to regex compiling, do two passes; the first pass
12210      * determines whether the op chain is convertible and calculates the
12211      * buffer size; the second pass populates the buffer and makes any
12212      * changes necessary to ops (such as moving consts to the pad on
12213      * threaded builds).
12214      *
12215      * NB: for things like Coverity, note that both passes take the same
12216      * path through the logic tree (except for 'if (pass)' bits), since
12217      * both passes are following the same op_next chain; and in
12218      * particular, if it would return early on the second pass, it would
12219      * already have returned early on the first pass.
12220      */
12221     for (pass = 0; pass < 2; pass++) {
12222         OP *o                = orig_o;
12223         UV action            = orig_action;
12224         OP *first_elem_op    = NULL;  /* first seen aelem/helem */
12225         OP *top_op           = NULL;  /* highest [ah]elem/exists/del/rv2[ah]v */
12226         int action_count     = 0;     /* number of actions seen so far */
12227         int action_ix        = 0;     /* action_count % (actions per IV) */
12228         bool next_is_hash    = FALSE; /* is the next lookup to be a hash? */
12229         bool is_last         = FALSE; /* no more derefs to follow */
12230         bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
12231         UNOP_AUX_item *arg     = arg_buf;
12232         UNOP_AUX_item *action_ptr = arg_buf;
12233
12234         if (pass)
12235             action_ptr->uv = 0;
12236         arg++;
12237
12238         switch (action) {
12239         case MDEREF_HV_gvsv_vivify_rv2hv_helem:
12240         case MDEREF_HV_gvhv_helem:
12241             next_is_hash = TRUE;
12242             /* FALLTHROUGH */
12243         case MDEREF_AV_gvsv_vivify_rv2av_aelem:
12244         case MDEREF_AV_gvav_aelem:
12245             if (pass) {
12246 #ifdef USE_ITHREADS
12247                 arg->pad_offset = cPADOPx(start)->op_padix;
12248                 /* stop it being swiped when nulled */
12249                 cPADOPx(start)->op_padix = 0;
12250 #else
12251                 arg->sv = cSVOPx(start)->op_sv;
12252                 cSVOPx(start)->op_sv = NULL;
12253 #endif
12254             }
12255             arg++;
12256             break;
12257
12258         case MDEREF_HV_padhv_helem:
12259         case MDEREF_HV_padsv_vivify_rv2hv_helem:
12260             next_is_hash = TRUE;
12261             /* FALLTHROUGH */
12262         case MDEREF_AV_padav_aelem:
12263         case MDEREF_AV_padsv_vivify_rv2av_aelem:
12264             if (pass) {
12265                 arg->pad_offset = start->op_targ;
12266                 /* we skip setting op_targ = 0 for now, since the intact
12267                  * OP_PADXV is needed by S_check_hash_fields_and_hekify */
12268                 reset_start_targ = TRUE;
12269             }
12270             arg++;
12271             break;
12272
12273         case MDEREF_HV_pop_rv2hv_helem:
12274             next_is_hash = TRUE;
12275             /* FALLTHROUGH */
12276         case MDEREF_AV_pop_rv2av_aelem:
12277             break;
12278
12279         default:
12280             NOT_REACHED; /* NOTREACHED */
12281             return;
12282         }
12283
12284         while (!is_last) {
12285             /* look for another (rv2av/hv; get index;
12286              * aelem/helem/exists/delele) sequence */
12287
12288             OP *kid;
12289             bool is_deref;
12290             bool ok;
12291             UV index_type = MDEREF_INDEX_none;
12292
12293             if (action_count) {
12294                 /* if this is not the first lookup, consume the rv2av/hv  */
12295
12296                 /* for N levels of aggregate lookup, we normally expect
12297                  * that the first N-1 [ah]elem ops will be flagged as
12298                  * /DEREF (so they autovivifiy if necessary), and the last
12299                  * lookup op not to be.
12300                  * For other things (like @{$h{k1}{k2}}) extra scope or
12301                  * leave ops can appear, so abandon the effort in that
12302                  * case */
12303                 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
12304                     return;
12305
12306                 /* rv2av or rv2hv sKR/1 */
12307
12308                 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12309                                             |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12310                 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
12311                     return;
12312
12313                 /* at this point, we wouldn't expect any of these
12314                  * possible private flags:
12315                  * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
12316                  * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
12317                  */
12318                 ASSUME(!(o->op_private &
12319                     ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
12320
12321                 hints = (o->op_private & OPpHINT_STRICT_REFS);
12322
12323                 /* make sure the type of the previous /DEREF matches the
12324                  * type of the next lookup */
12325                 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
12326                 top_op = o;
12327
12328                 action = next_is_hash
12329                             ? MDEREF_HV_vivify_rv2hv_helem
12330                             : MDEREF_AV_vivify_rv2av_aelem;
12331                 o = o->op_next;
12332             }
12333
12334             /* if this is the second pass, and we're at the depth where
12335              * previously we encountered a non-simple index expression,
12336              * stop processing the index at this point */
12337             if (action_count != index_skip) {
12338
12339                 /* look for one or more simple ops that return an array
12340                  * index or hash key */
12341
12342                 switch (o->op_type) {
12343                 case OP_PADSV:
12344                     /* it may be a lexical var index */
12345                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
12346                                             |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12347                     ASSUME(!(o->op_private &
12348                             ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
12349
12350                     if (   OP_GIMME(o,0) == G_SCALAR
12351                         && !(o->op_flags & (OPf_REF|OPf_MOD))
12352                         && o->op_private == 0)
12353                     {
12354                         if (pass)
12355                             arg->pad_offset = o->op_targ;
12356                         arg++;
12357                         index_type = MDEREF_INDEX_padsv;
12358                         o = o->op_next;
12359                     }
12360                     break;
12361
12362                 case OP_CONST:
12363                     if (next_is_hash) {
12364                         /* it's a constant hash index */
12365                         if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
12366                             /* "use constant foo => FOO; $h{+foo}" for
12367                              * some weird FOO, can leave you with constants
12368                              * that aren't simple strings. It's not worth
12369                              * the extra hassle for those edge cases */
12370                             break;
12371
12372                         if (pass) {
12373                             UNOP *rop = NULL;
12374                             OP * helem_op = o->op_next;
12375
12376                             ASSUME(   helem_op->op_type == OP_HELEM
12377                                    || helem_op->op_type == OP_NULL);
12378                             if (helem_op->op_type == OP_HELEM) {
12379                                 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
12380                                 if (   helem_op->op_private & OPpLVAL_INTRO
12381                                     || rop->op_type != OP_RV2HV
12382                                 )
12383                                     rop = NULL;
12384                             }
12385                             S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo);
12386
12387 #ifdef USE_ITHREADS
12388                             /* Relocate sv to the pad for thread safety */
12389                             op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
12390                             arg->pad_offset = o->op_targ;
12391                             o->op_targ = 0;
12392 #else
12393                             arg->sv = cSVOPx_sv(o);
12394 #endif
12395                         }
12396                     }
12397                     else {
12398                         /* it's a constant array index */
12399                         IV iv;
12400                         SV *ix_sv = cSVOPo->op_sv;
12401                         if (!SvIOK(ix_sv))
12402                             break;
12403                         iv = SvIV(ix_sv);
12404
12405                         if (   action_count == 0
12406                             && iv >= -128
12407                             && iv <= 127
12408                             && (   action == MDEREF_AV_padav_aelem
12409                                 || action == MDEREF_AV_gvav_aelem)
12410                         )
12411                             maybe_aelemfast = TRUE;
12412
12413                         if (pass) {
12414                             arg->iv = iv;
12415                             SvREFCNT_dec_NN(cSVOPo->op_sv);
12416                         }
12417                     }
12418                     if (pass)
12419                         /* we've taken ownership of the SV */
12420                         cSVOPo->op_sv = NULL;
12421                     arg++;
12422                     index_type = MDEREF_INDEX_const;
12423                     o = o->op_next;
12424                     break;
12425
12426                 case OP_GV:
12427                     /* it may be a package var index */
12428
12429                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_SPECIAL)));
12430                     ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
12431                     if (  (o->op_flags &~ OPf_SPECIAL) != OPf_WANT_SCALAR
12432                         || o->op_private != 0
12433                     )
12434                         break;
12435
12436                     kid = o->op_next;
12437                     if (kid->op_type != OP_RV2SV)
12438                         break;
12439
12440                     ASSUME(!(kid->op_flags &
12441                             ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
12442                              |OPf_SPECIAL|OPf_PARENS)));
12443                     ASSUME(!(kid->op_private &
12444                                     ~(OPpARG1_MASK
12445                                      |OPpHINT_STRICT_REFS|OPpOUR_INTRO
12446                                      |OPpDEREF|OPpLVAL_INTRO)));
12447                     if(   (kid->op_flags &~ OPf_PARENS)
12448                             != (OPf_WANT_SCALAR|OPf_KIDS)
12449                        || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
12450                     )
12451                         break;
12452
12453                     if (pass) {
12454 #ifdef USE_ITHREADS
12455                         arg->pad_offset = cPADOPx(o)->op_padix;
12456                         /* stop it being swiped when nulled */
12457                         cPADOPx(o)->op_padix = 0;
12458 #else
12459                         arg->sv = cSVOPx(o)->op_sv;
12460                         cSVOPo->op_sv = NULL;
12461 #endif
12462                     }
12463                     arg++;
12464                     index_type = MDEREF_INDEX_gvsv;
12465                     o = kid->op_next;
12466                     break;
12467
12468                 } /* switch */
12469             } /* action_count != index_skip */
12470
12471             action |= index_type;
12472
12473
12474             /* at this point we have either:
12475              *   * detected what looks like a simple index expression,
12476              *     and expect the next op to be an [ah]elem, or
12477              *     an nulled  [ah]elem followed by a delete or exists;
12478              *  * found a more complex expression, so something other
12479              *    than the above follows.
12480              */
12481
12482             /* possibly an optimised away [ah]elem (where op_next is
12483              * exists or delete) */
12484             if (o->op_type == OP_NULL)
12485                 o = o->op_next;
12486
12487             /* at this point we're looking for an OP_AELEM, OP_HELEM,
12488              * OP_EXISTS or OP_DELETE */
12489
12490             /* if something like arybase (a.k.a $[ ) is in scope,
12491              * abandon optimisation attempt */
12492             if (  (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
12493                && PL_check[o->op_type] != Perl_ck_null)
12494                 return;
12495
12496             if (   o->op_type != OP_AELEM
12497                 || (o->op_private &
12498                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
12499                 )
12500                 maybe_aelemfast = FALSE;
12501
12502             /* look for aelem/helem/exists/delete. If it's not the last elem
12503              * lookup, it *must* have OPpDEREF_AV/HV, but not many other
12504              * flags; if it's the last, then it mustn't have
12505              * OPpDEREF_AV/HV, but may have lots of other flags, like
12506              * OPpLVAL_INTRO etc
12507              */
12508
12509             if (   index_type == MDEREF_INDEX_none
12510                 || (   o->op_type != OP_AELEM  && o->op_type != OP_HELEM
12511                     && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
12512             )
12513                 ok = FALSE;
12514             else {
12515                 /* we have aelem/helem/exists/delete with valid simple index */
12516
12517                 is_deref =    (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
12518                            && (   (o->op_private & OPpDEREF) == OPpDEREF_AV
12519                                || (o->op_private & OPpDEREF) == OPpDEREF_HV);
12520
12521                 if (is_deref) {
12522                     ASSUME(!(o->op_flags &
12523                                  ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
12524                     ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
12525
12526                     ok =    (o->op_flags &~ OPf_PARENS)
12527                                == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
12528                          && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
12529                 }
12530                 else if (o->op_type == OP_EXISTS) {
12531                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12532                                 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12533                     ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
12534                     ok =  !(o->op_private & ~OPpARG1_MASK);
12535                 }
12536                 else if (o->op_type == OP_DELETE) {
12537                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12538                                 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12539                     ASSUME(!(o->op_private &
12540                                     ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
12541                     /* don't handle slices or 'local delete'; the latter
12542                      * is fairly rare, and has a complex runtime */
12543                     ok =  !(o->op_private & ~OPpARG1_MASK);
12544                     if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
12545                         /* skip handling run-tome error */
12546                         ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
12547                 }
12548                 else {
12549                     ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
12550                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
12551                                             |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
12552                     ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
12553                                     |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
12554                     ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
12555                 }
12556             }
12557
12558             if (ok) {
12559                 if (!first_elem_op)
12560                     first_elem_op = o;
12561                 top_op = o;
12562                 if (is_deref) {
12563                     next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
12564                     o = o->op_next;
12565                 }
12566                 else {
12567                     is_last = TRUE;
12568                     action |= MDEREF_FLAG_last;
12569                 }
12570             }
12571             else {
12572                 /* at this point we have something that started
12573                  * promisingly enough (with rv2av or whatever), but failed
12574                  * to find a simple index followed by an
12575                  * aelem/helem/exists/delete. If this is the first action,
12576                  * give up; but if we've already seen at least one
12577                  * aelem/helem, then keep them and add a new action with
12578                  * MDEREF_INDEX_none, which causes it to do the vivify
12579                  * from the end of the previous lookup, and do the deref,
12580                  * but stop at that point. So $a[0][expr] will do one
12581                  * av_fetch, vivify and deref, then continue executing at
12582                  * expr */
12583                 if (!action_count)
12584                     return;
12585                 is_last = TRUE;
12586                 index_skip = action_count;
12587                 action |= MDEREF_FLAG_last;
12588             }
12589
12590             if (pass)
12591                 action_ptr->uv |= (action << (action_ix * MDEREF_SHIFT));
12592             action_ix++;
12593             action_count++;
12594             /* if there's no space for the next action, create a new slot
12595              * for it *before* we start adding args for that action */
12596             if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
12597                 action_ptr = arg;
12598                 if (pass)
12599                     arg->uv = 0;
12600                 arg++;
12601                 action_ix = 0;
12602             }
12603         } /* while !is_last */
12604
12605         /* success! */
12606
12607         if (pass) {
12608             OP *mderef;
12609             OP *p, *q;
12610
12611             mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
12612             if (index_skip == -1) {
12613                 mderef->op_flags = o->op_flags
12614                         & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
12615                 if (o->op_type == OP_EXISTS)
12616                     mderef->op_private = OPpMULTIDEREF_EXISTS;
12617                 else if (o->op_type == OP_DELETE)
12618                     mderef->op_private = OPpMULTIDEREF_DELETE;
12619                 else
12620                     mderef->op_private = o->op_private
12621                         & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
12622             }
12623             /* accumulate strictness from every level (although I don't think
12624              * they can actually vary) */
12625             mderef->op_private |= hints;
12626
12627             /* integrate the new multideref op into the optree and the
12628              * op_next chain.
12629              *
12630              * In general an op like aelem or helem has two child
12631              * sub-trees: the aggregate expression (a_expr) and the
12632              * index expression (i_expr):
12633              *
12634              *     aelem
12635              *       |
12636              *     a_expr - i_expr
12637              *
12638              * The a_expr returns an AV or HV, while the i-expr returns an
12639              * index. In general a multideref replaces most or all of a
12640              * multi-level tree, e.g.
12641              *
12642              *     exists
12643              *       |
12644              *     ex-aelem
12645              *       |
12646              *     rv2av  - i_expr1
12647              *       |
12648              *     helem
12649              *       |
12650              *     rv2hv  - i_expr2
12651              *       |
12652              *     aelem
12653              *       |
12654              *     a_expr - i_expr3
12655              *
12656              * With multideref, all the i_exprs will be simple vars or
12657              * constants, except that i_expr1 may be arbitrary in the case
12658              * of MDEREF_INDEX_none.
12659              *
12660              * The bottom-most a_expr will be either:
12661              *   1) a simple var (so padXv or gv+rv2Xv);
12662              *   2) a simple scalar var dereferenced (e.g. $r->[0]):
12663              *      so a simple var with an extra rv2Xv;
12664              *   3) or an arbitrary expression.
12665              *
12666              * 'start', the first op in the execution chain, will point to
12667              *   1),2): the padXv or gv op;
12668              *   3):    the rv2Xv which forms the last op in the a_expr
12669              *          execution chain, and the top-most op in the a_expr
12670              *          subtree.
12671              *
12672              * For all cases, the 'start' node is no longer required,
12673              * but we can't free it since one or more external nodes
12674              * may point to it. E.g. consider
12675              *     $h{foo} = $a ? $b : $c
12676              * Here, both the op_next and op_other branches of the
12677              * cond_expr point to the gv[*h] of the hash expression, so
12678              * we can't free the 'start' op.
12679              *
12680              * For expr->[...], we need to save the subtree containing the
12681              * expression; for the other cases, we just need to save the
12682              * start node.
12683              * So in all cases, we null the start op and keep it around by
12684              * making it the child of the multideref op; for the expr->
12685              * case, the expr will be a subtree of the start node.
12686              *
12687              * So in the simple 1,2 case the  optree above changes to
12688              *
12689              *     ex-exists
12690              *       |
12691              *     multideref
12692              *       |
12693              *     ex-gv (or ex-padxv)
12694              *
12695              *  with the op_next chain being
12696              *
12697              *  -> ex-gv -> multideref -> op-following-ex-exists ->
12698              *
12699              *  In the 3 case, we have
12700              *
12701              *     ex-exists
12702              *       |
12703              *     multideref
12704              *       |
12705              *     ex-rv2xv
12706              *       |
12707              *    rest-of-a_expr
12708              *      subtree
12709              *
12710              *  and
12711              *
12712              *  -> rest-of-a_expr subtree ->
12713              *    ex-rv2xv -> multideref -> op-following-ex-exists ->
12714              *
12715              *
12716              * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
12717              * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
12718              * multideref attached as the child, e.g.
12719              *
12720              *     exists
12721              *       |
12722              *     ex-aelem
12723              *       |
12724              *     ex-rv2av  - i_expr1
12725              *       |
12726              *     multideref
12727              *       |
12728              *     ex-whatever
12729              *
12730              */
12731
12732             /* if we free this op, don't free the pad entry */
12733             if (reset_start_targ)
12734                 start->op_targ = 0;
12735
12736
12737             /* Cut the bit we need to save out of the tree and attach to
12738              * the multideref op, then free the rest of the tree */
12739
12740             /* find parent of node to be detached (for use by splice) */
12741             p = first_elem_op;
12742             if (   orig_action == MDEREF_AV_pop_rv2av_aelem
12743                 || orig_action == MDEREF_HV_pop_rv2hv_helem)
12744             {
12745                 /* there is an arbitrary expression preceding us, e.g.
12746                  * expr->[..]? so we need to save the 'expr' subtree */
12747                 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
12748                     p = cUNOPx(p)->op_first;
12749                 ASSUME(   start->op_type == OP_RV2AV
12750                        || start->op_type == OP_RV2HV);
12751             }
12752             else {
12753                 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
12754                  * above for exists/delete. */
12755                 while (   (p->op_flags & OPf_KIDS)
12756                        && cUNOPx(p)->op_first != start
12757                 )
12758                     p = cUNOPx(p)->op_first;
12759             }
12760             ASSUME(cUNOPx(p)->op_first == start);
12761
12762             /* detach from main tree, and re-attach under the multideref */
12763             op_sibling_splice(mderef, NULL, 0,
12764                     op_sibling_splice(p, NULL, 1, NULL));
12765             op_null(start);
12766
12767             start->op_next = mderef;
12768
12769             mderef->op_next = index_skip == -1 ? o->op_next : o;
12770
12771             /* excise and free the original tree, and replace with
12772              * the multideref op */
12773             p = op_sibling_splice(top_op, NULL, -1, mderef);
12774             while (p) {
12775                 q = OpSIBLING(p);
12776                 op_free(p);
12777                 p = q;
12778             }
12779             op_null(top_op);
12780         }
12781         else {
12782             Size_t size = arg - arg_buf;
12783
12784             if (maybe_aelemfast && action_count == 1)
12785                 return;
12786
12787             arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
12788                                 sizeof(UNOP_AUX_item) * (size + 1));
12789             /* for dumping etc: store the length in a hidden first slot;
12790              * we set the op_aux pointer to the second slot */
12791             arg_buf->uv = size;
12792             arg_buf++;
12793         }
12794     } /* for (pass = ...) */
12795 }
12796
12797
12798
12799 /* mechanism for deferring recursion in rpeep() */
12800
12801 #define MAX_DEFERRED 4
12802
12803 #define DEFER(o) \
12804   STMT_START { \
12805     if (defer_ix == (MAX_DEFERRED-1)) { \
12806         OP **defer = defer_queue[defer_base]; \
12807         CALL_RPEEP(*defer); \
12808         S_prune_chain_head(defer); \
12809         defer_base = (defer_base + 1) % MAX_DEFERRED; \
12810         defer_ix--; \
12811     } \
12812     defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
12813   } STMT_END
12814
12815 #define IS_AND_OP(o)   (o->op_type == OP_AND)
12816 #define IS_OR_OP(o)    (o->op_type == OP_OR)
12817
12818
12819 /* A peephole optimizer.  We visit the ops in the order they're to execute.
12820  * See the comments at the top of this file for more details about when
12821  * peep() is called */
12822
12823 void
12824 Perl_rpeep(pTHX_ OP *o)
12825 {
12826     dVAR;
12827     OP* oldop = NULL;
12828     OP* oldoldop = NULL;
12829     OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
12830     int defer_base = 0;
12831     int defer_ix = -1;
12832     OP *fop;
12833     OP *sop;
12834
12835     if (!o || o->op_opt)
12836         return;
12837     ENTER;
12838     SAVEOP();
12839     SAVEVPTR(PL_curcop);
12840     for (;; o = o->op_next) {
12841         if (o && o->op_opt)
12842             o = NULL;
12843         if (!o) {
12844             while (defer_ix >= 0) {
12845                 OP **defer =
12846                         defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
12847                 CALL_RPEEP(*defer);
12848                 S_prune_chain_head(defer);
12849             }
12850             break;
12851         }
12852
12853       redo:
12854         /* By default, this op has now been optimised. A couple of cases below
12855            clear this again.  */
12856         o->op_opt = 1;
12857         PL_op = o;
12858
12859         /* look for a series of 1 or more aggregate derefs, e.g.
12860          *   $a[1]{foo}[$i]{$k}
12861          * and replace with a single OP_MULTIDEREF op.
12862          * Each index must be either a const, or a simple variable,
12863          *
12864          * First, look for likely combinations of starting ops,
12865          * corresponding to (global and lexical variants of)
12866          *     $a[...]   $h{...}
12867          *     $r->[...] $r->{...}
12868          *     (preceding expression)->[...]
12869          *     (preceding expression)->{...}
12870          * and if so, call maybe_multideref() to do a full inspection
12871          * of the op chain and if appropriate, replace with an
12872          * OP_MULTIDEREF
12873          */
12874         {
12875             UV action;
12876             OP *o2 = o;
12877             U8 hints = 0;
12878
12879             switch (o2->op_type) {
12880             case OP_GV:
12881                 /* $pkg[..]   :   gv[*pkg]
12882                  * $pkg->[...]:   gv[*pkg]; rv2sv sKM/DREFAV */
12883
12884                 /* Fail if there are new op flag combinations that we're
12885                  * not aware of, rather than:
12886                  *  * silently failing to optimise, or
12887                  *  * silently optimising the flag away.
12888                  * If this ASSUME starts failing, examine what new flag
12889                  * has been added to the op, and decide whether the
12890                  * optimisation should still occur with that flag, then
12891                  * update the code accordingly. This applies to all the
12892                  * other ASSUMEs in the block of code too.
12893                  */
12894                 ASSUME(!(o2->op_flags &
12895                             ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
12896                 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
12897
12898                 o2 = o2->op_next;
12899
12900                 if (o2->op_type == OP_RV2AV) {
12901                     action = MDEREF_AV_gvav_aelem;
12902                     goto do_deref;
12903                 }
12904
12905                 if (o2->op_type == OP_RV2HV) {
12906                     action = MDEREF_HV_gvhv_helem;
12907                     goto do_deref;
12908                 }
12909
12910                 if (o2->op_type != OP_RV2SV)
12911                     break;
12912
12913                 /* at this point we've seen gv,rv2sv, so the only valid
12914                  * construct left is $pkg->[] or $pkg->{} */
12915
12916                 ASSUME(!(o2->op_flags & OPf_STACKED));
12917                 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
12918                             != (OPf_WANT_SCALAR|OPf_MOD))
12919                     break;
12920
12921                 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
12922                                     |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
12923                 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
12924                     break;
12925                 if (   (o2->op_private & OPpDEREF) != OPpDEREF_AV
12926                     && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
12927                     break;
12928
12929                 o2 = o2->op_next;
12930                 if (o2->op_type == OP_RV2AV) {
12931                     action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
12932                     goto do_deref;
12933                 }
12934                 if (o2->op_type == OP_RV2HV) {
12935                     action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
12936                     goto do_deref;
12937                 }
12938                 break;
12939
12940             case OP_PADSV:
12941                 /* $lex->[...]: padsv[$lex] sM/DREFAV */
12942
12943                 ASSUME(!(o2->op_flags &
12944                     ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
12945                 if ((o2->op_flags &
12946                         (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
12947                      != (OPf_WANT_SCALAR|OPf_MOD))
12948                     break;
12949
12950                 ASSUME(!(o2->op_private &
12951                                 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
12952                 /* skip if state or intro, or not a deref */
12953                 if (      o2->op_private != OPpDEREF_AV
12954                        && o2->op_private != OPpDEREF_HV)
12955                     break;
12956
12957                 o2 = o2->op_next;
12958                 if (o2->op_type == OP_RV2AV) {
12959                     action = MDEREF_AV_padsv_vivify_rv2av_aelem;
12960                     goto do_deref;
12961                 }
12962                 if (o2->op_type == OP_RV2HV) {
12963                     action = MDEREF_HV_padsv_vivify_rv2hv_helem;
12964                     goto do_deref;
12965                 }
12966                 break;
12967
12968             case OP_PADAV:
12969             case OP_PADHV:
12970                 /*    $lex[..]:  padav[@lex:1,2] sR *
12971                  * or $lex{..}:  padhv[%lex:1,2] sR */
12972                 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
12973                                             OPf_REF|OPf_SPECIAL)));
12974                 if ((o2->op_flags &
12975                         (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
12976                      != (OPf_WANT_SCALAR|OPf_REF))
12977                     break;
12978                 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
12979                     break;
12980                 /* OPf_PARENS isn't currently used in this case;
12981                  * if that changes, let us know! */
12982                 ASSUME(!(o2->op_flags & OPf_PARENS));
12983
12984                 /* at this point, we wouldn't expect any of the remaining
12985                  * possible private flags:
12986                  * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
12987                  * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
12988                  *
12989                  * OPpSLICEWARNING shouldn't affect runtime
12990                  */
12991                 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
12992
12993                 action = o2->op_type == OP_PADAV
12994                             ? MDEREF_AV_padav_aelem
12995                             : MDEREF_HV_padhv_helem;
12996                 o2 = o2->op_next;
12997                 S_maybe_multideref(aTHX_ o, o2, action, 0);
12998                 break;
12999
13000
13001             case OP_RV2AV:
13002             case OP_RV2HV:
13003                 action = o2->op_type == OP_RV2AV
13004                             ? MDEREF_AV_pop_rv2av_aelem
13005                             : MDEREF_HV_pop_rv2hv_helem;
13006                 /* FALLTHROUGH */
13007             do_deref:
13008                 /* (expr)->[...]:  rv2av sKR/1;
13009                  * (expr)->{...}:  rv2hv sKR/1; */
13010
13011                 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
13012
13013                 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
13014                                 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
13015                 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
13016                     break;
13017
13018                 /* at this point, we wouldn't expect any of these
13019                  * possible private flags:
13020                  * OPpMAYBE_LVSUB, OPpLVAL_INTRO
13021                  * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
13022                  */
13023                 ASSUME(!(o2->op_private &
13024                     ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
13025                      |OPpOUR_INTRO)));
13026                 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
13027
13028                 o2 = o2->op_next;
13029
13030                 S_maybe_multideref(aTHX_ o, o2, action, hints);
13031                 break;
13032
13033             default:
13034                 break;
13035             }
13036         }
13037
13038
13039         switch (o->op_type) {
13040         case OP_DBSTATE:
13041             PL_curcop = ((COP*)o);              /* for warnings */
13042             break;
13043         case OP_NEXTSTATE:
13044             PL_curcop = ((COP*)o);              /* for warnings */
13045
13046             /* Optimise a "return ..." at the end of a sub to just be "...".
13047              * This saves 2 ops. Before:
13048              * 1  <;> nextstate(main 1 -e:1) v ->2
13049              * 4  <@> return K ->5
13050              * 2    <0> pushmark s ->3
13051              * -    <1> ex-rv2sv sK/1 ->4
13052              * 3      <#> gvsv[*cat] s ->4
13053              *
13054              * After:
13055              * -  <@> return K ->-
13056              * -    <0> pushmark s ->2
13057              * -    <1> ex-rv2sv sK/1 ->-
13058              * 2      <$> gvsv(*cat) s ->3
13059              */
13060             {
13061                 OP *next = o->op_next;
13062                 OP *sibling = OpSIBLING(o);
13063                 if (   OP_TYPE_IS(next, OP_PUSHMARK)
13064                     && OP_TYPE_IS(sibling, OP_RETURN)
13065                     && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
13066                     && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
13067                        ||OP_TYPE_IS(sibling->op_next->op_next,
13068                                     OP_LEAVESUBLV))
13069                     && cUNOPx(sibling)->op_first == next
13070                     && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
13071                     && next->op_next
13072                 ) {
13073                     /* Look through the PUSHMARK's siblings for one that
13074                      * points to the RETURN */
13075                     OP *top = OpSIBLING(next);
13076                     while (top && top->op_next) {
13077                         if (top->op_next == sibling) {
13078                             top->op_next = sibling->op_next;
13079                             o->op_next = next->op_next;
13080                             break;
13081                         }
13082                         top = OpSIBLING(top);
13083                     }
13084                 }
13085             }
13086
13087             /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
13088              *
13089              * This latter form is then suitable for conversion into padrange
13090              * later on. Convert:
13091              *
13092              *   nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
13093              *
13094              * into:
13095              *
13096              *   nextstate1 ->     listop     -> nextstate3
13097              *                 /            \
13098              *         pushmark -> padop1 -> padop2
13099              */
13100             if (o->op_next && (
13101                     o->op_next->op_type == OP_PADSV
13102                  || o->op_next->op_type == OP_PADAV
13103                  || o->op_next->op_type == OP_PADHV
13104                 )
13105                 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
13106                 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
13107                 && o->op_next->op_next->op_next && (
13108                     o->op_next->op_next->op_next->op_type == OP_PADSV
13109                  || o->op_next->op_next->op_next->op_type == OP_PADAV
13110                  || o->op_next->op_next->op_next->op_type == OP_PADHV
13111                 )
13112                 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
13113                 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
13114                 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
13115                 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
13116             ) {
13117                 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
13118
13119                 pad1 =    o->op_next;
13120                 ns2  = pad1->op_next;
13121                 pad2 =  ns2->op_next;
13122                 ns3  = pad2->op_next;
13123
13124                 /* we assume here that the op_next chain is the same as
13125                  * the op_sibling chain */
13126                 assert(OpSIBLING(o)    == pad1);
13127                 assert(OpSIBLING(pad1) == ns2);
13128                 assert(OpSIBLING(ns2)  == pad2);
13129                 assert(OpSIBLING(pad2) == ns3);
13130
13131                 /* excise and delete ns2 */
13132                 op_sibling_splice(NULL, pad1, 1, NULL);
13133                 op_free(ns2);
13134
13135                 /* excise pad1 and pad2 */
13136                 op_sibling_splice(NULL, o, 2, NULL);
13137
13138                 /* create new listop, with children consisting of:
13139                  * a new pushmark, pad1, pad2. */
13140                 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
13141                 newop->op_flags |= OPf_PARENS;
13142                 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
13143
13144                 /* insert newop between o and ns3 */
13145                 op_sibling_splice(NULL, o, 0, newop);
13146
13147                 /*fixup op_next chain */
13148                 newpm = cUNOPx(newop)->op_first; /* pushmark */
13149                 o    ->op_next = newpm;
13150                 newpm->op_next = pad1;
13151                 pad1 ->op_next = pad2;
13152                 pad2 ->op_next = newop; /* listop */
13153                 newop->op_next = ns3;
13154
13155                 /* Ensure pushmark has this flag if padops do */
13156                 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
13157                     newpm->op_flags |= OPf_MOD;
13158                 }
13159
13160                 break;
13161             }
13162
13163             /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
13164                to carry two labels. For now, take the easier option, and skip
13165                this optimisation if the first NEXTSTATE has a label.  */
13166             if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
13167                 OP *nextop = o->op_next;
13168                 while (nextop && nextop->op_type == OP_NULL)
13169                     nextop = nextop->op_next;
13170
13171                 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
13172                     op_null(o);
13173                     if (oldop)
13174                         oldop->op_next = nextop;
13175                     /* Skip (old)oldop assignment since the current oldop's
13176                        op_next already points to the next op.  */
13177                     continue;
13178                 }
13179             }
13180             break;
13181
13182         case OP_CONCAT:
13183             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
13184                 if (o->op_next->op_private & OPpTARGET_MY) {
13185                     if (o->op_flags & OPf_STACKED) /* chained concats */
13186                         break; /* ignore_optimization */
13187                     else {
13188                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
13189                         o->op_targ = o->op_next->op_targ;
13190                         o->op_next->op_targ = 0;
13191                         o->op_private |= OPpTARGET_MY;
13192                     }
13193                 }
13194                 op_null(o->op_next);
13195             }
13196             break;
13197         case OP_STUB:
13198             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
13199                 break; /* Scalar stub must produce undef.  List stub is noop */
13200             }
13201             goto nothin;
13202         case OP_NULL:
13203             if (o->op_targ == OP_NEXTSTATE
13204                 || o->op_targ == OP_DBSTATE)
13205             {
13206                 PL_curcop = ((COP*)o);
13207             }
13208             /* XXX: We avoid setting op_seq here to prevent later calls
13209                to rpeep() from mistakenly concluding that optimisation
13210                has already occurred. This doesn't fix the real problem,
13211                though (See 20010220.007). AMS 20010719 */
13212             /* op_seq functionality is now replaced by op_opt */
13213             o->op_opt = 0;
13214             /* FALLTHROUGH */
13215         case OP_SCALAR:
13216         case OP_LINESEQ:
13217         case OP_SCOPE:
13218         nothin:
13219             if (oldop) {
13220                 oldop->op_next = o->op_next;
13221                 o->op_opt = 0;
13222                 continue;
13223             }
13224             break;
13225
13226         case OP_PUSHMARK:
13227
13228             /* Given
13229                  5 repeat/DOLIST
13230                  3   ex-list
13231                  1     pushmark
13232                  2     scalar or const
13233                  4   const[0]
13234                convert repeat into a stub with no kids.
13235              */
13236             if (o->op_next->op_type == OP_CONST
13237              || (  o->op_next->op_type == OP_PADSV
13238                 && !(o->op_next->op_private & OPpLVAL_INTRO))
13239              || (  o->op_next->op_type == OP_GV
13240                 && o->op_next->op_next->op_type == OP_RV2SV
13241                 && !(o->op_next->op_next->op_private
13242                         & (OPpLVAL_INTRO|OPpOUR_INTRO))))
13243             {
13244                 const OP *kid = o->op_next->op_next;
13245                 if (o->op_next->op_type == OP_GV)
13246                    kid = kid->op_next;
13247                 /* kid is now the ex-list.  */
13248                 if (kid->op_type == OP_NULL
13249                  && (kid = kid->op_next)->op_type == OP_CONST
13250                     /* kid is now the repeat count.  */
13251                  && kid->op_next->op_type == OP_REPEAT
13252                  && kid->op_next->op_private & OPpREPEAT_DOLIST
13253                  && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
13254                  && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0)
13255                 {
13256                     o = kid->op_next; /* repeat */
13257                     assert(oldop);
13258                     oldop->op_next = o;
13259                     op_free(cBINOPo->op_first);
13260                     op_free(cBINOPo->op_last );
13261                     o->op_flags &=~ OPf_KIDS;
13262                     /* stub is a baseop; repeat is a binop */
13263                     STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
13264                     OpTYPE_set(o, OP_STUB);
13265                     o->op_private = 0;
13266                     break;
13267                 }
13268             }
13269
13270             /* Convert a series of PAD ops for my vars plus support into a
13271              * single padrange op. Basically
13272              *
13273              *    pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
13274              *
13275              * becomes, depending on circumstances, one of
13276              *
13277              *    padrange  ----------------------------------> (list) -> rest
13278              *    padrange  --------------------------------------------> rest
13279              *
13280              * where all the pad indexes are sequential and of the same type
13281              * (INTRO or not).
13282              * We convert the pushmark into a padrange op, then skip
13283              * any other pad ops, and possibly some trailing ops.
13284              * Note that we don't null() the skipped ops, to make it
13285              * easier for Deparse to undo this optimisation (and none of
13286              * the skipped ops are holding any resourses). It also makes
13287              * it easier for find_uninit_var(), as it can just ignore
13288              * padrange, and examine the original pad ops.
13289              */
13290         {
13291             OP *p;
13292             OP *followop = NULL; /* the op that will follow the padrange op */
13293             U8 count = 0;
13294             U8 intro = 0;
13295             PADOFFSET base = 0; /* init only to stop compiler whining */
13296             bool gvoid = 0;     /* init only to stop compiler whining */
13297             bool defav = 0;  /* seen (...) = @_ */
13298             bool reuse = 0;  /* reuse an existing padrange op */
13299
13300             /* look for a pushmark -> gv[_] -> rv2av */
13301
13302             {
13303                 OP *rv2av, *q;
13304                 p = o->op_next;
13305                 if (   p->op_type == OP_GV
13306                     && cGVOPx_gv(p) == PL_defgv
13307                     && (rv2av = p->op_next)
13308                     && rv2av->op_type == OP_RV2AV
13309                     && !(rv2av->op_flags & OPf_REF)
13310                     && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
13311                     && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
13312                 ) {
13313                     q = rv2av->op_next;
13314                     if (q->op_type == OP_NULL)
13315                         q = q->op_next;
13316                     if (q->op_type == OP_PUSHMARK) {
13317                         defav = 1;
13318                         p = q;
13319                     }
13320                 }
13321             }
13322             if (!defav) {
13323                 p = o;
13324             }
13325
13326             /* scan for PAD ops */
13327
13328             for (p = p->op_next; p; p = p->op_next) {
13329                 if (p->op_type == OP_NULL)
13330                     continue;
13331
13332                 if ((     p->op_type != OP_PADSV
13333                        && p->op_type != OP_PADAV
13334                        && p->op_type != OP_PADHV
13335                     )
13336                       /* any private flag other than INTRO? e.g. STATE */
13337                    || (p->op_private & ~OPpLVAL_INTRO)
13338                 )
13339                     break;
13340
13341                 /* let $a[N] potentially be optimised into AELEMFAST_LEX
13342                  * instead */
13343                 if (   p->op_type == OP_PADAV
13344                     && p->op_next
13345                     && p->op_next->op_type == OP_CONST
13346                     && p->op_next->op_next
13347                     && p->op_next->op_next->op_type == OP_AELEM
13348                 )
13349                     break;
13350
13351                 /* for 1st padop, note what type it is and the range
13352                  * start; for the others, check that it's the same type
13353                  * and that the targs are contiguous */
13354                 if (count == 0) {
13355                     intro = (p->op_private & OPpLVAL_INTRO);
13356                     base = p->op_targ;
13357                     gvoid = OP_GIMME(p,0) == G_VOID;
13358                 }
13359                 else {
13360                     if ((p->op_private & OPpLVAL_INTRO) != intro)
13361                         break;
13362                     /* Note that you'd normally  expect targs to be
13363                      * contiguous in my($a,$b,$c), but that's not the case
13364                      * when external modules start doing things, e.g.
13365                      i* Function::Parameters */
13366                     if (p->op_targ != base + count)
13367                         break;
13368                     assert(p->op_targ == base + count);
13369                     /* Either all the padops or none of the padops should
13370                        be in void context.  Since we only do the optimisa-
13371                        tion for av/hv when the aggregate itself is pushed
13372                        on to the stack (one item), there is no need to dis-
13373                        tinguish list from scalar context.  */
13374                     if (gvoid != (OP_GIMME(p,0) == G_VOID))
13375                         break;
13376                 }
13377
13378                 /* for AV, HV, only when we're not flattening */
13379                 if (   p->op_type != OP_PADSV
13380                     && !gvoid
13381                     && !(p->op_flags & OPf_REF)
13382                 )
13383                     break;
13384
13385                 if (count >= OPpPADRANGE_COUNTMASK)
13386                     break;
13387
13388                 /* there's a biggest base we can fit into a
13389                  * SAVEt_CLEARPADRANGE in pp_padrange */
13390                 if (intro && base >
13391                         (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)))
13392                     break;
13393
13394                 /* Success! We've got another valid pad op to optimise away */
13395                 count++;
13396                 followop = p->op_next;
13397             }
13398
13399             if (count < 1 || (count == 1 && !defav))
13400                 break;
13401
13402             /* pp_padrange in specifically compile-time void context
13403              * skips pushing a mark and lexicals; in all other contexts
13404              * (including unknown till runtime) it pushes a mark and the
13405              * lexicals. We must be very careful then, that the ops we
13406              * optimise away would have exactly the same effect as the
13407              * padrange.
13408              * In particular in void context, we can only optimise to
13409              * a padrange if see see the complete sequence
13410              *     pushmark, pad*v, ...., list
13411              * which has the net effect of of leaving the markstack as it
13412              * was.  Not pushing on to the stack (whereas padsv does touch
13413              * the stack) makes no difference in void context.
13414              */
13415             assert(followop);
13416             if (gvoid) {
13417                 if (followop->op_type == OP_LIST
13418                         && OP_GIMME(followop,0) == G_VOID
13419                    )
13420                 {
13421                     followop = followop->op_next; /* skip OP_LIST */
13422
13423                     /* consolidate two successive my(...);'s */
13424
13425                     if (   oldoldop
13426                         && oldoldop->op_type == OP_PADRANGE
13427                         && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
13428                         && (oldoldop->op_private & OPpLVAL_INTRO) == intro
13429                         && !(oldoldop->op_flags & OPf_SPECIAL)
13430                     ) {
13431                         U8 old_count;
13432                         assert(oldoldop->op_next == oldop);
13433                         assert(   oldop->op_type == OP_NEXTSTATE
13434                                || oldop->op_type == OP_DBSTATE);
13435                         assert(oldop->op_next == o);
13436
13437                         old_count
13438                             = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
13439
13440                        /* Do not assume pad offsets for $c and $d are con-
13441                           tiguous in
13442                             my ($a,$b,$c);
13443                             my ($d,$e,$f);
13444                         */
13445                         if (  oldoldop->op_targ + old_count == base
13446                            && old_count < OPpPADRANGE_COUNTMASK - count) {
13447                             base = oldoldop->op_targ;
13448                             count += old_count;
13449                             reuse = 1;
13450                         }
13451                     }
13452
13453                     /* if there's any immediately following singleton
13454                      * my var's; then swallow them and the associated
13455                      * nextstates; i.e.
13456                      *    my ($a,$b); my $c; my $d;
13457                      * is treated as
13458                      *    my ($a,$b,$c,$d);
13459                      */
13460
13461                     while (    ((p = followop->op_next))
13462                             && (  p->op_type == OP_PADSV
13463                                || p->op_type == OP_PADAV
13464                                || p->op_type == OP_PADHV)
13465                             && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
13466                             && (p->op_private & OPpLVAL_INTRO) == intro
13467                             && !(p->op_private & ~OPpLVAL_INTRO)
13468                             && p->op_next
13469                             && (   p->op_next->op_type == OP_NEXTSTATE
13470                                 || p->op_next->op_type == OP_DBSTATE)
13471                             && count < OPpPADRANGE_COUNTMASK
13472                             && base + count == p->op_targ
13473                     ) {
13474                         count++;
13475                         followop = p->op_next;
13476                     }
13477                 }
13478                 else
13479                     break;
13480             }
13481
13482             if (reuse) {
13483                 assert(oldoldop->op_type == OP_PADRANGE);
13484                 oldoldop->op_next = followop;
13485                 oldoldop->op_private = (intro | count);
13486                 o = oldoldop;
13487                 oldop = NULL;
13488                 oldoldop = NULL;
13489             }
13490             else {
13491                 /* Convert the pushmark into a padrange.
13492                  * To make Deparse easier, we guarantee that a padrange was
13493                  * *always* formerly a pushmark */
13494                 assert(o->op_type == OP_PUSHMARK);
13495                 o->op_next = followop;
13496                 OpTYPE_set(o, OP_PADRANGE);
13497                 o->op_targ = base;
13498                 /* bit 7: INTRO; bit 6..0: count */
13499                 o->op_private = (intro | count);
13500                 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
13501                               | gvoid * OPf_WANT_VOID
13502                               | (defav ? OPf_SPECIAL : 0));
13503             }
13504             break;
13505         }
13506
13507         case OP_PADAV:
13508         case OP_PADSV:
13509         case OP_PADHV:
13510         /* Skip over state($x) in void context.  */
13511         if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
13512          && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
13513         {
13514             oldop->op_next = o->op_next;
13515             goto redo_nextstate;
13516         }
13517         if (o->op_type != OP_PADAV)
13518             break;
13519         /* FALLTHROUGH */
13520         case OP_GV:
13521             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
13522                 OP* const pop = (o->op_type == OP_PADAV) ?
13523                             o->op_next : o->op_next->op_next;
13524                 IV i;
13525                 if (pop && pop->op_type == OP_CONST &&
13526                     ((PL_op = pop->op_next)) &&
13527                     pop->op_next->op_type == OP_AELEM &&
13528                     !(pop->op_next->op_private &
13529                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
13530                     (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
13531                 {
13532                     GV *gv;
13533                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
13534                         no_bareword_allowed(pop);
13535                     if (o->op_type == OP_GV)
13536                         op_null(o->op_next);
13537                     op_null(pop->op_next);
13538                     op_null(pop);
13539                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
13540                     o->op_next = pop->op_next->op_next;
13541                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
13542                     o->op_private = (U8)i;
13543                     if (o->op_type == OP_GV) {
13544                         gv = cGVOPo_gv;
13545                         GvAVn(gv);
13546                         o->op_type = OP_AELEMFAST;
13547                     }
13548                     else
13549                         o->op_type = OP_AELEMFAST_LEX;
13550                 }
13551                 if (o->op_type != OP_GV)
13552                     break;
13553             }
13554
13555             /* Remove $foo from the op_next chain in void context.  */
13556             if (oldop
13557              && (  o->op_next->op_type == OP_RV2SV
13558                 || o->op_next->op_type == OP_RV2AV
13559                 || o->op_next->op_type == OP_RV2HV  )
13560              && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
13561              && !(o->op_next->op_private & OPpLVAL_INTRO))
13562             {
13563                 oldop->op_next = o->op_next->op_next;
13564                 /* Reprocess the previous op if it is a nextstate, to
13565                    allow double-nextstate optimisation.  */
13566               redo_nextstate:
13567                 if (oldop->op_type == OP_NEXTSTATE) {
13568                     oldop->op_opt = 0;
13569                     o = oldop;
13570                     oldop = oldoldop;
13571                     oldoldop = NULL;
13572                     goto redo;
13573                 }
13574                 o = oldop;
13575             }
13576             else if (o->op_next->op_type == OP_RV2SV) {
13577                 if (!(o->op_next->op_private & OPpDEREF)) {
13578                     op_null(o->op_next);
13579                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
13580                                                                | OPpOUR_INTRO);
13581                     o->op_next = o->op_next->op_next;
13582                     OpTYPE_set(o, OP_GVSV);
13583                 }
13584             }
13585             else if (o->op_next->op_type == OP_READLINE
13586                     && o->op_next->op_next->op_type == OP_CONCAT
13587                     && (o->op_next->op_next->op_flags & OPf_STACKED))
13588             {
13589                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
13590                 OpTYPE_set(o, OP_RCATLINE);
13591                 o->op_flags |= OPf_STACKED;
13592                 op_null(o->op_next->op_next);
13593                 op_null(o->op_next);
13594             }
13595
13596             break;
13597
13598 #define HV_OR_SCALARHV(op)                                   \
13599     (  (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \
13600        ? (op)                                                  \
13601        : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \
13602        && (  cUNOPx(op)->op_first->op_type == OP_PADHV          \
13603           || cUNOPx(op)->op_first->op_type == OP_RV2HV)          \
13604          ? cUNOPx(op)->op_first                                   \
13605          : NULL)
13606
13607         case OP_NOT:
13608             if ((fop = HV_OR_SCALARHV(cUNOP->op_first)))
13609                 fop->op_private |= OPpTRUEBOOL;
13610             break;
13611
13612         case OP_AND:
13613         case OP_OR:
13614         case OP_DOR:
13615             fop = cLOGOP->op_first;
13616             sop = OpSIBLING(fop);
13617             while (cLOGOP->op_other->op_type == OP_NULL)
13618                 cLOGOP->op_other = cLOGOP->op_other->op_next;
13619             while (o->op_next && (   o->op_type == o->op_next->op_type
13620                                   || o->op_next->op_type == OP_NULL))
13621                 o->op_next = o->op_next->op_next;
13622
13623             /* if we're an OR and our next is a AND in void context, we'll
13624                follow it's op_other on short circuit, same for reverse.
13625                We can't do this with OP_DOR since if it's true, its return
13626                value is the underlying value which must be evaluated
13627                by the next op */
13628             if (o->op_next &&
13629                 (
13630                     (IS_AND_OP(o) && IS_OR_OP(o->op_next))
13631                  || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
13632                 )
13633                 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
13634             ) {
13635                 o->op_next = ((LOGOP*)o->op_next)->op_other;
13636             }
13637             DEFER(cLOGOP->op_other);
13638
13639             o->op_opt = 1;
13640             fop = HV_OR_SCALARHV(fop);
13641             if (sop) sop = HV_OR_SCALARHV(sop);
13642             if (fop || sop
13643             ){
13644                 OP * nop = o;
13645                 OP * lop = o;
13646                 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
13647                     while (nop && nop->op_next) {
13648                         switch (nop->op_next->op_type) {
13649                             case OP_NOT:
13650                             case OP_AND:
13651                             case OP_OR:
13652                             case OP_DOR:
13653                                 lop = nop = nop->op_next;
13654                                 break;
13655                             case OP_NULL:
13656                                 nop = nop->op_next;
13657                                 break;
13658                             default:
13659                                 nop = NULL;
13660                                 break;
13661                         }
13662                     }
13663                 }
13664                 if (fop) {
13665                     if (  (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
13666                       || o->op_type == OP_AND  )
13667                         fop->op_private |= OPpTRUEBOOL;
13668                     else if (!(lop->op_flags & OPf_WANT))
13669                         fop->op_private |= OPpMAYBE_TRUEBOOL;
13670                 }
13671                 if (  (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
13672                    && sop)
13673                     sop->op_private |= OPpTRUEBOOL;
13674             }
13675
13676
13677             break;
13678
13679         case OP_COND_EXPR:
13680             if ((fop = HV_OR_SCALARHV(cLOGOP->op_first)))
13681                 fop->op_private |= OPpTRUEBOOL;
13682 #undef HV_OR_SCALARHV
13683             /* GERONIMO! */ /* FALLTHROUGH */
13684
13685         case OP_MAPWHILE:
13686         case OP_GREPWHILE:
13687         case OP_ANDASSIGN:
13688         case OP_ORASSIGN:
13689         case OP_DORASSIGN:
13690         case OP_RANGE:
13691         case OP_ONCE:
13692             while (cLOGOP->op_other->op_type == OP_NULL)
13693                 cLOGOP->op_other = cLOGOP->op_other->op_next;
13694             DEFER(cLOGOP->op_other);
13695             break;
13696
13697         case OP_ENTERLOOP:
13698         case OP_ENTERITER:
13699             while (cLOOP->op_redoop->op_type == OP_NULL)
13700                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
13701             while (cLOOP->op_nextop->op_type == OP_NULL)
13702                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
13703             while (cLOOP->op_lastop->op_type == OP_NULL)
13704                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
13705             /* a while(1) loop doesn't have an op_next that escapes the
13706              * loop, so we have to explicitly follow the op_lastop to
13707              * process the rest of the code */
13708             DEFER(cLOOP->op_lastop);
13709             break;
13710
13711         case OP_ENTERTRY:
13712             assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
13713             DEFER(cLOGOPo->op_other);
13714             break;
13715
13716         case OP_SUBST:
13717             assert(!(cPMOP->op_pmflags & PMf_ONCE));
13718             while (cPMOP->op_pmstashstartu.op_pmreplstart &&
13719                    cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
13720                 cPMOP->op_pmstashstartu.op_pmreplstart
13721                     = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
13722             DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
13723             break;
13724
13725         case OP_SORT: {
13726             OP *oright;
13727
13728             if (o->op_flags & OPf_SPECIAL) {
13729                 /* first arg is a code block */
13730                 OP * const nullop = OpSIBLING(cLISTOP->op_first);
13731                 OP * kid          = cUNOPx(nullop)->op_first;
13732
13733                 assert(nullop->op_type == OP_NULL);
13734                 assert(kid->op_type == OP_SCOPE
13735                  || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
13736                 /* since OP_SORT doesn't have a handy op_other-style
13737                  * field that can point directly to the start of the code
13738                  * block, store it in the otherwise-unused op_next field
13739                  * of the top-level OP_NULL. This will be quicker at
13740                  * run-time, and it will also allow us to remove leading
13741                  * OP_NULLs by just messing with op_nexts without
13742                  * altering the basic op_first/op_sibling layout. */
13743                 kid = kLISTOP->op_first;
13744                 assert(
13745                       (kid->op_type == OP_NULL
13746                       && (  kid->op_targ == OP_NEXTSTATE
13747                          || kid->op_targ == OP_DBSTATE  ))
13748                     || kid->op_type == OP_STUB
13749                     || kid->op_type == OP_ENTER);
13750                 nullop->op_next = kLISTOP->op_next;
13751                 DEFER(nullop->op_next);
13752             }
13753
13754             /* check that RHS of sort is a single plain array */
13755             oright = cUNOPo->op_first;
13756             if (!oright || oright->op_type != OP_PUSHMARK)
13757                 break;
13758
13759             if (o->op_private & OPpSORT_INPLACE)
13760                 break;
13761
13762             /* reverse sort ... can be optimised.  */
13763             if (!OpHAS_SIBLING(cUNOPo)) {
13764                 /* Nothing follows us on the list. */
13765                 OP * const reverse = o->op_next;
13766
13767                 if (reverse->op_type == OP_REVERSE &&
13768                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
13769                     OP * const pushmark = cUNOPx(reverse)->op_first;
13770                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
13771                         && (OpSIBLING(cUNOPx(pushmark)) == o)) {
13772                         /* reverse -> pushmark -> sort */
13773                         o->op_private |= OPpSORT_REVERSE;
13774                         op_null(reverse);
13775                         pushmark->op_next = oright->op_next;
13776                         op_null(oright);
13777                     }
13778                 }
13779             }
13780
13781             break;
13782         }
13783
13784         case OP_REVERSE: {
13785             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
13786             OP *gvop = NULL;
13787             LISTOP *enter, *exlist;
13788
13789             if (o->op_private & OPpSORT_INPLACE)
13790                 break;
13791
13792             enter = (LISTOP *) o->op_next;
13793             if (!enter)
13794                 break;
13795             if (enter->op_type == OP_NULL) {
13796                 enter = (LISTOP *) enter->op_next;
13797                 if (!enter)
13798                     break;
13799             }
13800             /* for $a (...) will have OP_GV then OP_RV2GV here.
13801                for (...) just has an OP_GV.  */
13802             if (enter->op_type == OP_GV) {
13803                 gvop = (OP *) enter;
13804                 enter = (LISTOP *) enter->op_next;
13805                 if (!enter)
13806                     break;
13807                 if (enter->op_type == OP_RV2GV) {
13808                   enter = (LISTOP *) enter->op_next;
13809                   if (!enter)
13810                     break;
13811                 }
13812             }
13813
13814             if (enter->op_type != OP_ENTERITER)
13815                 break;
13816
13817             iter = enter->op_next;
13818             if (!iter || iter->op_type != OP_ITER)
13819                 break;
13820
13821             expushmark = enter->op_first;
13822             if (!expushmark || expushmark->op_type != OP_NULL
13823                 || expushmark->op_targ != OP_PUSHMARK)
13824                 break;
13825
13826             exlist = (LISTOP *) OpSIBLING(expushmark);
13827             if (!exlist || exlist->op_type != OP_NULL
13828                 || exlist->op_targ != OP_LIST)
13829                 break;
13830
13831             if (exlist->op_last != o) {
13832                 /* Mmm. Was expecting to point back to this op.  */
13833                 break;
13834             }
13835             theirmark = exlist->op_first;
13836             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
13837                 break;
13838
13839             if (OpSIBLING(theirmark) != o) {
13840                 /* There's something between the mark and the reverse, eg
13841                    for (1, reverse (...))
13842                    so no go.  */
13843                 break;
13844             }
13845
13846             ourmark = ((LISTOP *)o)->op_first;
13847             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
13848                 break;
13849
13850             ourlast = ((LISTOP *)o)->op_last;
13851             if (!ourlast || ourlast->op_next != o)
13852                 break;
13853
13854             rv2av = OpSIBLING(ourmark);
13855             if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
13856                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
13857                 /* We're just reversing a single array.  */
13858                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
13859                 enter->op_flags |= OPf_STACKED;
13860             }
13861
13862             /* We don't have control over who points to theirmark, so sacrifice
13863                ours.  */
13864             theirmark->op_next = ourmark->op_next;
13865             theirmark->op_flags = ourmark->op_flags;
13866             ourlast->op_next = gvop ? gvop : (OP *) enter;
13867             op_null(ourmark);
13868             op_null(o);
13869             enter->op_private |= OPpITER_REVERSED;
13870             iter->op_private |= OPpITER_REVERSED;
13871
13872             break;
13873         }
13874
13875         case OP_QR:
13876         case OP_MATCH:
13877             if (!(cPMOP->op_pmflags & PMf_ONCE)) {
13878                 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
13879             }
13880             break;
13881
13882         case OP_RUNCV:
13883             if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
13884              && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
13885             {
13886                 SV *sv;
13887                 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
13888                 else {
13889                     sv = newRV((SV *)PL_compcv);
13890                     sv_rvweaken(sv);
13891                     SvREADONLY_on(sv);
13892                 }
13893                 OpTYPE_set(o, OP_CONST);
13894                 o->op_flags |= OPf_SPECIAL;
13895                 cSVOPo->op_sv = sv;
13896             }
13897             break;
13898
13899         case OP_SASSIGN:
13900             if (OP_GIMME(o,0) == G_VOID
13901              || (  o->op_next->op_type == OP_LINESEQ
13902                 && (  o->op_next->op_next->op_type == OP_LEAVESUB
13903                    || (  o->op_next->op_next->op_type == OP_RETURN
13904                       && !CvLVALUE(PL_compcv)))))
13905             {
13906                 OP *right = cBINOP->op_first;
13907                 if (right) {
13908                     /*   sassign
13909                     *      RIGHT
13910                     *      substr
13911                     *         pushmark
13912                     *         arg1
13913                     *         arg2
13914                     *         ...
13915                     * becomes
13916                     *
13917                     *  ex-sassign
13918                     *     substr
13919                     *        pushmark
13920                     *        RIGHT
13921                     *        arg1
13922                     *        arg2
13923                     *        ...
13924                     */
13925                     OP *left = OpSIBLING(right);
13926                     if (left->op_type == OP_SUBSTR
13927                          && (left->op_private & 7) < 4) {
13928                         op_null(o);
13929                         /* cut out right */
13930                         op_sibling_splice(o, NULL, 1, NULL);
13931                         /* and insert it as second child of OP_SUBSTR */
13932                         op_sibling_splice(left, cBINOPx(left)->op_first, 0,
13933                                     right);
13934                         left->op_private |= OPpSUBSTR_REPL_FIRST;
13935                         left->op_flags =
13936                             (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
13937                     }
13938                 }
13939             }
13940             break;
13941
13942         case OP_AASSIGN:
13943             /* We do the common-vars check here, rather than in newASSIGNOP
13944                (as formerly), so that all lexical vars that get aliased are
13945                marked as such before we do the check.  */
13946             /* There can’t be common vars if the lhs is a stub.  */
13947             if (OpSIBLING(cLISTOPx(cBINOPo->op_last)->op_first)
13948                     == cLISTOPx(cBINOPo->op_last)->op_last
13949              && cLISTOPx(cBINOPo->op_last)->op_last->op_type == OP_STUB)
13950             {
13951                 o->op_private &=~ OPpASSIGN_COMMON;
13952                 break;
13953             }
13954             if (o->op_private & OPpASSIGN_COMMON) {
13955                  /* See the comment before S_aassign_common_vars concerning
13956                     PL_generation sorcery.  */
13957                 PL_generation++;
13958                 if (!aassign_common_vars(o))
13959                     o->op_private &=~ OPpASSIGN_COMMON;
13960             }
13961             else if (S_aassign_common_vars_aliases_only(aTHX_ o))
13962                 o->op_private |= OPpASSIGN_COMMON;
13963             break;
13964
13965         case OP_CUSTOM: {
13966             Perl_cpeep_t cpeep =
13967                 XopENTRYCUSTOM(o, xop_peep);
13968             if (cpeep)
13969                 cpeep(aTHX_ o, oldop);
13970             break;
13971         }
13972
13973         }
13974         /* did we just null the current op? If so, re-process it to handle
13975          * eliding "empty" ops from the chain */
13976         if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
13977             o->op_opt = 0;
13978             o = oldop;
13979         }
13980         else {
13981             oldoldop = oldop;
13982             oldop = o;
13983         }
13984     }
13985     LEAVE;
13986 }
13987
13988 void
13989 Perl_peep(pTHX_ OP *o)
13990 {
13991     CALL_RPEEP(o);
13992 }
13993
13994 /*
13995 =head1 Custom Operators
13996
13997 =for apidoc Ao||custom_op_xop
13998 Return the XOP structure for a given custom op.  This macro should be
13999 considered internal to OP_NAME and the other access macros: use them instead.
14000 This macro does call a function.  Prior
14001 to 5.19.6, this was implemented as a
14002 function.
14003
14004 =cut
14005 */
14006
14007 XOPRETANY
14008 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
14009 {
14010     SV *keysv;
14011     HE *he = NULL;
14012     XOP *xop;
14013
14014     static const XOP xop_null = { 0, 0, 0, 0, 0 };
14015
14016     PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
14017     assert(o->op_type == OP_CUSTOM);
14018
14019     /* This is wrong. It assumes a function pointer can be cast to IV,
14020      * which isn't guaranteed, but this is what the old custom OP code
14021      * did. In principle it should be safer to Copy the bytes of the
14022      * pointer into a PV: since the new interface is hidden behind
14023      * functions, this can be changed later if necessary.  */
14024     /* Change custom_op_xop if this ever happens */
14025     keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
14026
14027     if (PL_custom_ops)
14028         he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
14029
14030     /* assume noone will have just registered a desc */
14031     if (!he && PL_custom_op_names &&
14032         (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
14033     ) {
14034         const char *pv;
14035         STRLEN l;
14036
14037         /* XXX does all this need to be shared mem? */
14038         Newxz(xop, 1, XOP);
14039         pv = SvPV(HeVAL(he), l);
14040         XopENTRY_set(xop, xop_name, savepvn(pv, l));
14041         if (PL_custom_op_descs &&
14042             (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
14043         ) {
14044             pv = SvPV(HeVAL(he), l);
14045             XopENTRY_set(xop, xop_desc, savepvn(pv, l));
14046         }
14047         Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
14048     }
14049     else {
14050         if (!he)
14051             xop = (XOP *)&xop_null;
14052         else
14053             xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
14054     }
14055     {
14056         XOPRETANY any;
14057         if(field == XOPe_xop_ptr) {
14058             any.xop_ptr = xop;
14059         } else {
14060             const U32 flags = XopFLAGS(xop);
14061             if(flags & field) {
14062                 switch(field) {
14063                 case XOPe_xop_name:
14064                     any.xop_name = xop->xop_name;
14065                     break;
14066                 case XOPe_xop_desc:
14067                     any.xop_desc = xop->xop_desc;
14068                     break;
14069                 case XOPe_xop_class:
14070                     any.xop_class = xop->xop_class;
14071                     break;
14072                 case XOPe_xop_peep:
14073                     any.xop_peep = xop->xop_peep;
14074                     break;
14075                 default:
14076                     NOT_REACHED; /* NOTREACHED */
14077                     break;
14078                 }
14079             } else {
14080                 switch(field) {
14081                 case XOPe_xop_name:
14082                     any.xop_name = XOPd_xop_name;
14083                     break;
14084                 case XOPe_xop_desc:
14085                     any.xop_desc = XOPd_xop_desc;
14086                     break;
14087                 case XOPe_xop_class:
14088                     any.xop_class = XOPd_xop_class;
14089                     break;
14090                 case XOPe_xop_peep:
14091                     any.xop_peep = XOPd_xop_peep;
14092                     break;
14093                 default:
14094                     NOT_REACHED; /* NOTREACHED */
14095                     break;
14096                 }
14097             }
14098         }
14099         /* Some gcc releases emit a warning for this function:
14100          * op.c: In function 'Perl_custom_op_get_field':
14101          * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
14102          * Whether this is true, is currently unknown. */
14103         return any;
14104     }
14105 }
14106
14107 /*
14108 =for apidoc Ao||custom_op_register
14109 Register a custom op.  See L<perlguts/"Custom Operators">.
14110
14111 =cut
14112 */
14113
14114 void
14115 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
14116 {
14117     SV *keysv;
14118
14119     PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
14120
14121     /* see the comment in custom_op_xop */
14122     keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
14123
14124     if (!PL_custom_ops)
14125         PL_custom_ops = newHV();
14126
14127     if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
14128         Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
14129 }
14130
14131 /*
14132
14133 =for apidoc core_prototype
14134
14135 This function assigns the prototype of the named core function to C<sv>, or
14136 to a new mortal SV if C<sv> is NULL.  It returns the modified C<sv>, or
14137 NULL if the core function has no prototype.  C<code> is a code as returned
14138 by C<keyword()>.  It must not be equal to 0.
14139
14140 =cut
14141 */
14142
14143 SV *
14144 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
14145                           int * const opnum)
14146 {
14147     int i = 0, n = 0, seen_question = 0, defgv = 0;
14148     I32 oa;
14149 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
14150     char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
14151     bool nullret = FALSE;
14152
14153     PERL_ARGS_ASSERT_CORE_PROTOTYPE;
14154
14155     assert (code);
14156
14157     if (!sv) sv = sv_newmortal();
14158
14159 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
14160
14161     switch (code < 0 ? -code : code) {
14162     case KEY_and   : case KEY_chop: case KEY_chomp:
14163     case KEY_cmp   : case KEY_defined: case KEY_delete: case KEY_exec  :
14164     case KEY_exists: case KEY_eq     : case KEY_ge    : case KEY_goto  :
14165     case KEY_grep  : case KEY_gt     : case KEY_last  : case KEY_le    :
14166     case KEY_lt    : case KEY_map    : case KEY_ne    : case KEY_next  :
14167     case KEY_or    : case KEY_print  : case KEY_printf: case KEY_qr    :
14168     case KEY_redo  : case KEY_require: case KEY_return: case KEY_say   :
14169     case KEY_select: case KEY_sort   : case KEY_split : case KEY_system:
14170     case KEY_x     : case KEY_xor    :
14171         if (!opnum) return NULL; nullret = TRUE; goto findopnum;
14172     case KEY_glob:    retsetpvs("_;", OP_GLOB);
14173     case KEY_keys:    retsetpvs("\\[%@]", OP_KEYS);
14174     case KEY_values:  retsetpvs("\\[%@]", OP_VALUES);
14175     case KEY_each:    retsetpvs("\\[%@]", OP_EACH);
14176     case KEY_push:    retsetpvs("\\@@", OP_PUSH);
14177     case KEY_unshift: retsetpvs("\\@@", OP_UNSHIFT);
14178     case KEY_pop:     retsetpvs(";\\@", OP_POP);
14179     case KEY_shift:   retsetpvs(";\\@", OP_SHIFT);
14180     case KEY_pos:     retsetpvs(";\\[$*]", OP_POS);
14181     case KEY_splice:
14182         retsetpvs("\\@;$$@", OP_SPLICE);
14183     case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
14184         retsetpvs("", 0);
14185     case KEY_evalbytes:
14186         name = "entereval"; break;
14187     case KEY_readpipe:
14188         name = "backtick";
14189     }
14190
14191 #undef retsetpvs
14192
14193   findopnum:
14194     while (i < MAXO) {  /* The slow way. */
14195         if (strEQ(name, PL_op_name[i])
14196             || strEQ(name, PL_op_desc[i]))
14197         {
14198             if (nullret) { assert(opnum); *opnum = i; return NULL; }
14199             goto found;
14200         }
14201         i++;
14202     }
14203     return NULL;
14204   found:
14205     defgv = PL_opargs[i] & OA_DEFGV;
14206     oa = PL_opargs[i] >> OASHIFT;
14207     while (oa) {
14208         if (oa & OA_OPTIONAL && !seen_question && (
14209               !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
14210         )) {
14211             seen_question = 1;
14212             str[n++] = ';';
14213         }
14214         if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
14215             && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
14216             /* But globs are already references (kinda) */
14217             && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
14218         ) {
14219             str[n++] = '\\';
14220         }
14221         if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
14222          && !scalar_mod_type(NULL, i)) {
14223             str[n++] = '[';
14224             str[n++] = '$';
14225             str[n++] = '@';
14226             str[n++] = '%';
14227             if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
14228             str[n++] = '*';
14229             str[n++] = ']';
14230         }
14231         else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
14232         if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
14233             str[n-1] = '_'; defgv = 0;
14234         }
14235         oa = oa >> 4;
14236     }
14237     if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
14238     str[n++] = '\0';
14239     sv_setpvn(sv, str, n - 1);
14240     if (opnum) *opnum = i;
14241     return sv;
14242 }
14243
14244 OP *
14245 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
14246                       const int opnum)
14247 {
14248     OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
14249     OP *o;
14250
14251     PERL_ARGS_ASSERT_CORESUB_OP;
14252
14253     switch(opnum) {
14254     case 0:
14255         return op_append_elem(OP_LINESEQ,
14256                        argop,
14257                        newSLICEOP(0,
14258                                   newSVOP(OP_CONST, 0, newSViv(-code % 3)),
14259                                   newOP(OP_CALLER,0)
14260                        )
14261                );
14262     case OP_SELECT: /* which represents OP_SSELECT as well */
14263         if (code)
14264             return newCONDOP(
14265                          0,
14266                          newBINOP(OP_GT, 0,
14267                                   newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
14268                                   newSVOP(OP_CONST, 0, newSVuv(1))
14269                                  ),
14270                          coresub_op(newSVuv((UV)OP_SSELECT), 0,
14271                                     OP_SSELECT),
14272                          coresub_op(coreargssv, 0, OP_SELECT)
14273                    );
14274         /* FALLTHROUGH */
14275     default:
14276         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
14277         case OA_BASEOP:
14278             return op_append_elem(
14279                         OP_LINESEQ, argop,
14280                         newOP(opnum,
14281                               opnum == OP_WANTARRAY || opnum == OP_RUNCV
14282                                 ? OPpOFFBYONE << 8 : 0)
14283                    );
14284         case OA_BASEOP_OR_UNOP:
14285             if (opnum == OP_ENTEREVAL) {
14286                 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
14287                 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
14288             }
14289             else o = newUNOP(opnum,0,argop);
14290             if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
14291             else {
14292           onearg:
14293               if (is_handle_constructor(o, 1))
14294                 argop->op_private |= OPpCOREARGS_DEREF1;
14295               if (scalar_mod_type(NULL, opnum))
14296                 argop->op_private |= OPpCOREARGS_SCALARMOD;
14297             }
14298             return o;
14299         default:
14300             o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
14301             if (is_handle_constructor(o, 2))
14302                 argop->op_private |= OPpCOREARGS_DEREF2;
14303             if (opnum == OP_SUBSTR) {
14304                 o->op_private |= OPpMAYBE_LVSUB;
14305                 return o;
14306             }
14307             else goto onearg;
14308         }
14309     }
14310 }
14311
14312 void
14313 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
14314                                SV * const *new_const_svp)
14315 {
14316     const char *hvname;
14317     bool is_const = !!CvCONST(old_cv);
14318     SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
14319
14320     PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
14321
14322     if (is_const && new_const_svp && old_const_sv == *new_const_svp)
14323         return;
14324         /* They are 2 constant subroutines generated from
14325            the same constant. This probably means that
14326            they are really the "same" proxy subroutine
14327            instantiated in 2 places. Most likely this is
14328            when a constant is exported twice.  Don't warn.
14329         */
14330     if (
14331         (ckWARN(WARN_REDEFINE)
14332          && !(
14333                 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
14334              && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
14335              && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
14336                  strEQ(hvname, "autouse"))
14337              )
14338         )
14339      || (is_const
14340          && ckWARN_d(WARN_REDEFINE)
14341          && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
14342         )
14343     )
14344         Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
14345                           is_const
14346                             ? "Constant subroutine %"SVf" redefined"
14347                             : "Subroutine %"SVf" redefined",
14348                           SVfARG(name));
14349 }
14350
14351 /*
14352 =head1 Hook manipulation
14353
14354 These functions provide convenient and thread-safe means of manipulating
14355 hook variables.
14356
14357 =cut
14358 */
14359
14360 /*
14361 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
14362
14363 Puts a C function into the chain of check functions for a specified op
14364 type.  This is the preferred way to manipulate the L</PL_check> array.
14365 C<opcode> specifies which type of op is to be affected.  C<new_checker>
14366 is a pointer to the C function that is to be added to that opcode's
14367 check chain, and C<old_checker_p> points to the storage location where a
14368 pointer to the next function in the chain will be stored.  The value of
14369 C<new_pointer> is written into the L</PL_check> array, while the value
14370 previously stored there is written to C<*old_checker_p>.
14371
14372 The function should be defined like this:
14373
14374     static OP *new_checker(pTHX_ OP *op) { ... }
14375
14376 It is intended to be called in this manner:
14377
14378     new_checker(aTHX_ op)
14379
14380 C<old_checker_p> should be defined like this:
14381
14382     static Perl_check_t old_checker_p;
14383
14384 L</PL_check> is global to an entire process, and a module wishing to
14385 hook op checking may find itself invoked more than once per process,
14386 typically in different threads.  To handle that situation, this function
14387 is idempotent.  The location C<*old_checker_p> must initially (once
14388 per process) contain a null pointer.  A C variable of static duration
14389 (declared at file scope, typically also marked C<static> to give
14390 it internal linkage) will be implicitly initialised appropriately,
14391 if it does not have an explicit initialiser.  This function will only
14392 actually modify the check chain if it finds C<*old_checker_p> to be null.
14393 This function is also thread safe on the small scale.  It uses appropriate
14394 locking to avoid race conditions in accessing L</PL_check>.
14395
14396 When this function is called, the function referenced by C<new_checker>
14397 must be ready to be called, except for C<*old_checker_p> being unfilled.
14398 In a threading situation, C<new_checker> may be called immediately,
14399 even before this function has returned.  C<*old_checker_p> will always
14400 be appropriately set before C<new_checker> is called.  If C<new_checker>
14401 decides not to do anything special with an op that it is given (which
14402 is the usual case for most uses of op check hooking), it must chain the
14403 check function referenced by C<*old_checker_p>.
14404
14405 If you want to influence compilation of calls to a specific subroutine,
14406 then use L</cv_set_call_checker> rather than hooking checking of all
14407 C<entersub> ops.
14408
14409 =cut
14410 */
14411
14412 void
14413 Perl_wrap_op_checker(pTHX_ Optype opcode,
14414     Perl_check_t new_checker, Perl_check_t *old_checker_p)
14415 {
14416     dVAR;
14417
14418     PERL_UNUSED_CONTEXT;
14419     PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
14420     if (*old_checker_p) return;
14421     OP_CHECK_MUTEX_LOCK;
14422     if (!*old_checker_p) {
14423         *old_checker_p = PL_check[opcode];
14424         PL_check[opcode] = new_checker;
14425     }
14426     OP_CHECK_MUTEX_UNLOCK;
14427 }
14428
14429 #include "XSUB.h"
14430
14431 /* Efficient sub that returns a constant scalar value. */
14432 static void
14433 const_sv_xsub(pTHX_ CV* cv)
14434 {
14435     dXSARGS;
14436     SV *const sv = MUTABLE_SV(XSANY.any_ptr);
14437     PERL_UNUSED_ARG(items);
14438     if (!sv) {
14439         XSRETURN(0);
14440     }
14441     EXTEND(sp, 1);
14442     ST(0) = sv;
14443     XSRETURN(1);
14444 }
14445
14446 static void
14447 const_av_xsub(pTHX_ CV* cv)
14448 {
14449     dXSARGS;
14450     AV * const av = MUTABLE_AV(XSANY.any_ptr);
14451     SP -= items;
14452     assert(av);
14453 #ifndef DEBUGGING
14454     if (!av) {
14455         XSRETURN(0);
14456     }
14457 #endif
14458     if (SvRMAGICAL(av))
14459         Perl_croak(aTHX_ "Magical list constants are not supported");
14460     if (GIMME_V != G_ARRAY) {
14461         EXTEND(SP, 1);
14462         ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
14463         XSRETURN(1);
14464     }
14465     EXTEND(SP, AvFILLp(av)+1);
14466     Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
14467     XSRETURN(AvFILLp(av)+1);
14468 }
14469
14470 /*
14471  * ex: set ts=8 sts=4 sw=4 et:
14472  */