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 /* remove any leading "empty" ops from the op_next chain whose first
 113  * node's address is stored in op_p. Store the updated address of the
 114  * first node in op_p.
 115  */
 116
 117 STATIC void
 118 S_prune_chain_head(OP** op_p)
 119 {
 120     while (*op_p
 121         && (   (*op_p)->op_type == OP_NULL
 122             || (*op_p)->op_type == OP_SCOPE
 123             || (*op_p)->op_type == OP_SCALAR
 124             || (*op_p)->op_type == OP_LINESEQ)
 125     )
 126         *op_p = (*op_p)->op_next;
 127 }
 128
 129
 130 /* See the explanatory comments above struct opslab in op.h. */
 131
 132 #ifdef PERL_DEBUG_READONLY_OPS
 133 #  define PERL_SLAB_SIZE 128
 134 #  define PERL_MAX_SLAB_SIZE 4096
 135 #  include <sys/mman.h>
 136 #endif
 137
 138 #ifndef PERL_SLAB_SIZE
 139 #  define PERL_SLAB_SIZE 64
 140 #endif
 141 #ifndef PERL_MAX_SLAB_SIZE
 142 #  define PERL_MAX_SLAB_SIZE 2048
 143 #endif
 144
 145 /* rounds up to nearest pointer */
 146 #define SIZE_TO_PSIZE(x)        (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
 147 #define DIFF(o,p)               ((size_t)((I32 **)(p) - (I32**)(o)))
 148
 149 static OPSLAB *
 150 S_new_slab(pTHX_ size_t sz)
 151 {
 152 #ifdef PERL_DEBUG_READONLY_OPS
 153     OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
 154                                    PROT_READ|PROT_WRITE,
 155                                    MAP_ANON|MAP_PRIVATE, -1, 0);
 156     DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
 157                           (unsigned long) sz, slab));
 158     if (slab == MAP_FAILED) {
 159         perror("mmap failed");
 160         abort();
 161     }
 162     slab->opslab_size = (U16)sz;
 163 #else
 164     OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
 165 #endif
 166 #ifndef WIN32
 167     /* The context is unused in non-Windows */
 168     PERL_UNUSED_CONTEXT;
 169 #endif
 170     slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
 171     return slab;
 172 }
 173
 174 /* requires double parens and aTHX_ */
 175 #define DEBUG_S_warn(args)                                             \
 176     DEBUG_S(                                                            \
 177         PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
 178     )
 179
 180 void *
 181 Perl_Slab_Alloc(pTHX_ size_t sz)
 182 {
 183     dVAR;
 184     OPSLAB *slab;
 185     OPSLAB *slab2;
 186     OPSLOT *slot;
 187     OP *o;
 188     size_t opsz, space;
 189
 190     /* We only allocate ops from the slab during subroutine compilation.
 191        We find the slab via PL_compcv, hence that must be non-NULL. It could
 192        also be pointing to a subroutine which is now fully set up (CvROOT()
 193        pointing to the top of the optree for that sub), or a subroutine
 194        which isn't using the slab allocator. If our sanity checks aren't met,
 195        don't use a slab, but allocate the OP directly from the heap.  */
 196     if (!PL_compcv || CvROOT(PL_compcv)
 197      || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
 198         return PerlMemShared_calloc(1, sz);
 199
 200     /* While the subroutine is under construction, the slabs are accessed via
 201        CvSTART(), to avoid needing to expand PVCV by one pointer for something
 202        unneeded at runtime. Once a subroutine is constructed, the slabs are
 203        accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
 204        allocated yet.  See the commit message for 8be227ab5eaa23f2 for more
 205        details.  */
 206     if (!CvSTART(PL_compcv)) {
 207         CvSTART(PL_compcv) =
 208             (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
 209         CvSLABBED_on(PL_compcv);
 210         slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
 211     }
 212     else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
 213
 214     opsz = SIZE_TO_PSIZE(sz);
 215     sz = opsz + OPSLOT_HEADER_P;
 216
 217     /* The slabs maintain a free list of OPs. In particular, constant folding
 218        will free up OPs, so it makes sense to re-use them where possible. A
 219        freed up slot is used in preference to a new allocation.  */
 220     if (slab->opslab_freed) {
 221         OP **too = &slab->opslab_freed;
 222         o = *too;
 223         DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", (void*)o, (void*)slab));
 224         while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
 225             DEBUG_S_warn((aTHX_ "Alas! too small"));
 226             o = *(too = &o->op_next);
 227             if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", (void*)o)); }
 228         }
 229         if (o) {
 230             *too = o->op_next;
 231             Zero(o, opsz, I32 *);
 232             o->op_slabbed = 1;
 233             return (void *)o;
 234         }
 235     }
 236
 237 #define INIT_OPSLOT \
 238             slot->opslot_slab = slab;                   \
 239             slot->opslot_next = slab2->opslab_first;    \
 240             slab2->opslab_first = slot;                 \
 241             o = &slot->opslot_op;                       \
 242             o->op_slabbed = 1
 243
 244     /* The partially-filled slab is next in the chain. */
 245     slab2 = slab->opslab_next ? slab->opslab_next : slab;
 246     if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
 247         /* Remaining space is too small. */
 248
 249         /* If we can fit a BASEOP, add it to the free chain, so as not
 250            to waste it. */
 251         if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
 252             slot = &slab2->opslab_slots;
 253             INIT_OPSLOT;
 254             o->op_type = OP_FREED;
 255             o->op_next = slab->opslab_freed;
 256             slab->opslab_freed = o;
 257         }
 258
 259         /* Create a new slab.  Make this one twice as big. */
 260         slot = slab2->opslab_first;
 261         while (slot->opslot_next) slot = slot->opslot_next;
 262         slab2 = S_new_slab(aTHX_
 263                             (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
 264                                         ? PERL_MAX_SLAB_SIZE
 265                                         : (DIFF(slab2, slot)+1)*2);
 266         slab2->opslab_next = slab->opslab_next;
 267         slab->opslab_next = slab2;
 268     }
 269     assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
 270
 271     /* Create a new op slot */
 272     slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
 273     assert(slot >= &slab2->opslab_slots);
 274     if (DIFF(&slab2->opslab_slots, slot)
 275          < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
 276         slot = &slab2->opslab_slots;
 277     INIT_OPSLOT;
 278     DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab));
 279     return (void *)o;
 280 }
 281
 282 #undef INIT_OPSLOT
 283
 284 #ifdef PERL_DEBUG_READONLY_OPS
 285 void
 286 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
 287 {
 288     PERL_ARGS_ASSERT_SLAB_TO_RO;
 289
 290     if (slab->opslab_readonly) return;
 291     slab->opslab_readonly = 1;
 292     for (; slab; slab = slab->opslab_next) {
 293         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
 294                               (unsigned long) slab->opslab_size, slab));*/
 295         if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
 296             Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
 297                              (unsigned long)slab->opslab_size, errno);
 298     }
 299 }
 300
 301 void
 302 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
 303 {
 304     OPSLAB *slab2;
 305
 306     PERL_ARGS_ASSERT_SLAB_TO_RW;
 307
 308     if (!slab->opslab_readonly) return;
 309     slab2 = slab;
 310     for (; slab2; slab2 = slab2->opslab_next) {
 311         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
 312                               (unsigned long) size, slab2));*/
 313         if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
 314                      PROT_READ|PROT_WRITE)) {
 315             Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
 316                              (unsigned long)slab2->opslab_size, errno);
 317         }
 318     }
 319     slab->opslab_readonly = 0;
 320 }
 321
 322 #else
 323 #  define Slab_to_rw(op)    NOOP
 324 #endif
 325
 326 /* This cannot possibly be right, but it was copied from the old slab
 327    allocator, to which it was originally added, without explanation, in
 328    commit 083fcd5. */
 329 #ifdef NETWARE
 330 #    define PerlMemShared PerlMem
 331 #endif
 332
 333 void
 334 Perl_Slab_Free(pTHX_ void *op)
 335 {
 336     dVAR;
 337     OP * const o = (OP *)op;
 338     OPSLAB *slab;
 339
 340     PERL_ARGS_ASSERT_SLAB_FREE;
 341
 342     if (!o->op_slabbed) {
 343         if (!o->op_static)
 344             PerlMemShared_free(op);
 345         return;
 346     }
 347
 348     slab = OpSLAB(o);
 349     /* If this op is already freed, our refcount will get screwy. */
 350     assert(o->op_type != OP_FREED);
 351     o->op_type = OP_FREED;
 352     o->op_next = slab->opslab_freed;
 353     slab->opslab_freed = o;
 354     DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", (void*)o, (void*)slab));
 355     OpslabREFCNT_dec_padok(slab);
 356 }
 357
 358 void
 359 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
 360 {
 361     dVAR;
 362     const bool havepad = !!PL_comppad;
 363     PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
 364     if (havepad) {
 365         ENTER;
 366         PAD_SAVE_SETNULLPAD();
 367     }
 368     opslab_free(slab);
 369     if (havepad) LEAVE;
 370 }
 371
 372 void
 373 Perl_opslab_free(pTHX_ OPSLAB *slab)
 374 {
 375     dVAR;
 376     OPSLAB *slab2;
 377     PERL_ARGS_ASSERT_OPSLAB_FREE;
 378     DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
 379     assert(slab->opslab_refcnt == 1);
 380     for (; slab; slab = slab2) {
 381         slab2 = slab->opslab_next;
 382 #ifdef DEBUGGING
 383         slab->opslab_refcnt = ~(size_t)0;
 384 #endif
 385 #ifdef PERL_DEBUG_READONLY_OPS
 386         DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
 387                                                (void*)slab));
 388         if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
 389             perror("munmap failed");
 390             abort();
 391         }
 392 #else
 393         PerlMemShared_free(slab);
 394 #endif
 395     }
 396 }
 397
 398 void
 399 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
 400 {
 401     OPSLAB *slab2;
 402     OPSLOT *slot;
 403 #ifdef DEBUGGING
 404     size_t savestack_count = 0;
 405 #endif
 406     PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
 407     slab2 = slab;
 408     do {
 409         for (slot = slab2->opslab_first;
 410              slot->opslot_next;
 411              slot = slot->opslot_next) {
 412             if (slot->opslot_op.op_type != OP_FREED
 413              && !(slot->opslot_op.op_savefree
 414 #ifdef DEBUGGING
 415                   && ++savestack_count
 416 #endif
 417                  )
 418             ) {
 419                 assert(slot->opslot_op.op_slabbed);
 420                 op_free(&slot->opslot_op);
 421                 if (slab->opslab_refcnt == 1) goto free;
 422             }
 423         }
 424     } while ((slab2 = slab2->opslab_next));
 425     /* > 1 because the CV still holds a reference count. */
 426     if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
 427 #ifdef DEBUGGING
 428         assert(savestack_count == slab->opslab_refcnt-1);
 429 #endif
 430         /* Remove the CV’s reference count. */
 431         slab->opslab_refcnt--;
 432         return;
 433     }
 434    free:
 435     opslab_free(slab);
 436 }
 437
 438 #ifdef PERL_DEBUG_READONLY_OPS
 439 OP *
 440 Perl_op_refcnt_inc(pTHX_ OP *o)
 441 {
 442     if(o) {
 443         OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
 444         if (slab && slab->opslab_readonly) {
 445             Slab_to_rw(slab);
 446             ++o->op_targ;
 447             Slab_to_ro(slab);
 448         } else {
 449             ++o->op_targ;
 450         }
 451     }
 452     return o;
 453
 454 }
 455
 456 PADOFFSET
 457 Perl_op_refcnt_dec(pTHX_ OP *o)
 458 {
 459     PADOFFSET result;
 460     OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
 461
 462     PERL_ARGS_ASSERT_OP_REFCNT_DEC;
 463
 464     if (slab && slab->opslab_readonly) {
 465         Slab_to_rw(slab);
 466         result = --o->op_targ;
 467         Slab_to_ro(slab);
 468     } else {
 469         result = --o->op_targ;
 470     }
 471     return result;
 472 }
 473 #endif
 474 /*
 475  * In the following definition, the ", (OP*)0" is just to make the compiler
 476  * think the expression is of the right type: croak actually does a Siglongjmp.
 477  */
 478 #define CHECKOP(type,o) \
 479     ((PL_op_mask && PL_op_mask[type])                           \
 480      ? ( op_free((OP*)o),                                       \
 481          Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]),  \
 482          (OP*)0 )                                               \
 483      : PL_check[type](aTHX_ (OP*)o))
 484
 485 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
 486
 487 #define CHANGE_TYPE(o,type) \
 488     STMT_START {                                \
 489         o->op_type = (OPCODE)type;              \
 490         o->op_ppaddr = PL_ppaddr[type];         \
 491     } STMT_END
 492
 493 STATIC SV*
 494 S_gv_ename(pTHX_ GV *gv)
 495 {
 496     SV* const tmpsv = sv_newmortal();
 497
 498     PERL_ARGS_ASSERT_GV_ENAME;
 499
 500     gv_efullname3(tmpsv, gv, NULL);
 501     return tmpsv;
 502 }
 503
 504 STATIC OP *
 505 S_no_fh_allowed(pTHX_ OP *o)
 506 {
 507     PERL_ARGS_ASSERT_NO_FH_ALLOWED;
 508
 509     yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
 510                  OP_DESC(o)));
 511     return o;
 512 }
 513
 514 STATIC OP *
 515 S_too_few_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
 516 {
 517     PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_SV;
 518     yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, SVfARG(namesv)),
 519                                     SvUTF8(namesv) | flags);
 520     return o;
 521 }
 522
 523 STATIC OP *
 524 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
 525 {
 526     PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
 527     yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
 528     return o;
 529 }
 530
 531 STATIC OP *
 532 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
 533 {
 534     PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
 535
 536     yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
 537     return o;
 538 }
 539
 540 STATIC OP *
 541 S_too_many_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
 542 {
 543     PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_SV;
 544
 545     yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf, SVfARG(namesv)),
 546                 SvUTF8(namesv) | flags);
 547     return o;
 548 }
 549
 550 STATIC void
 551 S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid)
 552 {
 553     PERL_ARGS_ASSERT_BAD_TYPE_PV;
 554
 555     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
 556                  (int)n, name, t, OP_DESC(kid)), flags);
 557 }
 558
 559 STATIC void
 560 S_bad_type_gv(pTHX_ I32 n, const char *t, GV *gv, U32 flags, const OP *kid)
 561 {
 562     SV * const namesv = gv_ename(gv);
 563     PERL_ARGS_ASSERT_BAD_TYPE_GV;
 564
 565     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
 566                  (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv) | flags);
 567 }
 568
 569 STATIC void
 570 S_no_bareword_allowed(pTHX_ OP *o)
 571 {
 572     PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
 573
 574     qerror(Perl_mess(aTHX_
 575                      "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
 576                      SVfARG(cSVOPo_sv)));
 577     o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
 578 }
 579
 580 /* "register" allocation */
 581
 582 PADOFFSET
 583 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
 584 {
 585     dVAR;
 586     PADOFFSET off;
 587     const bool is_our = (PL_parser->in_my == KEY_our);
 588
 589     PERL_ARGS_ASSERT_ALLOCMY;
 590
 591     if (flags & ~SVf_UTF8)
 592         Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
 593                    (UV)flags);
 594
 595     /* Until we're using the length for real, cross check that we're being
 596        told the truth.  */
 597     assert(strlen(name) == len);
 598
 599     /* complain about "my $<special_var>" etc etc */
 600     if (len &&
 601         !(is_our ||
 602           isALPHA(name[1]) ||
 603           ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
 604           (name[1] == '_' && (*name == '$' || len > 2))))
 605     {
 606         /* name[2] is true if strlen(name) > 2  */
 607         if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
 608          && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
 609             yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
 610                               name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
 611                               PL_parser->in_my == KEY_state ? "state" : "my"));
 612         } else {
 613             yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
 614                               PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
 615         }
 616     }
 617     else if (len == 2 && name[1] == '_' && !is_our)
 618         /* diag_listed_as: Use of my $_ is experimental */
 619         Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__LEXICAL_TOPIC),
 620                               "Use of %s $_ is experimental",
 621                                PL_parser->in_my == KEY_state
 622                                  ? "state"
 623                                  : "my");
 624
 625     /* allocate a spare slot and store the name in that slot */
 626
 627     off = pad_add_name_pvn(name, len,
 628                        (is_our ? padadd_OUR :
 629                         PL_parser->in_my == KEY_state ? padadd_STATE : 0)
 630                             | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ),
 631                     PL_parser->in_my_stash,
 632                     (is_our
 633                         /* $_ is always in main::, even with our */
 634                         ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
 635                         : NULL
 636                     )
 637     );
 638     /* anon sub prototypes contains state vars should always be cloned,
 639      * otherwise the state var would be shared between anon subs */
 640
 641     if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
 642         CvCLONE_on(PL_compcv);
 643
 644     return off;
 645 }
 646
 647 /*
 648 =head1 Optree Manipulation Functions
 649
 650 =for apidoc alloccopstash
 651
 652 Available only under threaded builds, this function allocates an entry in
 653 C<PL_stashpad> for the stash passed to it.
 654
 655 =cut
 656 */
 657
 658 #ifdef USE_ITHREADS
 659 PADOFFSET
 660 Perl_alloccopstash(pTHX_ HV *hv)
 661 {
 662     PADOFFSET off = 0, o = 1;
 663     bool found_slot = FALSE;
 664
 665     PERL_ARGS_ASSERT_ALLOCCOPSTASH;
 666
 667     if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
 668
 669     for (; o < PL_stashpadmax; ++o) {
 670         if (PL_stashpad[o] == hv) return PL_stashpadix = o;
 671         if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
 672             found_slot = TRUE, off = o;
 673     }
 674     if (!found_slot) {
 675         Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
 676         Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
 677         off = PL_stashpadmax;
 678         PL_stashpadmax += 10;
 679     }
 680
 681     PL_stashpad[PL_stashpadix = off] = hv;
 682     return off;
 683 }
 684 #endif
 685
 686 /* free the body of an op without examining its contents.
 687  * Always use this rather than FreeOp directly */
 688
 689 static void
 690 S_op_destroy(pTHX_ OP *o)
 691 {
 692     FreeOp(o);
 693 }
 694
 695 /* Destructor */
 696
 697 /*
 698 =for apidoc Am|void|op_free|OP *o
 699
 700 Free an op.  Only use this when an op is no longer linked to from any
 701 optree.
 702
 703 =cut
 704 */
 705
 706 void
 707 Perl_op_free(pTHX_ OP *o)
 708 {
 709     dVAR;
 710     OPCODE type;
 711
 712     /* Though ops may be freed twice, freeing the op after its slab is a
 713        big no-no. */
 714     assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
 715     /* During the forced freeing of ops after compilation failure, kidops
 716        may be freed before their parents. */
 717     if (!o || o->op_type == OP_FREED)
 718         return;
 719
 720     type = o->op_type;
 721     if (o->op_private & OPpREFCOUNTED) {
 722         switch (type) {
 723         case OP_LEAVESUB:
 724         case OP_LEAVESUBLV:
 725         case OP_LEAVEEVAL:
 726         case OP_LEAVE:
 727         case OP_SCOPE:
 728         case OP_LEAVEWRITE:
 729             {
 730             PADOFFSET refcnt;
 731             OP_REFCNT_LOCK;
 732             refcnt = OpREFCNT_dec(o);
 733             OP_REFCNT_UNLOCK;
 734             if (refcnt) {
 735                 /* Need to find and remove any pattern match ops from the list
 736                    we maintain for reset().  */
 737                 find_and_forget_pmops(o);
 738                 return;
 739             }
 740             }
 741             break;
 742         default:
 743             break;
 744         }
 745     }
 746
 747     /* Call the op_free hook if it has been set. Do it now so that it's called
 748      * at the right time for refcounted ops, but still before all of the kids
 749      * are freed. */
 750     CALL_OPFREEHOOK(o);
 751
 752     if (o->op_flags & OPf_KIDS) {
 753         OP *kid, *nextkid;
 754         for (kid = cUNOPo->op_first; kid; kid = nextkid) {
 755             nextkid = kid->op_sibling; /* Get before next freeing kid */
 756             op_free(kid);
 757         }
 758     }
 759     if (type == OP_NULL)
 760         type = (OPCODE)o->op_targ;
 761
 762     if (o->op_slabbed)
 763         Slab_to_rw(OpSLAB(o));
 764
 765     /* COP* is not cleared by op_clear() so that we may track line
 766      * numbers etc even after null() */
 767     if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
 768         cop_free((COP*)o);
 769     }
 770
 771     op_clear(o);
 772     FreeOp(o);
 773 #ifdef DEBUG_LEAKING_SCALARS
 774     if (PL_op == o)
 775         PL_op = NULL;
 776 #endif
 777 }
 778
 779 void
 780 Perl_op_clear(pTHX_ OP *o)
 781 {
 782
 783     dVAR;
 784
 785     PERL_ARGS_ASSERT_OP_CLEAR;
 786
 787     switch (o->op_type) {
 788     case OP_NULL:       /* Was holding old type, if any. */
 789         /* FALLTHROUGH */
 790     case OP_ENTERTRY:
 791     case OP_ENTEREVAL:  /* Was holding hints. */
 792         o->op_targ = 0;
 793         break;
 794     default:
 795         if (!(o->op_flags & OPf_REF)
 796             || (PL_check[o->op_type] != Perl_ck_ftst))
 797             break;
 798         /* FALLTHROUGH */
 799     case OP_GVSV:
 800     case OP_GV:
 801     case OP_AELEMFAST:
 802         {
 803             GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
 804 #ifdef USE_ITHREADS
 805                         && PL_curpad
 806 #endif
 807                         ? cGVOPo_gv : NULL;
 808             /* It's possible during global destruction that the GV is freed
 809                before the optree. Whilst the SvREFCNT_inc is happy to bump from
 810                0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
 811                will trigger an assertion failure, because the entry to sv_clear
 812                checks that the scalar is not already freed.  A check of for
 813                !SvIS_FREED(gv) turns out to be invalid, because during global
 814                destruction the reference count can be forced down to zero
 815                (with SVf_BREAK set).  In which case raising to 1 and then
 816                dropping to 0 triggers cleanup before it should happen.  I
 817                *think* that this might actually be a general, systematic,
 818                weakness of the whole idea of SVf_BREAK, in that code *is*
 819                allowed to raise and lower references during global destruction,
 820                so any *valid* code that happens to do this during global
 821                destruction might well trigger premature cleanup.  */
 822             bool still_valid = gv && SvREFCNT(gv);
 823
 824             if (still_valid)
 825                 SvREFCNT_inc_simple_void(gv);
 826 #ifdef USE_ITHREADS
 827             if (cPADOPo->op_padix > 0) {
 828                 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
 829                  * may still exist on the pad */
 830                 pad_swipe(cPADOPo->op_padix, TRUE);
 831                 cPADOPo->op_padix = 0;
 832             }
 833 #else
 834             SvREFCNT_dec(cSVOPo->op_sv);
 835             cSVOPo->op_sv = NULL;
 836 #endif
 837             if (still_valid) {
 838                 int try_downgrade = SvREFCNT(gv) == 2;
 839                 SvREFCNT_dec_NN(gv);
 840                 if (try_downgrade)
 841                     gv_try_downgrade(gv);
 842             }
 843         }
 844         break;
 845     case OP_METHOD_NAMED:
 846     case OP_CONST:
 847     case OP_HINTSEVAL:
 848         SvREFCNT_dec(cSVOPo->op_sv);
 849         cSVOPo->op_sv = NULL;
 850 #ifdef USE_ITHREADS
 851         /** Bug #15654
 852           Even if op_clear does a pad_free for the target of the op,
 853           pad_free doesn't actually remove the sv that exists in the pad;
 854           instead it lives on. This results in that it could be reused as
 855           a target later on when the pad was reallocated.
 856         **/
 857         if(o->op_targ) {
 858           pad_swipe(o->op_targ,1);
 859           o->op_targ = 0;
 860         }
 861 #endif
 862         break;
 863     case OP_DUMP:
 864     case OP_GOTO:
 865     case OP_NEXT:
 866     case OP_LAST:
 867     case OP_REDO:
 868         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
 869             break;
 870         /* FALLTHROUGH */
 871     case OP_TRANS:
 872     case OP_TRANSR:
 873         if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
 874             assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
 875 #ifdef USE_ITHREADS
 876             if (cPADOPo->op_padix > 0) {
 877                 pad_swipe(cPADOPo->op_padix, TRUE);
 878                 cPADOPo->op_padix = 0;
 879             }
 880 #else
 881             SvREFCNT_dec(cSVOPo->op_sv);
 882             cSVOPo->op_sv = NULL;
 883 #endif
 884         }
 885         else {
 886             PerlMemShared_free(cPVOPo->op_pv);
 887             cPVOPo->op_pv = NULL;
 888         }
 889         break;
 890     case OP_SUBST:
 891         op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
 892         goto clear_pmop;
 893     case OP_PUSHRE:
 894 #ifdef USE_ITHREADS
 895         if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
 896             /* No GvIN_PAD_off here, because other references may still
 897              * exist on the pad */
 898             pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
 899         }
 900 #else
 901         SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
 902 #endif
 903         /* FALLTHROUGH */
 904     case OP_MATCH:
 905     case OP_QR:
 906 clear_pmop:
 907         if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
 908             op_free(cPMOPo->op_code_list);
 909         cPMOPo->op_code_list = NULL;
 910         forget_pmop(cPMOPo);
 911         cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
 912         /* we use the same protection as the "SAFE" version of the PM_ macros
 913          * here since sv_clean_all might release some PMOPs
 914          * after PL_regex_padav has been cleared
 915          * and the clearing of PL_regex_padav needs to
 916          * happen before sv_clean_all
 917          */
 918 #ifdef USE_ITHREADS
 919         if(PL_regex_pad) {        /* We could be in destruction */
 920             const IV offset = (cPMOPo)->op_pmoffset;
 921             ReREFCNT_dec(PM_GETRE(cPMOPo));
 922             PL_regex_pad[offset] = &PL_sv_undef;
 923             sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
 924                            sizeof(offset));
 925         }
 926 #else
 927         ReREFCNT_dec(PM_GETRE(cPMOPo));
 928         PM_SETRE(cPMOPo, NULL);
 929 #endif
 930
 931         break;
 932     }
 933
 934     if (o->op_targ > 0) {
 935         pad_free(o->op_targ);
 936         o->op_targ = 0;
 937     }
 938 }
 939
 940 STATIC void
 941 S_cop_free(pTHX_ COP* cop)
 942 {
 943     PERL_ARGS_ASSERT_COP_FREE;
 944
 945     CopFILE_free(cop);
 946     if (! specialWARN(cop->cop_warnings))
 947         PerlMemShared_free(cop->cop_warnings);
 948     cophh_free(CopHINTHASH_get(cop));
 949     if (PL_curcop == cop)
 950        PL_curcop = NULL;
 951 }
 952
 953 STATIC void
 954 S_forget_pmop(pTHX_ PMOP *const o
 955               )
 956 {
 957     HV * const pmstash = PmopSTASH(o);
 958
 959     PERL_ARGS_ASSERT_FORGET_PMOP;
 960
 961     if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
 962         MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
 963         if (mg) {
 964             PMOP **const array = (PMOP**) mg->mg_ptr;
 965             U32 count = mg->mg_len / sizeof(PMOP**);
 966             U32 i = count;
 967
 968             while (i--) {
 969                 if (array[i] == o) {
 970                     /* Found it. Move the entry at the end to overwrite it.  */
 971                     array[i] = array[--count];
 972                     mg->mg_len = count * sizeof(PMOP**);
 973                     /* Could realloc smaller at this point always, but probably
 974                        not worth it. Probably worth free()ing if we're the
 975                        last.  */
 976                     if(!count) {
 977                         Safefree(mg->mg_ptr);
 978                         mg->mg_ptr = NULL;
 979                     }
 980                     break;
 981                 }
 982             }
 983         }
 984     }
 985     if (PL_curpm == o)
 986         PL_curpm = NULL;
 987 }
 988
 989 STATIC void
 990 S_find_and_forget_pmops(pTHX_ OP *o)
 991 {
 992     PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
 993
 994     if (o->op_flags & OPf_KIDS) {
 995         OP *kid = cUNOPo->op_first;
 996         while (kid) {
 997             switch (kid->op_type) {
 998             case OP_SUBST:
 999             case OP_PUSHRE:
1000             case OP_MATCH:
1001             case OP_QR:
1002                 forget_pmop((PMOP*)kid);
1003             }
1004             find_and_forget_pmops(kid);
1005             kid = kid->op_sibling;
1006         }
1007     }
1008 }
1009
1010 /*
1011 =for apidoc Am|void|op_null|OP *o
1012
1013 Neutralizes an op when it is no longer needed, but is still linked to from
1014 other ops.
1015
1016 =cut
1017 */
1018
1019 void
1020 Perl_op_null(pTHX_ OP *o)
1021 {
1022     dVAR;
1023
1024     PERL_ARGS_ASSERT_OP_NULL;
1025
1026     if (o->op_type == OP_NULL)
1027         return;
1028     op_clear(o);
1029     o->op_targ = o->op_type;
1030     o->op_type = OP_NULL;
1031     o->op_ppaddr = PL_ppaddr[OP_NULL];
1032 }
1033
1034 void
1035 Perl_op_refcnt_lock(pTHX)
1036 {
1037     dVAR;
1038     PERL_UNUSED_CONTEXT;
1039     OP_REFCNT_LOCK;
1040 }
1041
1042 void
1043 Perl_op_refcnt_unlock(pTHX)
1044 {
1045     dVAR;
1046     PERL_UNUSED_CONTEXT;
1047     OP_REFCNT_UNLOCK;
1048 }
1049
1050 /* Contextualizers */
1051
1052 /*
1053 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1054
1055 Applies a syntactic context to an op tree representing an expression.
1056 I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
1057 or C<G_VOID> to specify the context to apply.  The modified op tree
1058 is returned.
1059
1060 =cut
1061 */
1062
1063 OP *
1064 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1065 {
1066     PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1067     switch (context) {
1068         case G_SCALAR: return scalar(o);
1069         case G_ARRAY:  return list(o);
1070         case G_VOID:   return scalarvoid(o);
1071         default:
1072             Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1073                        (long) context);
1074     }
1075 }
1076
1077 /*
1078
1079 =for apidoc Am|OP*|op_linklist|OP *o
1080 This function is the implementation of the L</LINKLIST> macro.  It should
1081 not be called directly.
1082
1083 =cut
1084 */
1085
1086 OP *
1087 Perl_op_linklist(pTHX_ OP *o)
1088 {
1089     OP *first;
1090
1091     PERL_ARGS_ASSERT_OP_LINKLIST;
1092
1093     if (o->op_next)
1094         return o->op_next;
1095
1096     /* establish postfix order */
1097     first = cUNOPo->op_first;
1098     if (first) {
1099         OP *kid;
1100         o->op_next = LINKLIST(first);
1101         kid = first;
1102         for (;;) {
1103             if (kid->op_sibling) {
1104                 kid->op_next = LINKLIST(kid->op_sibling);
1105                 kid = kid->op_sibling;
1106             } else {
1107                 kid->op_next = o;
1108                 break;
1109             }
1110         }
1111     }
1112     else
1113         o->op_next = o;
1114
1115     return o->op_next;
1116 }
1117
1118 static OP *
1119 S_scalarkids(pTHX_ OP *o)
1120 {
1121     if (o && o->op_flags & OPf_KIDS) {
1122         OP *kid;
1123         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1124             scalar(kid);
1125     }
1126     return o;
1127 }
1128
1129 STATIC OP *
1130 S_scalarboolean(pTHX_ OP *o)
1131 {
1132     dVAR;
1133
1134     PERL_ARGS_ASSERT_SCALARBOOLEAN;
1135
1136     if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
1137      && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
1138         if (ckWARN(WARN_SYNTAX)) {
1139             const line_t oldline = CopLINE(PL_curcop);
1140
1141             if (PL_parser && PL_parser->copline != NOLINE) {
1142                 /* This ensures that warnings are reported at the first line
1143                    of the conditional, not the last.  */
1144                 CopLINE_set(PL_curcop, PL_parser->copline);
1145             }
1146             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1147             CopLINE_set(PL_curcop, oldline);
1148         }
1149     }
1150     return scalar(o);
1151 }
1152
1153 static SV *
1154 S_op_varname(pTHX_ const OP *o)
1155 {
1156     assert(o);
1157     assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1158            o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1159     {
1160         const char funny  = o->op_type == OP_PADAV
1161                          || o->op_type == OP_RV2AV ? '@' : '%';
1162         if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1163             GV *gv;
1164             if (cUNOPo->op_first->op_type != OP_GV
1165              || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1166                 return NULL;
1167             return varname(gv, funny, 0, NULL, 0, 1);
1168         }
1169         return
1170             varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, 1);
1171     }
1172 }
1173
1174 static void
1175 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1176 { /* or not so pretty :-) */
1177     if (o->op_type == OP_CONST) {
1178         *retsv = cSVOPo_sv;
1179         if (SvPOK(*retsv)) {
1180             SV *sv = *retsv;
1181             *retsv = sv_newmortal();
1182             pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1183                       PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1184         }
1185         else if (!SvOK(*retsv))
1186             *retpv = "undef";
1187     }
1188     else *retpv = "...";
1189 }
1190
1191 static void
1192 S_scalar_slice_warning(pTHX_ const OP *o)
1193 {
1194     OP *kid;
1195     const char lbrack =
1196         o->op_type == OP_HSLICE ? '{' : '[';
1197     const char rbrack =
1198         o->op_type == OP_HSLICE ? '}' : ']';
1199     SV *name;
1200     SV *keysv = NULL; /* just to silence compiler warnings */
1201     const char *key = NULL;
1202
1203     if (!(o->op_private & OPpSLICEWARNING))
1204         return;
1205     if (PL_parser && PL_parser->error_count)
1206         /* This warning can be nonsensical when there is a syntax error. */
1207         return;
1208
1209     kid = cLISTOPo->op_first;
1210     kid = kid->op_sibling; /* get past pushmark */
1211     /* weed out false positives: any ops that can return lists */
1212     switch (kid->op_type) {
1213     case OP_BACKTICK:
1214     case OP_GLOB:
1215     case OP_READLINE:
1216     case OP_MATCH:
1217     case OP_RV2AV:
1218     case OP_EACH:
1219     case OP_VALUES:
1220     case OP_KEYS:
1221     case OP_SPLIT:
1222     case OP_LIST:
1223     case OP_SORT:
1224     case OP_REVERSE:
1225     case OP_ENTERSUB:
1226     case OP_CALLER:
1227     case OP_LSTAT:
1228     case OP_STAT:
1229     case OP_READDIR:
1230     case OP_SYSTEM:
1231     case OP_TMS:
1232     case OP_LOCALTIME:
1233     case OP_GMTIME:
1234     case OP_ENTEREVAL:
1235     case OP_REACH:
1236     case OP_RKEYS:
1237     case OP_RVALUES:
1238         return;
1239     }
1240
1241     /* Don't warn if we have a nulled list either. */
1242     if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1243         return;
1244
1245     assert(kid->op_sibling);
1246     name = S_op_varname(aTHX_ kid->op_sibling);
1247     if (!name) /* XS module fiddling with the op tree */
1248         return;
1249     S_op_pretty(aTHX_ kid, &keysv, &key);
1250     assert(SvPOK(name));
1251     sv_chop(name,SvPVX(name)+1);
1252     if (key)
1253        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1254         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1255                    "Scalar value @%"SVf"%c%s%c better written as $%"SVf
1256                    "%c%s%c",
1257                     SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1258                     lbrack, key, rbrack);
1259     else
1260        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1261         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1262                    "Scalar value @%"SVf"%c%"SVf"%c better written as $%"
1263                     SVf"%c%"SVf"%c",
1264                     SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1265                     SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1266 }
1267
1268 OP *
1269 Perl_scalar(pTHX_ OP *o)
1270 {
1271     dVAR;
1272     OP *kid;
1273
1274     /* assumes no premature commitment */
1275     if (!o || (PL_parser && PL_parser->error_count)
1276          || (o->op_flags & OPf_WANT)
1277          || o->op_type == OP_RETURN)
1278     {
1279         return o;
1280     }
1281
1282     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1283
1284     switch (o->op_type) {
1285     case OP_REPEAT:
1286         scalar(cBINOPo->op_first);
1287         break;
1288     case OP_OR:
1289     case OP_AND:
1290     case OP_COND_EXPR:
1291         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1292             scalar(kid);
1293         break;
1294         /* FALLTHROUGH */
1295     case OP_SPLIT:
1296     case OP_MATCH:
1297     case OP_QR:
1298     case OP_SUBST:
1299     case OP_NULL:
1300     default:
1301         if (o->op_flags & OPf_KIDS) {
1302             for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1303                 scalar(kid);
1304         }
1305         break;
1306     case OP_LEAVE:
1307     case OP_LEAVETRY:
1308         kid = cLISTOPo->op_first;
1309         scalar(kid);
1310         kid = kid->op_sibling;
1311     do_kids:
1312         while (kid) {
1313             OP *sib = kid->op_sibling;
1314             if (sib && kid->op_type != OP_LEAVEWHEN)
1315                 scalarvoid(kid);
1316             else
1317                 scalar(kid);
1318             kid = sib;
1319         }
1320         PL_curcop = &PL_compiling;
1321         break;
1322     case OP_SCOPE:
1323     case OP_LINESEQ:
1324     case OP_LIST:
1325         kid = cLISTOPo->op_first;
1326         goto do_kids;
1327     case OP_SORT:
1328         Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1329         break;
1330     case OP_KVHSLICE:
1331     case OP_KVASLICE:
1332     {
1333         /* Warn about scalar context */
1334         const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1335         const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1336         SV *name;
1337         SV *keysv;
1338         const char *key = NULL;
1339
1340         /* This warning can be nonsensical when there is a syntax error. */
1341         if (PL_parser && PL_parser->error_count)
1342             break;
1343
1344         if (!ckWARN(WARN_SYNTAX)) break;
1345
1346         kid = cLISTOPo->op_first;
1347         kid = kid->op_sibling; /* get past pushmark */
1348         assert(kid->op_sibling);
1349         name = S_op_varname(aTHX_ kid->op_sibling);
1350         if (!name) /* XS module fiddling with the op tree */
1351             break;
1352         S_op_pretty(aTHX_ kid, &keysv, &key);
1353         assert(SvPOK(name));
1354         sv_chop(name,SvPVX(name)+1);
1355         if (key)
1356   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1357             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1358                        "%%%"SVf"%c%s%c in scalar context better written "
1359                        "as $%"SVf"%c%s%c",
1360                         SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1361                         lbrack, key, rbrack);
1362         else
1363   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1364             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1365                        "%%%"SVf"%c%"SVf"%c in scalar context better "
1366                        "written as $%"SVf"%c%"SVf"%c",
1367                         SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1368                         SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1369     }
1370     }
1371     return o;
1372 }
1373
1374 OP *
1375 Perl_scalarvoid(pTHX_ OP *o)
1376 {
1377     dVAR;
1378     OP *kid;
1379     SV *useless_sv = NULL;
1380     const char* useless = NULL;
1381     SV* sv;
1382     U8 want;
1383
1384     PERL_ARGS_ASSERT_SCALARVOID;
1385
1386     if (o->op_type == OP_NEXTSTATE
1387         || o->op_type == OP_DBSTATE
1388         || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1389                                       || o->op_targ == OP_DBSTATE)))
1390         PL_curcop = (COP*)o;            /* for warning below */
1391
1392     /* assumes no premature commitment */
1393     want = o->op_flags & OPf_WANT;
1394     if ((want && want != OPf_WANT_SCALAR)
1395          || (PL_parser && PL_parser->error_count)
1396          || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1397     {
1398         return o;
1399     }
1400
1401     if ((o->op_private & OPpTARGET_MY)
1402         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1403     {
1404         return scalar(o);                       /* As if inside SASSIGN */
1405     }
1406
1407     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1408
1409     switch (o->op_type) {
1410     default:
1411         if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1412             break;
1413         /* FALLTHROUGH */
1414     case OP_REPEAT:
1415         if (o->op_flags & OPf_STACKED)
1416             break;
1417         goto func_ops;
1418     case OP_SUBSTR:
1419         if (o->op_private == 4)
1420             break;
1421         /* FALLTHROUGH */
1422     case OP_GVSV:
1423     case OP_WANTARRAY:
1424     case OP_GV:
1425     case OP_SMARTMATCH:
1426     case OP_PADSV:
1427     case OP_PADAV:
1428     case OP_PADHV:
1429     case OP_PADANY:
1430     case OP_AV2ARYLEN:
1431     case OP_REF:
1432     case OP_REFGEN:
1433     case OP_SREFGEN:
1434     case OP_DEFINED:
1435     case OP_HEX:
1436     case OP_OCT:
1437     case OP_LENGTH:
1438     case OP_VEC:
1439     case OP_INDEX:
1440     case OP_RINDEX:
1441     case OP_SPRINTF:
1442     case OP_AELEM:
1443     case OP_AELEMFAST:
1444     case OP_AELEMFAST_LEX:
1445     case OP_ASLICE:
1446     case OP_KVASLICE:
1447     case OP_HELEM:
1448     case OP_HSLICE:
1449     case OP_KVHSLICE:
1450     case OP_UNPACK:
1451     case OP_PACK:
1452     case OP_JOIN:
1453     case OP_LSLICE:
1454     case OP_ANONLIST:
1455     case OP_ANONHASH:
1456     case OP_SORT:
1457     case OP_REVERSE:
1458     case OP_RANGE:
1459     case OP_FLIP:
1460     case OP_FLOP:
1461     case OP_CALLER:
1462     case OP_FILENO:
1463     case OP_EOF:
1464     case OP_TELL:
1465     case OP_GETSOCKNAME:
1466     case OP_GETPEERNAME:
1467     case OP_READLINK:
1468     case OP_TELLDIR:
1469     case OP_GETPPID:
1470     case OP_GETPGRP:
1471     case OP_GETPRIORITY:
1472     case OP_TIME:
1473     case OP_TMS:
1474     case OP_LOCALTIME:
1475     case OP_GMTIME:
1476     case OP_GHBYNAME:
1477     case OP_GHBYADDR:
1478     case OP_GHOSTENT:
1479     case OP_GNBYNAME:
1480     case OP_GNBYADDR:
1481     case OP_GNETENT:
1482     case OP_GPBYNAME:
1483     case OP_GPBYNUMBER:
1484     case OP_GPROTOENT:
1485     case OP_GSBYNAME:
1486     case OP_GSBYPORT:
1487     case OP_GSERVENT:
1488     case OP_GPWNAM:
1489     case OP_GPWUID:
1490     case OP_GGRNAM:
1491     case OP_GGRGID:
1492     case OP_GETLOGIN:
1493     case OP_PROTOTYPE:
1494     case OP_RUNCV:
1495       func_ops:
1496         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1497             /* Otherwise it's "Useless use of grep iterator" */
1498             useless = OP_DESC(o);
1499         break;
1500
1501     case OP_SPLIT:
1502         kid = cLISTOPo->op_first;
1503         if (kid && kid->op_type == OP_PUSHRE
1504 #ifdef USE_ITHREADS
1505                 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1506 #else
1507                 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1508 #endif
1509             useless = OP_DESC(o);
1510         break;
1511
1512     case OP_NOT:
1513        kid = cUNOPo->op_first;
1514        if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1515            kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1516                 goto func_ops;
1517        }
1518        useless = "negative pattern binding (!~)";
1519        break;
1520
1521     case OP_SUBST:
1522         if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1523             useless = "non-destructive substitution (s///r)";
1524         break;
1525
1526     case OP_TRANSR:
1527         useless = "non-destructive transliteration (tr///r)";
1528         break;
1529
1530     case OP_RV2GV:
1531     case OP_RV2SV:
1532     case OP_RV2AV:
1533     case OP_RV2HV:
1534         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1535                 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1536             useless = "a variable";
1537         break;
1538
1539     case OP_CONST:
1540         sv = cSVOPo_sv;
1541         if (cSVOPo->op_private & OPpCONST_STRICT)
1542             no_bareword_allowed(o);
1543         else {
1544             if (ckWARN(WARN_VOID)) {
1545                 /* don't warn on optimised away booleans, eg
1546                  * use constant Foo, 5; Foo || print; */
1547                 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1548                     useless = NULL;
1549                 /* the constants 0 and 1 are permitted as they are
1550                    conventionally used as dummies in constructs like
1551                         1 while some_condition_with_side_effects;  */
1552                 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1553                     useless = NULL;
1554                 else if (SvPOK(sv)) {
1555                     SV * const dsv = newSVpvs("");
1556                     useless_sv
1557                         = Perl_newSVpvf(aTHX_
1558                                         "a constant (%s)",
1559                                         pv_pretty(dsv, SvPVX_const(sv),
1560                                                   SvCUR(sv), 32, NULL, NULL,
1561                                                   PERL_PV_PRETTY_DUMP
1562                                                   | PERL_PV_ESCAPE_NOCLEAR
1563                                                   | PERL_PV_ESCAPE_UNI_DETECT));
1564                     SvREFCNT_dec_NN(dsv);
1565                 }
1566                 else if (SvOK(sv)) {
1567                     useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", SVfARG(sv));
1568                 }
1569                 else
1570                     useless = "a constant (undef)";
1571             }
1572         }
1573         op_null(o);             /* don't execute or even remember it */
1574         break;
1575
1576     case OP_POSTINC:
1577         o->op_type = OP_PREINC;         /* pre-increment is faster */
1578         o->op_ppaddr = PL_ppaddr[OP_PREINC];
1579         break;
1580
1581     case OP_POSTDEC:
1582         o->op_type = OP_PREDEC;         /* pre-decrement is faster */
1583         o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1584         break;
1585
1586     case OP_I_POSTINC:
1587         o->op_type = OP_I_PREINC;       /* pre-increment is faster */
1588         o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1589         break;
1590
1591     case OP_I_POSTDEC:
1592         o->op_type = OP_I_PREDEC;       /* pre-decrement is faster */
1593         o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1594         break;
1595
1596     case OP_SASSIGN: {
1597         OP *rv2gv;
1598         UNOP *refgen, *rv2cv;
1599         LISTOP *exlist;
1600
1601         if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
1602             break;
1603
1604         rv2gv = ((BINOP *)o)->op_last;
1605         if (!rv2gv || rv2gv->op_type != OP_RV2GV)
1606             break;
1607
1608         refgen = (UNOP *)((BINOP *)o)->op_first;
1609
1610         if (!refgen || refgen->op_type != OP_REFGEN)
1611             break;
1612
1613         exlist = (LISTOP *)refgen->op_first;
1614         if (!exlist || exlist->op_type != OP_NULL
1615             || exlist->op_targ != OP_LIST)
1616             break;
1617
1618         if (exlist->op_first->op_type != OP_PUSHMARK)
1619             break;
1620
1621         rv2cv = (UNOP*)exlist->op_last;
1622
1623         if (rv2cv->op_type != OP_RV2CV)
1624             break;
1625
1626         assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
1627         assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
1628         assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
1629
1630         o->op_private |= OPpASSIGN_CV_TO_GV;
1631         rv2gv->op_private |= OPpDONT_INIT_GV;
1632         rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
1633
1634         break;
1635     }
1636
1637     case OP_AASSIGN: {
1638         inplace_aassign(o);
1639         break;
1640     }
1641
1642     case OP_OR:
1643     case OP_AND:
1644         kid = cLOGOPo->op_first;
1645         if (kid->op_type == OP_NOT
1646             && (kid->op_flags & OPf_KIDS)) {
1647             if (o->op_type == OP_AND) {
1648                 o->op_type = OP_OR;
1649                 o->op_ppaddr = PL_ppaddr[OP_OR];
1650             } else {
1651                 o->op_type = OP_AND;
1652                 o->op_ppaddr = PL_ppaddr[OP_AND];
1653             }
1654             op_null(kid);
1655         }
1656         /* FALLTHROUGH */
1657
1658     case OP_DOR:
1659     case OP_COND_EXPR:
1660     case OP_ENTERGIVEN:
1661     case OP_ENTERWHEN:
1662         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1663             scalarvoid(kid);
1664         break;
1665
1666     case OP_NULL:
1667         if (o->op_flags & OPf_STACKED)
1668             break;
1669         /* FALLTHROUGH */
1670     case OP_NEXTSTATE:
1671     case OP_DBSTATE:
1672     case OP_ENTERTRY:
1673     case OP_ENTER:
1674         if (!(o->op_flags & OPf_KIDS))
1675             break;
1676         /* FALLTHROUGH */
1677     case OP_SCOPE:
1678     case OP_LEAVE:
1679     case OP_LEAVETRY:
1680     case OP_LEAVELOOP:
1681     case OP_LINESEQ:
1682     case OP_LIST:
1683     case OP_LEAVEGIVEN:
1684     case OP_LEAVEWHEN:
1685         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1686             scalarvoid(kid);
1687         break;
1688     case OP_ENTEREVAL:
1689         scalarkids(o);
1690         break;
1691     case OP_SCALAR:
1692         return scalar(o);
1693     }
1694
1695     if (useless_sv) {
1696         /* mortalise it, in case warnings are fatal.  */
1697         Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1698                        "Useless use of %"SVf" in void context",
1699                        SVfARG(sv_2mortal(useless_sv)));
1700     }
1701     else if (useless) {
1702        Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1703                       "Useless use of %s in void context",
1704                       useless);
1705     }
1706     return o;
1707 }
1708
1709 static OP *
1710 S_listkids(pTHX_ OP *o)
1711 {
1712     if (o && o->op_flags & OPf_KIDS) {
1713         OP *kid;
1714         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1715             list(kid);
1716     }
1717     return o;
1718 }
1719
1720 OP *
1721 Perl_list(pTHX_ OP *o)
1722 {
1723     dVAR;
1724     OP *kid;
1725
1726     /* assumes no premature commitment */
1727     if (!o || (o->op_flags & OPf_WANT)
1728          || (PL_parser && PL_parser->error_count)
1729          || o->op_type == OP_RETURN)
1730     {
1731         return o;
1732     }
1733
1734     if ((o->op_private & OPpTARGET_MY)
1735         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1736     {
1737         return o;                               /* As if inside SASSIGN */
1738     }
1739
1740     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1741
1742     switch (o->op_type) {
1743     case OP_FLOP:
1744     case OP_REPEAT:
1745         list(cBINOPo->op_first);
1746         break;
1747     case OP_OR:
1748     case OP_AND:
1749     case OP_COND_EXPR:
1750         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1751             list(kid);
1752         break;
1753     default:
1754     case OP_MATCH:
1755     case OP_QR:
1756     case OP_SUBST:
1757     case OP_NULL:
1758         if (!(o->op_flags & OPf_KIDS))
1759             break;
1760         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1761             list(cBINOPo->op_first);
1762             return gen_constant_list(o);
1763         }
1764     case OP_LIST:
1765         listkids(o);
1766         break;
1767     case OP_LEAVE:
1768     case OP_LEAVETRY:
1769         kid = cLISTOPo->op_first;
1770         list(kid);
1771         kid = kid->op_sibling;
1772     do_kids:
1773         while (kid) {
1774             OP *sib = kid->op_sibling;
1775             if (sib && kid->op_type != OP_LEAVEWHEN)
1776                 scalarvoid(kid);
1777             else
1778                 list(kid);
1779             kid = sib;
1780         }
1781         PL_curcop = &PL_compiling;
1782         break;
1783     case OP_SCOPE:
1784     case OP_LINESEQ:
1785         kid = cLISTOPo->op_first;
1786         goto do_kids;
1787     }
1788     return o;
1789 }
1790
1791 static OP *
1792 S_scalarseq(pTHX_ OP *o)
1793 {
1794     dVAR;
1795     if (o) {
1796         const OPCODE type = o->op_type;
1797
1798         if (type == OP_LINESEQ || type == OP_SCOPE ||
1799             type == OP_LEAVE || type == OP_LEAVETRY)
1800         {
1801             OP *kid;
1802             for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1803                 if (kid->op_sibling) {
1804                     scalarvoid(kid);
1805                 }
1806             }
1807             PL_curcop = &PL_compiling;
1808         }
1809         o->op_flags &= ~OPf_PARENS;
1810         if (PL_hints & HINT_BLOCK_SCOPE)
1811             o->op_flags |= OPf_PARENS;
1812     }
1813     else
1814         o = newOP(OP_STUB, 0);
1815     return o;
1816 }
1817
1818 STATIC OP *
1819 S_modkids(pTHX_ OP *o, I32 type)
1820 {
1821     if (o && o->op_flags & OPf_KIDS) {
1822         OP *kid;
1823         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1824             op_lvalue(kid, type);
1825     }
1826     return o;
1827 }
1828
1829 /*
1830 =for apidoc finalize_optree
1831
1832 This function finalizes the optree.  Should be called directly after
1833 the complete optree is built.  It does some additional
1834 checking which can't be done in the normal ck_xxx functions and makes
1835 the tree thread-safe.
1836
1837 =cut
1838 */
1839 void
1840 Perl_finalize_optree(pTHX_ OP* o)
1841 {
1842     PERL_ARGS_ASSERT_FINALIZE_OPTREE;
1843
1844     ENTER;
1845     SAVEVPTR(PL_curcop);
1846
1847     finalize_op(o);
1848
1849     LEAVE;
1850 }
1851
1852 STATIC void
1853 S_finalize_op(pTHX_ OP* o)
1854 {
1855     PERL_ARGS_ASSERT_FINALIZE_OP;
1856
1857
1858     switch (o->op_type) {
1859     case OP_NEXTSTATE:
1860     case OP_DBSTATE:
1861         PL_curcop = ((COP*)o);          /* for warnings */
1862         break;
1863     case OP_EXEC:
1864         if ( o->op_sibling
1865             && (o->op_sibling->op_type == OP_NEXTSTATE || o->op_sibling->op_type == OP_DBSTATE)
1866             && ckWARN(WARN_EXEC))
1867             {
1868                 if (o->op_sibling->op_sibling) {
1869                     const OPCODE type = o->op_sibling->op_sibling->op_type;
1870                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
1871                         const line_t oldline = CopLINE(PL_curcop);
1872                         CopLINE_set(PL_curcop, CopLINE((COP*)o->op_sibling));
1873                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
1874                             "Statement unlikely to be reached");
1875                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
1876                             "\t(Maybe you meant system() when you said exec()?)\n");
1877                         CopLINE_set(PL_curcop, oldline);
1878                     }
1879                 }
1880             }
1881         break;
1882
1883     case OP_GV:
1884         if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
1885             GV * const gv = cGVOPo_gv;
1886             if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
1887                 /* XXX could check prototype here instead of just carping */
1888                 SV * const sv = sv_newmortal();
1889                 gv_efullname3(sv, gv, NULL);
1890                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
1891                     "%"SVf"() called too early to check prototype",
1892                     SVfARG(sv));
1893             }
1894         }
1895         break;
1896
1897     case OP_CONST:
1898         if (cSVOPo->op_private & OPpCONST_STRICT)
1899             no_bareword_allowed(o);
1900         /* FALLTHROUGH */
1901 #ifdef USE_ITHREADS
1902     case OP_HINTSEVAL:
1903     case OP_METHOD_NAMED:
1904         /* Relocate sv to the pad for thread safety.
1905          * Despite being a "constant", the SV is written to,
1906          * for reference counts, sv_upgrade() etc. */
1907         if (cSVOPo->op_sv) {
1908             const PADOFFSET ix = pad_alloc(OP_CONST, SVf_READONLY);
1909             SvREFCNT_dec(PAD_SVl(ix));
1910             PAD_SETSV(ix, cSVOPo->op_sv);
1911             /* XXX I don't know how this isn't readonly already. */
1912             if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
1913             cSVOPo->op_sv = NULL;
1914             o->op_targ = ix;
1915         }
1916 #endif
1917         break;
1918
1919     case OP_HELEM: {
1920         UNOP *rop;
1921         SV *lexname;
1922         GV **fields;
1923         SVOP *key_op;
1924         OP *kid;
1925         bool check_fields;
1926
1927         if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
1928             break;
1929
1930         rop = (UNOP*)((BINOP*)o)->op_first;
1931
1932         goto check_keys;
1933
1934     case OP_HSLICE:
1935         S_scalar_slice_warning(aTHX_ o);
1936         /* FALLTHROUGH */
1937
1938     case OP_KVHSLICE:
1939         kid = cLISTOPo->op_first->op_sibling;
1940         if (/* I bet there's always a pushmark... */
1941             OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
1942             && OP_TYPE_ISNT_NN(kid, OP_CONST))
1943         {
1944             break;
1945         }
1946
1947         key_op = (SVOP*)(kid->op_type == OP_CONST
1948                                 ? kid
1949                                 : kLISTOP->op_first->op_sibling);
1950
1951         rop = (UNOP*)((LISTOP*)o)->op_last;
1952
1953       check_keys:
1954         if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
1955             rop = NULL;
1956         else if (rop->op_first->op_type == OP_PADSV)
1957             /* @$hash{qw(keys here)} */
1958             rop = (UNOP*)rop->op_first;
1959         else {
1960             /* @{$hash}{qw(keys here)} */
1961             if (rop->op_first->op_type == OP_SCOPE
1962                 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
1963                 {
1964                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
1965                 }
1966             else
1967                 rop = NULL;
1968         }
1969
1970         lexname = NULL; /* just to silence compiler warnings */
1971         fields  = NULL; /* just to silence compiler warnings */
1972
1973         check_fields =
1974             rop
1975          && (lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE),
1976              SvPAD_TYPED(lexname))
1977          && (fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE))
1978          && isGV(*fields) && GvHV(*fields);
1979         for (; key_op;
1980              key_op = (SVOP*)key_op->op_sibling) {
1981             SV **svp, *sv;
1982             if (key_op->op_type != OP_CONST)
1983                 continue;
1984             svp = cSVOPx_svp(key_op);
1985
1986             /* Make the CONST have a shared SV */
1987             if ((!SvIsCOW_shared_hash(sv = *svp))
1988              && SvTYPE(sv) < SVt_PVMG && SvOK(sv) && !SvROK(sv)) {
1989                 SSize_t keylen;
1990                 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
1991                 SV *nsv = newSVpvn_share(key,
1992                                          SvUTF8(sv) ? -keylen : keylen, 0);
1993                 SvREFCNT_dec_NN(sv);
1994                 *svp = nsv;
1995             }
1996
1997             if (check_fields
1998              && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0)) {
1999                 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
2000                            "in variable %"SVf" of type %"HEKf,
2001                       SVfARG(*svp), SVfARG(lexname),
2002                       HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
2003             }
2004         }
2005         break;
2006     }
2007     case OP_ASLICE:
2008         S_scalar_slice_warning(aTHX_ o);
2009         break;
2010
2011     case OP_SUBST: {
2012         if (cPMOPo->op_pmreplrootu.op_pmreplroot)
2013             finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
2014         break;
2015     }
2016     default:
2017         break;
2018     }
2019
2020     if (o->op_flags & OPf_KIDS) {
2021         OP *kid;
2022         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
2023             finalize_op(kid);
2024     }
2025 }
2026
2027 /*
2028 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
2029
2030 Propagate lvalue ("modifiable") context to an op and its children.
2031 I<type> represents the context type, roughly based on the type of op that
2032 would do the modifying, although C<local()> is represented by OP_NULL,
2033 because it has no op type of its own (it is signalled by a flag on
2034 the lvalue op).
2035
2036 This function detects things that can't be modified, such as C<$x+1>, and
2037 generates errors for them.  For example, C<$x+1 = 2> would cause it to be
2038 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
2039
2040 It also flags things that need to behave specially in an lvalue context,
2041 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
2042
2043 =cut
2044 */
2045
2046 static bool
2047 S_vivifies(const OPCODE type)
2048 {
2049     switch(type) {
2050     case OP_RV2AV:     case   OP_ASLICE:
2051     case OP_RV2HV:     case OP_KVASLICE:
2052     case OP_RV2SV:     case   OP_HSLICE:
2053     case OP_AELEMFAST: case OP_KVHSLICE:
2054     case OP_HELEM:
2055     case OP_AELEM:
2056         return 1;
2057     }
2058     return 0;
2059 }
2060
2061 OP *
2062 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
2063 {
2064     dVAR;
2065     OP *kid;
2066     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2067     int localize = -1;
2068
2069     if (!o || (PL_parser && PL_parser->error_count))
2070         return o;
2071
2072     if ((o->op_private & OPpTARGET_MY)
2073         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2074     {
2075         return o;
2076     }
2077
2078     assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2079
2080     if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2081
2082     switch (o->op_type) {
2083     case OP_UNDEF:
2084         PL_modcount++;
2085         return o;
2086     case OP_STUB:
2087         if ((o->op_flags & OPf_PARENS))
2088             break;
2089         goto nomod;
2090     case OP_ENTERSUB:
2091         if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
2092             !(o->op_flags & OPf_STACKED)) {
2093             o->op_type = OP_RV2CV;              /* entersub => rv2cv */
2094             /* Both ENTERSUB and RV2CV use this bit, but for different pur-
2095                poses, so we need it clear.  */
2096             o->op_private &= ~1;
2097             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2098             assert(cUNOPo->op_first->op_type == OP_NULL);
2099             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
2100             break;
2101         }
2102         else {                          /* lvalue subroutine call */
2103             o->op_private |= OPpLVAL_INTRO
2104                            |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
2105             PL_modcount = RETURN_UNLIMITED_NUMBER;
2106             if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
2107                 /* Potential lvalue context: */
2108                 o->op_private |= OPpENTERSUB_INARGS;
2109                 break;
2110             }
2111             else {                      /* Compile-time error message: */
2112                 OP *kid = cUNOPo->op_first;
2113                 CV *cv;
2114
2115                 if (kid->op_type != OP_PUSHMARK) {
2116                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2117                         Perl_croak(aTHX_
2118                                 "panic: unexpected lvalue entersub "
2119                                 "args: type/targ %ld:%"UVuf,
2120                                 (long)kid->op_type, (UV)kid->op_targ);
2121                     kid = kLISTOP->op_first;
2122                 }
2123                 while (kid->op_sibling)
2124                     kid = kid->op_sibling;
2125                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
2126                     break;      /* Postpone until runtime */
2127                 }
2128
2129                 kid = kUNOP->op_first;
2130                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2131                     kid = kUNOP->op_first;
2132                 if (kid->op_type == OP_NULL)
2133                     Perl_croak(aTHX_
2134                                "Unexpected constant lvalue entersub "
2135                                "entry via type/targ %ld:%"UVuf,
2136                                (long)kid->op_type, (UV)kid->op_targ);
2137                 if (kid->op_type != OP_GV) {
2138                     break;
2139                 }
2140
2141                 cv = GvCV(kGVOP_gv);
2142                 if (!cv)
2143                     break;
2144                 if (CvLVALUE(cv))
2145                     break;
2146             }
2147         }
2148         /* FALLTHROUGH */
2149     default:
2150       nomod:
2151         if (flags & OP_LVALUE_NO_CROAK) return NULL;
2152         /* grep, foreach, subcalls, refgen */
2153         if (type == OP_GREPSTART || type == OP_ENTERSUB
2154          || type == OP_REFGEN    || type == OP_LEAVESUBLV)
2155             break;
2156         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2157                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
2158                       ? "do block"
2159                       : (o->op_type == OP_ENTERSUB
2160                         ? "non-lvalue subroutine call"
2161                         : OP_DESC(o))),
2162                      type ? PL_op_desc[type] : "local"));
2163         return o;
2164
2165     case OP_PREINC:
2166     case OP_PREDEC:
2167     case OP_POW:
2168     case OP_MULTIPLY:
2169     case OP_DIVIDE:
2170     case OP_MODULO:
2171     case OP_REPEAT:
2172     case OP_ADD:
2173     case OP_SUBTRACT:
2174     case OP_CONCAT:
2175     case OP_LEFT_SHIFT:
2176     case OP_RIGHT_SHIFT:
2177     case OP_BIT_AND:
2178     case OP_BIT_XOR:
2179     case OP_BIT_OR:
2180     case OP_I_MULTIPLY:
2181     case OP_I_DIVIDE:
2182     case OP_I_MODULO:
2183     case OP_I_ADD:
2184     case OP_I_SUBTRACT:
2185         if (!(o->op_flags & OPf_STACKED))
2186             goto nomod;
2187         PL_modcount++;
2188         break;
2189
2190     case OP_COND_EXPR:
2191         localize = 1;
2192         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
2193             op_lvalue(kid, type);
2194         break;
2195
2196     case OP_RV2AV:
2197     case OP_RV2HV:
2198         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
2199            PL_modcount = RETURN_UNLIMITED_NUMBER;
2200             return o;           /* Treat \(@foo) like ordinary list. */
2201         }
2202         /* FALLTHROUGH */
2203     case OP_RV2GV:
2204         if (scalar_mod_type(o, type))
2205             goto nomod;
2206         ref(cUNOPo->op_first, o->op_type);
2207         /* FALLTHROUGH */
2208     case OP_ASLICE:
2209     case OP_HSLICE:
2210         localize = 1;
2211         /* FALLTHROUGH */
2212     case OP_AASSIGN:
2213         /* Do not apply the lvsub flag for rv2[ah]v in scalar context.  */
2214         if (type == OP_LEAVESUBLV && (
2215                 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
2216              || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2217            ))
2218             o->op_private |= OPpMAYBE_LVSUB;
2219         /* FALLTHROUGH */
2220     case OP_NEXTSTATE:
2221     case OP_DBSTATE:
2222        PL_modcount = RETURN_UNLIMITED_NUMBER;
2223         break;
2224     case OP_KVHSLICE:
2225     case OP_KVASLICE:
2226         if (type == OP_LEAVESUBLV)
2227             o->op_private |= OPpMAYBE_LVSUB;
2228         goto nomod;
2229     case OP_AV2ARYLEN:
2230         PL_hints |= HINT_BLOCK_SCOPE;
2231         if (type == OP_LEAVESUBLV)
2232             o->op_private |= OPpMAYBE_LVSUB;
2233         PL_modcount++;
2234         break;
2235     case OP_RV2SV:
2236         ref(cUNOPo->op_first, o->op_type);
2237         localize = 1;
2238         /* FALLTHROUGH */
2239     case OP_GV:
2240         PL_hints |= HINT_BLOCK_SCOPE;
2241         /* FALLTHROUGH */
2242     case OP_SASSIGN:
2243     case OP_ANDASSIGN:
2244     case OP_ORASSIGN:
2245     case OP_DORASSIGN:
2246         PL_modcount++;
2247         break;
2248
2249     case OP_AELEMFAST:
2250     case OP_AELEMFAST_LEX:
2251         localize = -1;
2252         PL_modcount++;
2253         break;
2254
2255     case OP_PADAV:
2256     case OP_PADHV:
2257        PL_modcount = RETURN_UNLIMITED_NUMBER;
2258         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
2259             return o;           /* Treat \(@foo) like ordinary list. */
2260         if (scalar_mod_type(o, type))
2261             goto nomod;
2262         if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2263           && type == OP_LEAVESUBLV)
2264             o->op_private |= OPpMAYBE_LVSUB;
2265         /* FALLTHROUGH */
2266     case OP_PADSV:
2267         PL_modcount++;
2268         if (!type) /* local() */
2269             Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
2270                  PAD_COMPNAME_SV(o->op_targ));
2271         break;
2272
2273     case OP_PUSHMARK:
2274         localize = 0;
2275         break;
2276
2277     case OP_KEYS:
2278     case OP_RKEYS:
2279         if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
2280             goto nomod;
2281         goto lvalue_func;
2282     case OP_SUBSTR:
2283         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
2284             goto nomod;
2285         /* FALLTHROUGH */
2286     case OP_POS:
2287     case OP_VEC:
2288       lvalue_func:
2289         if (type == OP_LEAVESUBLV)
2290             o->op_private |= OPpMAYBE_LVSUB;
2291         if (o->op_flags & OPf_KIDS)
2292             op_lvalue(cBINOPo->op_first->op_sibling, type);
2293         break;
2294
2295     case OP_AELEM:
2296     case OP_HELEM:
2297         ref(cBINOPo->op_first, o->op_type);
2298         if (type == OP_ENTERSUB &&
2299              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
2300             o->op_private |= OPpLVAL_DEFER;
2301         if (type == OP_LEAVESUBLV)
2302             o->op_private |= OPpMAYBE_LVSUB;
2303         localize = 1;
2304         PL_modcount++;
2305         break;
2306
2307     case OP_LEAVE:
2308     case OP_LEAVELOOP:
2309         o->op_private |= OPpLVALUE;
2310         /* FALLTHROUGH */
2311     case OP_SCOPE:
2312     case OP_ENTER:
2313     case OP_LINESEQ:
2314         localize = 0;
2315         if (o->op_flags & OPf_KIDS)
2316             op_lvalue(cLISTOPo->op_last, type);
2317         break;
2318
2319     case OP_NULL:
2320         localize = 0;
2321         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
2322             goto nomod;
2323         else if (!(o->op_flags & OPf_KIDS))
2324             break;
2325         if (o->op_targ != OP_LIST) {
2326             op_lvalue(cBINOPo->op_first, type);
2327             break;
2328         }
2329         /* FALLTHROUGH */
2330     case OP_LIST:
2331         localize = 0;
2332         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2333             /* elements might be in void context because the list is
2334                in scalar context or because they are attribute sub calls */
2335             if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
2336                 op_lvalue(kid, type);
2337         break;
2338
2339     case OP_RETURN:
2340         if (type != OP_LEAVESUBLV)
2341             goto nomod;
2342         break; /* op_lvalue()ing was handled by ck_return() */
2343
2344     case OP_COREARGS:
2345         return o;
2346
2347     case OP_AND:
2348     case OP_OR:
2349         if (type == OP_LEAVESUBLV
2350          || !S_vivifies(cLOGOPo->op_first->op_type))
2351             op_lvalue(cLOGOPo->op_first, type);
2352         if (type == OP_LEAVESUBLV
2353          || !S_vivifies(cLOGOPo->op_first->op_sibling->op_type))
2354             op_lvalue(cLOGOPo->op_first->op_sibling, type);
2355         goto nomod;
2356     }
2357
2358     /* [20011101.069] File test operators interpret OPf_REF to mean that
2359        their argument is a filehandle; thus \stat(".") should not set
2360        it. AMS 20011102 */
2361     if (type == OP_REFGEN &&
2362         PL_check[o->op_type] == Perl_ck_ftst)
2363         return o;
2364
2365     if (type != OP_LEAVESUBLV)
2366         o->op_flags |= OPf_MOD;
2367
2368     if (type == OP_AASSIGN || type == OP_SASSIGN)
2369         o->op_flags |= OPf_SPECIAL|OPf_REF;
2370     else if (!type) { /* local() */
2371         switch (localize) {
2372         case 1:
2373             o->op_private |= OPpLVAL_INTRO;
2374             o->op_flags &= ~OPf_SPECIAL;
2375             PL_hints |= HINT_BLOCK_SCOPE;
2376             break;
2377         case 0:
2378             break;
2379         case -1:
2380             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2381                            "Useless localization of %s", OP_DESC(o));
2382         }
2383     }
2384     else if (type != OP_GREPSTART && type != OP_ENTERSUB
2385              && type != OP_LEAVESUBLV)
2386         o->op_flags |= OPf_REF;
2387     return o;
2388 }
2389
2390 STATIC bool
2391 S_scalar_mod_type(const OP *o, I32 type)
2392 {
2393     switch (type) {
2394     case OP_POS:
2395     case OP_SASSIGN:
2396         if (o && o->op_type == OP_RV2GV)
2397             return FALSE;
2398         /* FALLTHROUGH */
2399     case OP_PREINC:
2400     case OP_PREDEC:
2401     case OP_POSTINC:
2402     case OP_POSTDEC:
2403     case OP_I_PREINC:
2404     case OP_I_PREDEC:
2405     case OP_I_POSTINC:
2406     case OP_I_POSTDEC:
2407     case OP_POW:
2408     case OP_MULTIPLY:
2409     case OP_DIVIDE:
2410     case OP_MODULO:
2411     case OP_REPEAT:
2412     case OP_ADD:
2413     case OP_SUBTRACT:
2414     case OP_I_MULTIPLY:
2415     case OP_I_DIVIDE:
2416     case OP_I_MODULO:
2417     case OP_I_ADD:
2418     case OP_I_SUBTRACT:
2419     case OP_LEFT_SHIFT:
2420     case OP_RIGHT_SHIFT:
2421     case OP_BIT_AND:
2422     case OP_BIT_XOR:
2423     case OP_BIT_OR:
2424     case OP_CONCAT:
2425     case OP_SUBST:
2426     case OP_TRANS:
2427     case OP_TRANSR:
2428     case OP_READ:
2429     case OP_SYSREAD:
2430     case OP_RECV:
2431     case OP_ANDASSIGN:
2432     case OP_ORASSIGN:
2433     case OP_DORASSIGN:
2434         return TRUE;
2435     default:
2436         return FALSE;
2437     }
2438 }
2439
2440 STATIC bool
2441 S_is_handle_constructor(const OP *o, I32 numargs)
2442 {
2443     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2444
2445     switch (o->op_type) {
2446     case OP_PIPE_OP:
2447     case OP_SOCKPAIR:
2448         if (numargs == 2)
2449             return TRUE;
2450         /* FALLTHROUGH */
2451     case OP_SYSOPEN:
2452     case OP_OPEN:
2453     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
2454     case OP_SOCKET:
2455     case OP_OPEN_DIR:
2456     case OP_ACCEPT:
2457         if (numargs == 1)
2458             return TRUE;
2459         /* FALLTHROUGH */
2460     default:
2461         return FALSE;
2462     }
2463 }
2464
2465 static OP *
2466 S_refkids(pTHX_ OP *o, I32 type)
2467 {
2468     if (o && o->op_flags & OPf_KIDS) {
2469         OP *kid;
2470         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2471             ref(kid, type);
2472     }
2473     return o;
2474 }
2475
2476 OP *
2477 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
2478 {
2479     dVAR;
2480     OP *kid;
2481
2482     PERL_ARGS_ASSERT_DOREF;
2483
2484     if (!o || (PL_parser && PL_parser->error_count))
2485         return o;
2486
2487     switch (o->op_type) {
2488     case OP_ENTERSUB:
2489         if ((type == OP_EXISTS || type == OP_DEFINED) &&
2490             !(o->op_flags & OPf_STACKED)) {
2491             o->op_type = OP_RV2CV;             /* entersub => rv2cv */
2492             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2493             assert(cUNOPo->op_first->op_type == OP_NULL);
2494             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
2495             o->op_flags |= OPf_SPECIAL;
2496             o->op_private &= ~1;
2497         }
2498         else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
2499             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2500                               : type == OP_RV2HV ? OPpDEREF_HV
2501                               : OPpDEREF_SV);
2502             o->op_flags |= OPf_MOD;
2503         }
2504
2505         break;
2506
2507     case OP_COND_EXPR:
2508         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
2509             doref(kid, type, set_op_ref);
2510         break;
2511     case OP_RV2SV:
2512         if (type == OP_DEFINED)
2513             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
2514         doref(cUNOPo->op_first, o->op_type, set_op_ref);
2515         /* FALLTHROUGH */
2516     case OP_PADSV:
2517         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2518             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2519                               : type == OP_RV2HV ? OPpDEREF_HV
2520                               : OPpDEREF_SV);
2521             o->op_flags |= OPf_MOD;
2522         }
2523         break;
2524
2525     case OP_RV2AV:
2526     case OP_RV2HV:
2527         if (set_op_ref)
2528             o->op_flags |= OPf_REF;
2529         /* FALLTHROUGH */
2530     case OP_RV2GV:
2531         if (type == OP_DEFINED)
2532             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
2533         doref(cUNOPo->op_first, o->op_type, set_op_ref);
2534         break;
2535
2536     case OP_PADAV:
2537     case OP_PADHV:
2538         if (set_op_ref)
2539             o->op_flags |= OPf_REF;
2540         break;
2541
2542     case OP_SCALAR:
2543     case OP_NULL:
2544         if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
2545             break;
2546         doref(cBINOPo->op_first, type, set_op_ref);
2547         break;
2548     case OP_AELEM:
2549     case OP_HELEM:
2550         doref(cBINOPo->op_first, o->op_type, set_op_ref);
2551         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2552             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2553                               : type == OP_RV2HV ? OPpDEREF_HV
2554                               : OPpDEREF_SV);
2555             o->op_flags |= OPf_MOD;
2556         }
2557         break;
2558
2559     case OP_SCOPE:
2560     case OP_LEAVE:
2561         set_op_ref = FALSE;
2562         /* FALLTHROUGH */
2563     case OP_ENTER:
2564     case OP_LIST:
2565         if (!(o->op_flags & OPf_KIDS))
2566             break;
2567         doref(cLISTOPo->op_last, type, set_op_ref);
2568         break;
2569     default:
2570         break;
2571     }
2572     return scalar(o);
2573
2574 }
2575
2576 STATIC OP *
2577 S_dup_attrlist(pTHX_ OP *o)
2578 {
2579     dVAR;
2580     OP *rop;
2581
2582     PERL_ARGS_ASSERT_DUP_ATTRLIST;
2583
2584     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
2585      * where the first kid is OP_PUSHMARK and the remaining ones
2586      * are OP_CONST.  We need to push the OP_CONST values.
2587      */
2588     if (o->op_type == OP_CONST)
2589         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
2590     else {
2591         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
2592         rop = NULL;
2593         for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2594             if (o->op_type == OP_CONST)
2595                 rop = op_append_elem(OP_LIST, rop,
2596                                   newSVOP(OP_CONST, o->op_flags,
2597                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
2598         }
2599     }
2600     return rop;
2601 }
2602
2603 STATIC void
2604 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
2605 {
2606     dVAR;
2607     SV * const stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2608
2609     PERL_ARGS_ASSERT_APPLY_ATTRS;
2610
2611     /* fake up C<use attributes $pkg,$rv,@attrs> */
2612
2613 #define ATTRSMODULE "attributes"
2614 #define ATTRSMODULE_PM "attributes.pm"
2615
2616     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2617                          newSVpvs(ATTRSMODULE),
2618                          NULL,
2619                          op_prepend_elem(OP_LIST,
2620                                       newSVOP(OP_CONST, 0, stashsv),
2621                                       op_prepend_elem(OP_LIST,
2622                                                    newSVOP(OP_CONST, 0,
2623                                                            newRV(target)),
2624                                                    dup_attrlist(attrs))));
2625 }
2626
2627 STATIC void
2628 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2629 {
2630     dVAR;
2631     OP *pack, *imop, *arg;
2632     SV *meth, *stashsv, **svp;
2633
2634     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2635
2636     if (!attrs)
2637         return;
2638
2639     assert(target->op_type == OP_PADSV ||
2640            target->op_type == OP_PADHV ||
2641            target->op_type == OP_PADAV);
2642
2643     /* Ensure that attributes.pm is loaded. */
2644     /* Don't force the C<use> if we don't need it. */
2645     svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2646     if (svp && *svp != &PL_sv_undef)
2647         NOOP;   /* already in %INC */
2648     else
2649         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2650                                newSVpvs(ATTRSMODULE), NULL);
2651
2652     /* Need package name for method call. */
2653     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2654
2655     /* Build up the real arg-list. */
2656     stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2657
2658     arg = newOP(OP_PADSV, 0);
2659     arg->op_targ = target->op_targ;
2660     arg = op_prepend_elem(OP_LIST,
2661                        newSVOP(OP_CONST, 0, stashsv),
2662                        op_prepend_elem(OP_LIST,
2663                                     newUNOP(OP_REFGEN, 0,
2664                                             op_lvalue(arg, OP_REFGEN)),
2665                                     dup_attrlist(attrs)));
2666
2667     /* Fake up a method call to import */
2668     meth = newSVpvs_share("import");
2669     imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2670                    op_append_elem(OP_LIST,
2671                                op_prepend_elem(OP_LIST, pack, list(arg)),
2672                                newSVOP(OP_METHOD_NAMED, 0, meth)));
2673
2674     /* Combine the ops. */
2675     *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
2676 }
2677
2678 /*
2679 =notfor apidoc apply_attrs_string
2680
2681 Attempts to apply a list of attributes specified by the C<attrstr> and
2682 C<len> arguments to the subroutine identified by the C<cv> argument which
2683 is expected to be associated with the package identified by the C<stashpv>
2684 argument (see L<attributes>).  It gets this wrong, though, in that it
2685 does not correctly identify the boundaries of the individual attribute
2686 specifications within C<attrstr>.  This is not really intended for the
2687 public API, but has to be listed here for systems such as AIX which
2688 need an explicit export list for symbols.  (It's called from XS code
2689 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
2690 to respect attribute syntax properly would be welcome.
2691
2692 =cut
2693 */
2694
2695 void
2696 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2697                         const char *attrstr, STRLEN len)
2698 {
2699     OP *attrs = NULL;
2700
2701     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2702
2703     if (!len) {
2704         len = strlen(attrstr);
2705     }
2706
2707     while (len) {
2708         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2709         if (len) {
2710             const char * const sstr = attrstr;
2711             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2712             attrs = op_append_elem(OP_LIST, attrs,
2713                                 newSVOP(OP_CONST, 0,
2714                                         newSVpvn(sstr, attrstr-sstr)));
2715         }
2716     }
2717
2718     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2719                      newSVpvs(ATTRSMODULE),
2720                      NULL, op_prepend_elem(OP_LIST,
2721                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2722                                   op_prepend_elem(OP_LIST,
2723                                                newSVOP(OP_CONST, 0,
2724                                                        newRV(MUTABLE_SV(cv))),
2725                                                attrs)));
2726 }
2727
2728 STATIC void
2729 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
2730 {
2731     OP *new_proto = NULL;
2732     STRLEN pvlen;
2733     char *pv;
2734     OP *o;
2735
2736     PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
2737
2738     if (!*attrs)
2739         return;
2740
2741     o = *attrs;
2742     if (o->op_type == OP_CONST) {
2743         pv = SvPV(cSVOPo_sv, pvlen);
2744         if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
2745             SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
2746             SV ** const tmpo = cSVOPx_svp(o);
2747             SvREFCNT_dec(cSVOPo_sv);
2748             *tmpo = tmpsv;
2749             new_proto = o;
2750             *attrs = NULL;
2751         }
2752     } else if (o->op_type == OP_LIST) {
2753         OP * lasto = NULL;
2754         assert(o->op_flags & OPf_KIDS);
2755         assert(cLISTOPo->op_first->op_type == OP_PUSHMARK);
2756         /* Counting on the first op to hit the lasto = o line */
2757         for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2758             if (o->op_type == OP_CONST) {
2759                 pv = SvPV(cSVOPo_sv, pvlen);
2760                 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
2761                     SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
2762                     SV ** const tmpo = cSVOPx_svp(o);
2763                     SvREFCNT_dec(cSVOPo_sv);
2764                     *tmpo = tmpsv;
2765                     if (new_proto && ckWARN(WARN_MISC)) {
2766                         STRLEN new_len;
2767                         const char * newp = SvPV(cSVOPo_sv, new_len);
2768                         Perl_warner(aTHX_ packWARN(WARN_MISC),
2769                             "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub",
2770                             UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
2771                         op_free(new_proto);
2772                     }
2773                     else if (new_proto)
2774                         op_free(new_proto);
2775                     new_proto = o;
2776                     lasto->op_sibling = o->op_sibling;
2777                     continue;
2778                 }
2779             }
2780             lasto = o;
2781         }
2782         /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
2783            would get pulled in with no real need */
2784         if (!cLISTOPx(*attrs)->op_first->op_sibling) {
2785             op_free(*attrs);
2786             *attrs = NULL;
2787         }
2788     }
2789
2790     if (new_proto) {
2791         SV *svname;
2792         if (isGV(name)) {
2793             svname = sv_newmortal();
2794             gv_efullname3(svname, name, NULL);
2795         }
2796         else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
2797             svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
2798         else
2799             svname = (SV *)name;
2800         if (ckWARN(WARN_ILLEGALPROTO))
2801             (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
2802         if (*proto && ckWARN(WARN_PROTOTYPE)) {
2803             STRLEN old_len, new_len;
2804             const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
2805             const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
2806
2807             Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
2808                 "Prototype '%"UTF8f"' overridden by attribute 'prototype(%"UTF8f")'"
2809                 " in %"SVf,
2810                 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
2811                 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
2812                 SVfARG(svname));
2813         }
2814         if (*proto)
2815             op_free(*proto);
2816         *proto = new_proto;
2817     }
2818 }
2819
2820 static void
2821 S_cant_declare(pTHX_ OP *o)
2822 {
2823     if (o->op_type == OP_NULL
2824      && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
2825         o = cUNOPo->op_first;
2826     yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2827                              o->op_type == OP_NULL
2828                                && o->op_flags & OPf_SPECIAL
2829                                  ? "do block"
2830                                  : OP_DESC(o),
2831                              PL_parser->in_my == KEY_our   ? "our"   :
2832                              PL_parser->in_my == KEY_state ? "state" :
2833                                                              "my"));
2834 }
2835
2836 STATIC OP *
2837 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2838 {
2839     dVAR;
2840     I32 type;
2841     const bool stately = PL_parser && PL_parser->in_my == KEY_state;
2842
2843     PERL_ARGS_ASSERT_MY_KID;
2844
2845     if (!o || (PL_parser && PL_parser->error_count))
2846         return o;
2847
2848     type = o->op_type;
2849
2850     if (type == OP_LIST) {
2851         OP *kid;
2852         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2853             my_kid(kid, attrs, imopsp);
2854         return o;
2855     } else if (type == OP_UNDEF || type == OP_STUB) {
2856         return o;
2857     } else if (type == OP_RV2SV ||      /* "our" declaration */
2858                type == OP_RV2AV ||
2859                type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2860         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2861             S_cant_declare(aTHX_ o);
2862         } else if (attrs) {
2863             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2864             assert(PL_parser);
2865             PL_parser->in_my = FALSE;
2866             PL_parser->in_my_stash = NULL;
2867             apply_attrs(GvSTASH(gv),
2868                         (type == OP_RV2SV ? GvSV(gv) :
2869                          type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2870                          type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2871                         attrs);
2872         }
2873         o->op_private |= OPpOUR_INTRO;
2874         return o;
2875     }
2876     else if (type != OP_PADSV &&
2877              type != OP_PADAV &&
2878              type != OP_PADHV &&
2879              type != OP_PUSHMARK)
2880     {
2881         S_cant_declare(aTHX_ o);
2882         return o;
2883     }
2884     else if (attrs && type != OP_PUSHMARK) {
2885         HV *stash;
2886
2887         assert(PL_parser);
2888         PL_parser->in_my = FALSE;
2889         PL_parser->in_my_stash = NULL;
2890
2891         /* check for C<my Dog $spot> when deciding package */
2892         stash = PAD_COMPNAME_TYPE(o->op_targ);
2893         if (!stash)
2894             stash = PL_curstash;
2895         apply_attrs_my(stash, o, attrs, imopsp);
2896     }
2897     o->op_flags |= OPf_MOD;
2898     o->op_private |= OPpLVAL_INTRO;
2899     if (stately)
2900         o->op_private |= OPpPAD_STATE;
2901     return o;
2902 }
2903
2904 OP *
2905 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2906 {
2907     dVAR;
2908     OP *rops;
2909     int maybe_scalar = 0;
2910
2911     PERL_ARGS_ASSERT_MY_ATTRS;
2912
2913 /* [perl #17376]: this appears to be premature, and results in code such as
2914    C< our(%x); > executing in list mode rather than void mode */
2915 #if 0
2916     if (o->op_flags & OPf_PARENS)
2917         list(o);
2918     else
2919         maybe_scalar = 1;
2920 #else
2921     maybe_scalar = 1;
2922 #endif
2923     if (attrs)
2924         SAVEFREEOP(attrs);
2925     rops = NULL;
2926     o = my_kid(o, attrs, &rops);
2927     if (rops) {
2928         if (maybe_scalar && o->op_type == OP_PADSV) {
2929             o = scalar(op_append_list(OP_LIST, rops, o));
2930             o->op_private |= OPpLVAL_INTRO;
2931         }
2932         else {
2933             /* The listop in rops might have a pushmark at the beginning,
2934                which will mess up list assignment. */
2935             LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
2936             if (rops->op_type == OP_LIST &&
2937                 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
2938             {
2939                 OP * const pushmark = lrops->op_first;
2940                 lrops->op_first = pushmark->op_sibling;
2941                 op_free(pushmark);
2942             }
2943             o = op_append_list(OP_LIST, o, rops);
2944         }
2945     }
2946     PL_parser->in_my = FALSE;
2947     PL_parser->in_my_stash = NULL;
2948     return o;
2949 }
2950
2951 OP *
2952 Perl_sawparens(pTHX_ OP *o)
2953 {
2954     PERL_UNUSED_CONTEXT;
2955     if (o)
2956         o->op_flags |= OPf_PARENS;
2957     return o;
2958 }
2959
2960 OP *
2961 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2962 {
2963     OP *o;
2964     bool ismatchop = 0;
2965     const OPCODE ltype = left->op_type;
2966     const OPCODE rtype = right->op_type;
2967
2968     PERL_ARGS_ASSERT_BIND_MATCH;
2969
2970     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2971           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2972     {
2973       const char * const desc
2974           = PL_op_desc[(
2975                           rtype == OP_SUBST || rtype == OP_TRANS
2976                        || rtype == OP_TRANSR
2977                        )
2978                        ? (int)rtype : OP_MATCH];
2979       const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
2980       SV * const name =
2981         S_op_varname(aTHX_ left);
2982       if (name)
2983         Perl_warner(aTHX_ packWARN(WARN_MISC),
2984              "Applying %s to %"SVf" will act on scalar(%"SVf")",
2985              desc, SVfARG(name), SVfARG(name));
2986       else {
2987         const char * const sample = (isary
2988              ? "@array" : "%hash");
2989         Perl_warner(aTHX_ packWARN(WARN_MISC),
2990              "Applying %s to %s will act on scalar(%s)",
2991              desc, sample, sample);
2992       }
2993     }
2994
2995     if (rtype == OP_CONST &&
2996         cSVOPx(right)->op_private & OPpCONST_BARE &&
2997         cSVOPx(right)->op_private & OPpCONST_STRICT)
2998     {
2999         no_bareword_allowed(right);
3000     }
3001
3002     /* !~ doesn't make sense with /r, so error on it for now */
3003     if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
3004         type == OP_NOT)
3005         /* diag_listed_as: Using !~ with %s doesn't make sense */
3006         yyerror("Using !~ with s///r doesn't make sense");
3007     if (rtype == OP_TRANSR && type == OP_NOT)
3008         /* diag_listed_as: Using !~ with %s doesn't make sense */
3009         yyerror("Using !~ with tr///r doesn't make sense");
3010
3011     ismatchop = (rtype == OP_MATCH ||
3012                  rtype == OP_SUBST ||
3013                  rtype == OP_TRANS || rtype == OP_TRANSR)
3014              && !(right->op_flags & OPf_SPECIAL);
3015     if (ismatchop && right->op_private & OPpTARGET_MY) {
3016         right->op_targ = 0;
3017         right->op_private &= ~OPpTARGET_MY;
3018     }
3019     if (!(right->op_flags & OPf_STACKED) && ismatchop) {
3020         OP *newleft;
3021
3022         right->op_flags |= OPf_STACKED;
3023         if (rtype != OP_MATCH && rtype != OP_TRANSR &&
3024             ! (rtype == OP_TRANS &&
3025                right->op_private & OPpTRANS_IDENTICAL) &&
3026             ! (rtype == OP_SUBST &&
3027                (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3028             newleft = op_lvalue(left, rtype);
3029         else
3030             newleft = left;
3031         if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
3032             o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
3033         else
3034             o = op_prepend_elem(rtype, scalar(newleft), right);
3035         if (type == OP_NOT)
3036             return newUNOP(OP_NOT, 0, scalar(o));
3037         return o;
3038     }
3039     else
3040         return bind_match(type, left,
3041                 pmruntime(newPMOP(OP_MATCH, 0), right, 0, 0));
3042 }
3043
3044 OP *
3045 Perl_invert(pTHX_ OP *o)
3046 {
3047     if (!o)
3048         return NULL;
3049     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
3050 }
3051
3052 /*
3053 =for apidoc Amx|OP *|op_scope|OP *o
3054
3055 Wraps up an op tree with some additional ops so that at runtime a dynamic
3056 scope will be created.  The original ops run in the new dynamic scope,
3057 and then, provided that they exit normally, the scope will be unwound.
3058 The additional ops used to create and unwind the dynamic scope will
3059 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
3060 instead if the ops are simple enough to not need the full dynamic scope
3061 structure.
3062
3063 =cut
3064 */
3065
3066 OP *
3067 Perl_op_scope(pTHX_ OP *o)
3068 {
3069     dVAR;
3070     if (o) {
3071         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
3072             o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
3073             o->op_type = OP_LEAVE;
3074             o->op_ppaddr = PL_ppaddr[OP_LEAVE];
3075         }
3076         else if (o->op_type == OP_LINESEQ) {
3077             OP *kid;
3078             o->op_type = OP_SCOPE;
3079             o->op_ppaddr = PL_ppaddr[OP_SCOPE];
3080             kid = ((LISTOP*)o)->op_first;
3081             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
3082                 op_null(kid);
3083
3084                 /* The following deals with things like 'do {1 for 1}' */
3085                 kid = kid->op_sibling;
3086                 if (kid &&
3087                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
3088                     op_null(kid);
3089             }
3090         }
3091         else
3092             o = newLISTOP(OP_SCOPE, 0, o, NULL);
3093     }
3094     return o;
3095 }
3096
3097 OP *
3098 Perl_op_unscope(pTHX_ OP *o)
3099 {
3100     if (o && o->op_type == OP_LINESEQ) {
3101         OP *kid = cLISTOPo->op_first;
3102         for(; kid; kid = kid->op_sibling)
3103             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
3104                 op_null(kid);
3105     }
3106     return o;
3107 }
3108
3109 int
3110 Perl_block_start(pTHX_ int full)
3111 {
3112     dVAR;
3113     const int retval = PL_savestack_ix;
3114
3115     pad_block_start(full);
3116     SAVEHINTS();
3117     PL_hints &= ~HINT_BLOCK_SCOPE;
3118     SAVECOMPILEWARNINGS();
3119     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
3120
3121     CALL_BLOCK_HOOKS(bhk_start, full);
3122
3123     return retval;
3124 }
3125
3126 OP*
3127 Perl_block_end(pTHX_ I32 floor, OP *seq)
3128 {
3129     dVAR;
3130     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
3131     OP* retval = scalarseq(seq);
3132     OP *o;
3133
3134     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
3135
3136     LEAVE_SCOPE(floor);
3137     if (needblockscope)
3138         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
3139     o = pad_leavemy();
3140
3141     if (o) {
3142         /* pad_leavemy has created a sequence of introcv ops for all my
3143            subs declared in the block.  We have to replicate that list with
3144            clonecv ops, to deal with this situation:
3145
3146                sub {
3147                    my sub s1;
3148                    my sub s2;
3149                    sub s1 { state sub foo { \&s2 } }
3150                }->()
3151
3152            Originally, I was going to have introcv clone the CV and turn
3153            off the stale flag.  Since &s1 is declared before &s2, the
3154            introcv op for &s1 is executed (on sub entry) before the one for
3155            &s2.  But the &foo sub inside &s1 (which is cloned when &s1 is
3156            cloned, since it is a state sub) closes over &s2 and expects
3157            to see it in its outer CV’s pad.  If the introcv op clones &s1,
3158            then &s2 is still marked stale.  Since &s1 is not active, and
3159            &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
3160            ble will not stay shared’ warning.  Because it is the same stub
3161            that will be used when the introcv op for &s2 is executed, clos-
3162            ing over it is safe.  Hence, we have to turn off the stale flag
3163            on all lexical subs in the block before we clone any of them.
3164            Hence, having introcv clone the sub cannot work.  So we create a
3165            list of ops like this:
3166
3167                lineseq
3168                   |
3169                   +-- introcv
3170                   |
3171                   +-- introcv
3172                   |
3173                   +-- introcv
3174                   |
3175                   .
3176                   .
3177                   .
3178                   |
3179                   +-- clonecv
3180                   |
3181                   +-- clonecv
3182                   |
3183                   +-- clonecv
3184                   |
3185                   .
3186                   .
3187                   .
3188          */
3189         OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
3190         OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
3191         for (;; kid = kid->op_sibling) {
3192             OP *newkid = newOP(OP_CLONECV, 0);
3193             newkid->op_targ = kid->op_targ;
3194             o = op_append_elem(OP_LINESEQ, o, newkid);
3195             if (kid == last) break;
3196         }
3197         retval = op_prepend_elem(OP_LINESEQ, o, retval);
3198     }
3199
3200     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
3201
3202     return retval;
3203 }
3204
3205 /*
3206 =head1 Compile-time scope hooks
3207
3208 =for apidoc Aox||blockhook_register
3209
3210 Register a set of hooks to be called when the Perl lexical scope changes
3211 at compile time.  See L<perlguts/"Compile-time scope hooks">.
3212
3213 =cut
3214 */
3215
3216 void
3217 Perl_blockhook_register(pTHX_ BHK *hk)
3218 {
3219     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
3220
3221     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
3222 }
3223
3224 STATIC OP *
3225 S_newDEFSVOP(pTHX)
3226 {
3227     dVAR;
3228     const PADOFFSET offset = pad_findmy_pvs("$_", 0);
3229     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
3230         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
3231     }
3232     else {
3233         OP * const o = newOP(OP_PADSV, 0);
3234         o->op_targ = offset;
3235         return o;
3236     }
3237 }
3238
3239 void
3240 Perl_newPROG(pTHX_ OP *o)
3241 {
3242     dVAR;
3243
3244     PERL_ARGS_ASSERT_NEWPROG;
3245
3246     if (PL_in_eval) {
3247         PERL_CONTEXT *cx;
3248         I32 i;
3249         if (PL_eval_root)
3250                 return;
3251         PL_eval_root = newUNOP(OP_LEAVEEVAL,
3252                                ((PL_in_eval & EVAL_KEEPERR)
3253                                 ? OPf_SPECIAL : 0), o);
3254
3255         cx = &cxstack[cxstack_ix];
3256         assert(CxTYPE(cx) == CXt_EVAL);
3257
3258         if ((cx->blk_gimme & G_WANT) == G_VOID)
3259             scalarvoid(PL_eval_root);
3260         else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
3261             list(PL_eval_root);
3262         else
3263             scalar(PL_eval_root);
3264
3265         PL_eval_start = op_linklist(PL_eval_root);
3266         PL_eval_root->op_private |= OPpREFCOUNTED;
3267         OpREFCNT_set(PL_eval_root, 1);
3268         PL_eval_root->op_next = 0;
3269         i = PL_savestack_ix;
3270         SAVEFREEOP(o);
3271         ENTER;
3272         CALL_PEEP(PL_eval_start);
3273         finalize_optree(PL_eval_root);
3274         S_prune_chain_head(&PL_eval_start);
3275         LEAVE;
3276         PL_savestack_ix = i;
3277     }
3278     else {
3279         if (o->op_type == OP_STUB) {
3280             /* This block is entered if nothing is compiled for the main
3281                program. This will be the case for an genuinely empty main
3282                program, or one which only has BEGIN blocks etc, so already
3283                run and freed.
3284
3285                Historically (5.000) the guard above was !o. However, commit
3286                f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
3287                c71fccf11fde0068, changed perly.y so that newPROG() is now
3288                called with the output of block_end(), which returns a new
3289                OP_STUB for the case of an empty optree. ByteLoader (and
3290                maybe other things) also take this path, because they set up
3291                PL_main_start and PL_main_root directly, without generating an
3292                optree.
3293
3294                If the parsing the main program aborts (due to parse errors,
3295                or due to BEGIN or similar calling exit), then newPROG()
3296                isn't even called, and hence this code path and its cleanups
3297                are skipped. This shouldn't make a make a difference:
3298                * a non-zero return from perl_parse is a failure, and
3299                  perl_destruct() should be called immediately.
3300                * however, if exit(0) is called during the parse, then
3301                  perl_parse() returns 0, and perl_run() is called. As
3302                  PL_main_start will be NULL, perl_run() will return
3303                  promptly, and the exit code will remain 0.
3304             */
3305
3306             PL_comppad_name = 0;
3307             PL_compcv = 0;
3308             S_op_destroy(aTHX_ o);
3309             return;
3310         }
3311         PL_main_root = op_scope(sawparens(scalarvoid(o)));
3312         PL_curcop = &PL_compiling;
3313         PL_main_start = LINKLIST(PL_main_root);
3314         PL_main_root->op_private |= OPpREFCOUNTED;
3315         OpREFCNT_set(PL_main_root, 1);
3316         PL_main_root->op_next = 0;
3317         CALL_PEEP(PL_main_start);
3318         finalize_optree(PL_main_root);
3319         S_prune_chain_head(&PL_main_start);
3320         cv_forget_slab(PL_compcv);
3321         PL_compcv = 0;
3322
3323         /* Register with debugger */
3324         if (PERLDB_INTER) {
3325             CV * const cv = get_cvs("DB::postponed", 0);
3326             if (cv) {
3327                 dSP;
3328                 PUSHMARK(SP);
3329                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3330                 PUTBACK;
3331                 call_sv(MUTABLE_SV(cv), G_DISCARD);
3332             }
3333         }
3334     }
3335 }
3336
3337 OP *
3338 Perl_localize(pTHX_ OP *o, I32 lex)
3339 {
3340     dVAR;
3341
3342     PERL_ARGS_ASSERT_LOCALIZE;
3343
3344     if (o->op_flags & OPf_PARENS)
3345 /* [perl #17376]: this appears to be premature, and results in code such as
3346    C< our(%x); > executing in list mode rather than void mode */
3347 #if 0
3348         list(o);
3349 #else
3350         NOOP;
3351 #endif
3352     else {
3353         if ( PL_parser->bufptr > PL_parser->oldbufptr
3354             && PL_parser->bufptr[-1] == ','
3355             && ckWARN(WARN_PARENTHESIS))
3356         {
3357             char *s = PL_parser->bufptr;
3358             bool sigil = FALSE;
3359
3360             /* some heuristics to detect a potential error */
3361             while (*s && (strchr(", \t\n", *s)))
3362                 s++;
3363
3364             while (1) {
3365                 if (*s && strchr("@$%*", *s) && *++s
3366                        && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
3367                     s++;
3368                     sigil = TRUE;
3369                     while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
3370                         s++;
3371                     while (*s && (strchr(", \t\n", *s)))
3372                         s++;
3373                 }
3374                 else
3375                     break;
3376             }
3377             if (sigil && (*s == ';' || *s == '=')) {
3378                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
3379                                 "Parentheses missing around \"%s\" list",
3380                                 lex
3381                                     ? (PL_parser->in_my == KEY_our
3382                                         ? "our"
3383                                         : PL_parser->in_my == KEY_state
3384                                             ? "state"
3385                                             : "my")
3386                                     : "local");
3387             }
3388         }
3389     }
3390     if (lex)
3391         o = my(o);
3392     else
3393         o = op_lvalue(o, OP_NULL);              /* a bit kludgey */
3394     PL_parser->in_my = FALSE;
3395     PL_parser->in_my_stash = NULL;
3396     return o;
3397 }
3398
3399 OP *
3400 Perl_jmaybe(pTHX_ OP *o)
3401 {
3402     PERL_ARGS_ASSERT_JMAYBE;
3403
3404     if (o->op_type == OP_LIST) {
3405         OP * const o2
3406             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
3407         o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
3408     }
3409     return o;
3410 }
3411
3412 PERL_STATIC_INLINE OP *
3413 S_op_std_init(pTHX_ OP *o)
3414 {
3415     I32 type = o->op_type;
3416
3417     PERL_ARGS_ASSERT_OP_STD_INIT;
3418
3419     if (PL_opargs[type] & OA_RETSCALAR)
3420         scalar(o);
3421     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
3422         o->op_targ = pad_alloc(type, SVs_PADTMP);
3423
3424     return o;
3425 }
3426
3427 PERL_STATIC_INLINE OP *
3428 S_op_integerize(pTHX_ OP *o)
3429 {
3430     I32 type = o->op_type;
3431
3432     PERL_ARGS_ASSERT_OP_INTEGERIZE;
3433
3434     /* integerize op. */
3435     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
3436     {
3437         dVAR;
3438         o->op_ppaddr = PL_ppaddr[++(o->op_type)];
3439     }
3440
3441     if (type == OP_NEGATE)
3442         /* XXX might want a ck_negate() for this */
3443         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
3444
3445     return o;
3446 }
3447
3448 static OP *
3449 S_fold_constants(pTHX_ OP *o)
3450 {
3451     dVAR;
3452     OP * VOL curop;
3453     OP *newop;
3454     VOL I32 type = o->op_type;
3455     SV * VOL sv = NULL;
3456     int ret = 0;
3457     I32 oldscope;
3458     OP *old_next;
3459     SV * const oldwarnhook = PL_warnhook;
3460     SV * const olddiehook  = PL_diehook;
3461     COP not_compiling;
3462     dJMPENV;
3463
3464     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
3465
3466     if (!(PL_opargs[type] & OA_FOLDCONST))
3467         goto nope;
3468
3469     switch (type) {
3470     case OP_UCFIRST:
3471     case OP_LCFIRST:
3472     case OP_UC:
3473     case OP_LC:
3474     case OP_FC:
3475 #ifdef USE_LOCALE_CTYPE
3476         if (IN_LC_COMPILETIME(LC_CTYPE))
3477             goto nope;
3478 #endif
3479         break;
3480     case OP_SLT:
3481     case OP_SGT:
3482     case OP_SLE:
3483     case OP_SGE:
3484     case OP_SCMP:
3485 #ifdef USE_LOCALE_COLLATE
3486         if (IN_LC_COMPILETIME(LC_COLLATE))
3487             goto nope;
3488 #endif
3489         break;
3490     case OP_SPRINTF:
3491         /* XXX what about the numeric ops? */
3492 #ifdef USE_LOCALE_NUMERIC
3493         if (IN_LC_COMPILETIME(LC_NUMERIC))
3494             goto nope;
3495 #endif
3496         break;
3497     case OP_PACK:
3498         if (!cLISTOPo->op_first->op_sibling
3499           || cLISTOPo->op_first->op_sibling->op_type != OP_CONST)
3500             goto nope;
3501         {
3502             SV * const sv = cSVOPx_sv(cLISTOPo->op_first->op_sibling);
3503             if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
3504             {
3505                 const char *s = SvPVX_const(sv);
3506                 while (s < SvEND(sv)) {
3507                     if (*s == 'p' || *s == 'P') goto nope;
3508                     s++;
3509                 }
3510             }
3511         }
3512         break;
3513     case OP_REPEAT:
3514         if (o->op_private & OPpREPEAT_DOLIST) goto nope;
3515         break;
3516     case OP_SREFGEN:
3517         if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
3518          || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
3519             goto nope;
3520     }
3521
3522     if (PL_parser && PL_parser->error_count)
3523         goto nope;              /* Don't try to run w/ errors */
3524
3525     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3526         const OPCODE type = curop->op_type;
3527         if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
3528             type != OP_LIST &&
3529             type != OP_SCALAR &&
3530             type != OP_NULL &&
3531             type != OP_PUSHMARK)
3532         {
3533             goto nope;
3534         }
3535     }
3536
3537     curop = LINKLIST(o);
3538     old_next = o->op_next;
3539     o->op_next = 0;
3540     PL_op = curop;
3541
3542     oldscope = PL_scopestack_ix;
3543     create_eval_scope(G_FAKINGEVAL);
3544
3545     /* Verify that we don't need to save it:  */
3546     assert(PL_curcop == &PL_compiling);
3547     StructCopy(&PL_compiling, &not_compiling, COP);
3548     PL_curcop = &not_compiling;
3549     /* The above ensures that we run with all the correct hints of the
3550        currently compiling COP, but that IN_PERL_RUNTIME is not true. */
3551     assert(IN_PERL_RUNTIME);
3552     PL_warnhook = PERL_WARNHOOK_FATAL;
3553     PL_diehook  = NULL;
3554     JMPENV_PUSH(ret);
3555
3556     switch (ret) {
3557     case 0:
3558         CALLRUNOPS(aTHX);
3559         sv = *(PL_stack_sp--);
3560         if (o->op_targ && sv == PAD_SV(o->op_targ)) {   /* grab pad temp? */
3561             pad_swipe(o->op_targ,  FALSE);
3562         }
3563         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
3564             SvREFCNT_inc_simple_void(sv);
3565             SvTEMP_off(sv);
3566         }
3567         else { assert(SvIMMORTAL(sv)); }
3568         break;
3569     case 3:
3570         /* Something tried to die.  Abandon constant folding.  */
3571         /* Pretend the error never happened.  */
3572         CLEAR_ERRSV();
3573         o->op_next = old_next;
3574         break;
3575     default:
3576         JMPENV_POP;
3577         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
3578         PL_warnhook = oldwarnhook;
3579         PL_diehook  = olddiehook;
3580         /* XXX note that this croak may fail as we've already blown away
3581          * the stack - eg any nested evals */
3582         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
3583     }
3584     JMPENV_POP;
3585     PL_warnhook = oldwarnhook;
3586     PL_diehook  = olddiehook;
3587     PL_curcop = &PL_compiling;
3588
3589     if (PL_scopestack_ix > oldscope)
3590         delete_eval_scope();
3591
3592     if (ret)
3593         goto nope;
3594
3595     op_free(o);
3596     assert(sv);
3597     if (type == OP_STRINGIFY) SvPADTMP_off(sv);
3598     else if (!SvIMMORTAL(sv)) {
3599         SvPADTMP_on(sv);
3600         SvREADONLY_on(sv);
3601     }
3602     if (type == OP_RV2GV)
3603         newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
3604     else
3605     {
3606         newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
3607         if (type != OP_STRINGIFY) newop->op_folded = 1;
3608     }
3609     return newop;
3610
3611  nope:
3612     return o;
3613 }
3614
3615 static OP *
3616 S_gen_constant_list(pTHX_ OP *o)
3617 {
3618     dVAR;
3619     OP *curop;
3620     const SSize_t oldtmps_floor = PL_tmps_floor;
3621     SV **svp;
3622     AV *av;
3623
3624     list(o);
3625     if (PL_parser && PL_parser->error_count)
3626         return o;               /* Don't attempt to run with errors */
3627
3628     curop = LINKLIST(o);
3629     o->op_next = 0;
3630     CALL_PEEP(curop);
3631     S_prune_chain_head(&curop);
3632     PL_op = curop;
3633     Perl_pp_pushmark(aTHX);
3634     CALLRUNOPS(aTHX);
3635     PL_op = curop;
3636     assert (!(curop->op_flags & OPf_SPECIAL));
3637     assert(curop->op_type == OP_RANGE);
3638     Perl_pp_anonlist(aTHX);
3639     PL_tmps_floor = oldtmps_floor;
3640
3641     o->op_type = OP_RV2AV;
3642     o->op_ppaddr = PL_ppaddr[OP_RV2AV];
3643     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
3644     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
3645     o->op_opt = 0;              /* needs to be revisited in rpeep() */
3646     curop = ((UNOP*)o)->op_first;
3647     av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
3648     ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, (SV *)av);
3649     if (AvFILLp(av) != -1)
3650         for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
3651         {
3652             SvPADTMP_on(*svp);
3653             SvREADONLY_on(*svp);
3654         }
3655     op_free(curop);
3656     LINKLIST(o);
3657     return list(o);
3658 }
3659
3660 OP *
3661 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
3662 {
3663     dVAR;
3664     if (type < 0) type = -type, flags |= OPf_SPECIAL;
3665     if (!o || o->op_type != OP_LIST)
3666         o = newLISTOP(OP_LIST, 0, o, NULL);
3667     else
3668         o->op_flags &= ~OPf_WANT;
3669
3670     if (!(PL_opargs[type] & OA_MARK))
3671         op_null(cLISTOPo->op_first);
3672     else {
3673         OP * const kid2 = cLISTOPo->op_first->op_sibling;
3674         if (kid2 && kid2->op_type == OP_COREARGS) {
3675             op_null(cLISTOPo->op_first);
3676             kid2->op_private |= OPpCOREARGS_PUSHMARK;
3677         }
3678     }
3679
3680     o->op_type = (OPCODE)type;
3681     o->op_ppaddr = PL_ppaddr[type];
3682     o->op_flags |= flags;
3683
3684     o = CHECKOP(type, o);
3685     if (o->op_type != (unsigned)type)
3686         return o;
3687
3688     return fold_constants(op_integerize(op_std_init(o)));
3689 }
3690
3691 /*
3692 =head1 Optree Manipulation Functions
3693 */
3694
3695 /* List constructors */
3696
3697 /*
3698 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
3699
3700 Append an item to the list of ops contained directly within a list-type
3701 op, returning the lengthened list.  I<first> is the list-type op,
3702 and I<last> is the op to append to the list.  I<optype> specifies the
3703 intended opcode for the list.  If I<first> is not already a list of the
3704 right type, it will be upgraded into one.  If either I<first> or I<last>
3705 is null, the other is returned unchanged.
3706
3707 =cut
3708 */
3709
3710 OP *
3711 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
3712 {
3713     if (!first)
3714         return last;
3715
3716     if (!last)
3717         return first;
3718
3719     if (first->op_type != (unsigned)type
3720         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
3721     {
3722         return newLISTOP(type, 0, first, last);
3723     }
3724
3725     if (first->op_flags & OPf_KIDS)
3726         ((LISTOP*)first)->op_last->op_sibling = last;
3727     else {
3728         first->op_flags |= OPf_KIDS;
3729         ((LISTOP*)first)->op_first = last;
3730     }
3731     ((LISTOP*)first)->op_last = last;
3732     return first;
3733 }
3734
3735 /*
3736 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
3737
3738 Concatenate the lists of ops contained directly within two list-type ops,
3739 returning the combined list.  I<first> and I<last> are the list-type ops
3740 to concatenate.  I<optype> specifies the intended opcode for the list.
3741 If either I<first> or I<last> is not already a list of the right type,
3742 it will be upgraded into one.  If either I<first> or I<last> is null,
3743 the other is returned unchanged.
3744
3745 =cut
3746 */
3747
3748 OP *
3749 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
3750 {
3751     if (!first)
3752         return last;
3753
3754     if (!last)
3755         return first;
3756
3757     if (first->op_type != (unsigned)type)
3758         return op_prepend_elem(type, first, last);
3759
3760     if (last->op_type != (unsigned)type)
3761         return op_append_elem(type, first, last);
3762
3763     ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
3764     ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
3765     first->op_flags |= (last->op_flags & OPf_KIDS);
3766
3767
3768     S_op_destroy(aTHX_ last);
3769
3770     return first;
3771 }
3772
3773 /*
3774 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
3775
3776 Prepend an item to the list of ops contained directly within a list-type
3777 op, returning the lengthened list.  I<first> is the op to prepend to the
3778 list, and I<last> is the list-type op.  I<optype> specifies the intended
3779 opcode for the list.  If I<last> is not already a list of the right type,
3780 it will be upgraded into one.  If either I<first> or I<last> is null,
3781 the other is returned unchanged.
3782
3783 =cut
3784 */
3785
3786 OP *
3787 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
3788 {
3789     if (!first)
3790         return last;
3791
3792     if (!last)
3793         return first;
3794
3795     if (last->op_type == (unsigned)type) {
3796         if (type == OP_LIST) {  /* already a PUSHMARK there */
3797             first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
3798             ((LISTOP*)last)->op_first->op_sibling = first;
3799             if (!(first->op_flags & OPf_PARENS))
3800                 last->op_flags &= ~OPf_PARENS;
3801         }
3802         else {
3803             if (!(last->op_flags & OPf_KIDS)) {
3804                 ((LISTOP*)last)->op_last = first;
3805                 last->op_flags |= OPf_KIDS;
3806             }
3807             first->op_sibling = ((LISTOP*)last)->op_first;
3808             ((LISTOP*)last)->op_first = first;
3809         }
3810         last->op_flags |= OPf_KIDS;
3811         return last;
3812     }
3813
3814     return newLISTOP(type, 0, first, last);
3815 }
3816
3817 /* Constructors */
3818
3819
3820 /*
3821 =head1 Optree construction
3822
3823 =for apidoc Am|OP *|newNULLLIST
3824
3825 Constructs, checks, and returns a new C<stub> op, which represents an
3826 empty list expression.
3827
3828 =cut
3829 */
3830
3831 OP *
3832 Perl_newNULLLIST(pTHX)
3833 {
3834     return newOP(OP_STUB, 0);
3835 }
3836
3837 static OP *
3838 S_force_list(pTHX_ OP *o)
3839 {
3840     if (!o || o->op_type != OP_LIST)
3841         o = newLISTOP(OP_LIST, 0, o, NULL);
3842     op_null(o);
3843     return o;
3844 }
3845
3846 /*
3847 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3848
3849 Constructs, checks, and returns an op of any list type.  I<type> is
3850 the opcode.  I<flags> gives the eight bits of C<op_flags>, except that
3851 C<OPf_KIDS> will be set automatically if required.  I<first> and I<last>
3852 supply up to two ops to be direct children of the list op; they are
3853 consumed by this function and become part of the constructed op tree.
3854
3855 =cut
3856 */
3857
3858 OP *
3859 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3860 {
3861     dVAR;
3862     LISTOP *listop;
3863
3864     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3865
3866     NewOp(1101, listop, 1, LISTOP);
3867
3868     listop->op_type = (OPCODE)type;
3869     listop->op_ppaddr = PL_ppaddr[type];
3870     if (first || last)
3871         flags |= OPf_KIDS;
3872     listop->op_flags = (U8)flags;
3873
3874     if (!last && first)
3875         last = first;
3876     else if (!first && last)
3877         first = last;
3878     else if (first)
3879         first->op_sibling = last;
3880     listop->op_first = first;
3881     listop->op_last = last;
3882     if (type == OP_LIST) {
3883         OP* const pushop = newOP(OP_PUSHMARK, 0);
3884         pushop->op_sibling = first;
3885         listop->op_first = pushop;
3886         listop->op_flags |= OPf_KIDS;
3887         if (!last)
3888             listop->op_last = pushop;
3889     }
3890
3891     return CHECKOP(type, listop);
3892 }
3893
3894 /*
3895 =for apidoc Am|OP *|newOP|I32 type|I32 flags
3896
3897 Constructs, checks, and returns an op of any base type (any type that
3898 has no extra fields).  I<type> is the opcode.  I<flags> gives the
3899 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
3900 of C<op_private>.
3901
3902 =cut
3903 */
3904
3905 OP *
3906 Perl_newOP(pTHX_ I32 type, I32 flags)
3907 {
3908     dVAR;
3909     OP *o;
3910
3911     if (type == -OP_ENTEREVAL) {
3912         type = OP_ENTEREVAL;
3913         flags |= OPpEVAL_BYTES<<8;
3914     }
3915
3916     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3917         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3918         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3919         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3920
3921     NewOp(1101, o, 1, OP);
3922     o->op_type = (OPCODE)type;
3923     o->op_ppaddr = PL_ppaddr[type];
3924     o->op_flags = (U8)flags;
3925
3926     o->op_next = o;
3927     o->op_private = (U8)(0 | (flags >> 8));
3928     if (PL_opargs[type] & OA_RETSCALAR)
3929         scalar(o);
3930     if (PL_opargs[type] & OA_TARGET)
3931         o->op_targ = pad_alloc(type, SVs_PADTMP);
3932     return CHECKOP(type, o);
3933 }
3934
3935 /*
3936 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
3937
3938 Constructs, checks, and returns an op of any unary type.  I<type> is
3939 the opcode.  I<flags> gives the eight bits of C<op_flags>, except that
3940 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
3941 bits, the eight bits of C<op_private>, except that the bit with value 1
3942 is automatically set.  I<first> supplies an optional op to be the direct
3943 child of the unary op; it is consumed by this function and become part
3944 of the constructed op tree.
3945
3946 =cut
3947 */
3948
3949 OP *
3950 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3951 {
3952     dVAR;
3953     UNOP *unop;
3954
3955     if (type == -OP_ENTEREVAL) {
3956         type = OP_ENTEREVAL;
3957         flags |= OPpEVAL_BYTES<<8;
3958     }
3959
3960     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3961         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3962         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3963         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3964         || type == OP_SASSIGN
3965         || type == OP_ENTERTRY
3966         || type == OP_NULL );
3967
3968     if (!first)
3969         first = newOP(OP_STUB, 0);
3970     if (PL_opargs[type] & OA_MARK)
3971         first = force_list(first);
3972
3973     NewOp(1101, unop, 1, UNOP);
3974     unop->op_type = (OPCODE)type;
3975     unop->op_ppaddr = PL_ppaddr[type];
3976     unop->op_first = first;
3977     unop->op_flags = (U8)(flags | OPf_KIDS);
3978     unop->op_private = (U8)(1 | (flags >> 8));
3979     unop = (UNOP*) CHECKOP(type, unop);
3980     if (unop->op_next)
3981         return (OP*)unop;
3982
3983     return fold_constants(op_integerize(op_std_init((OP *) unop)));
3984 }
3985
3986 /*
3987 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
3988
3989 Constructs, checks, and returns an op of any binary type.  I<type>
3990 is the opcode.  I<flags> gives the eight bits of C<op_flags>, except
3991 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
3992 the eight bits of C<op_private>, except that the bit with value 1 or
3993 2 is automatically set as required.  I<first> and I<last> supply up to
3994 two ops to be the direct children of the binary op; they are consumed
3995 by this function and become part of the constructed op tree.
3996
3997 =cut
3998 */
3999
4000 OP *
4001 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4002 {
4003     dVAR;
4004     BINOP *binop;
4005
4006     ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
4007         || type == OP_SASSIGN || type == OP_NULL );
4008
4009     NewOp(1101, binop, 1, BINOP);
4010
4011     if (!first)
4012         first = newOP(OP_NULL, 0);
4013
4014     binop->op_type = (OPCODE)type;
4015     binop->op_ppaddr = PL_ppaddr[type];
4016     binop->op_first = first;
4017     binop->op_flags = (U8)(flags | OPf_KIDS);
4018     if (!last) {
4019         last = first;
4020         binop->op_private = (U8)(1 | (flags >> 8));
4021     }
4022     else {
4023         binop->op_private = (U8)(2 | (flags >> 8));
4024         first->op_sibling = last;
4025     }
4026
4027     binop = (BINOP*)CHECKOP(type, binop);
4028     if (binop->op_next || binop->op_type != (OPCODE)type)
4029         return (OP*)binop;
4030
4031     binop->op_last = binop->op_first->op_sibling;
4032
4033     return fold_constants(op_integerize(op_std_init((OP *)binop)));
4034 }
4035
4036 static int uvcompare(const void *a, const void *b)
4037     __attribute__nonnull__(1)
4038     __attribute__nonnull__(2)
4039     __attribute__pure__;
4040 static int uvcompare(const void *a, const void *b)
4041 {
4042     if (*((const UV *)a) < (*(const UV *)b))
4043         return -1;
4044     if (*((const UV *)a) > (*(const UV *)b))
4045         return 1;
4046     if (*((const UV *)a+1) < (*(const UV *)b+1))
4047         return -1;
4048     if (*((const UV *)a+1) > (*(const UV *)b+1))
4049         return 1;
4050     return 0;
4051 }
4052
4053 static OP *
4054 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
4055 {
4056     dVAR;
4057     SV * const tstr = ((SVOP*)expr)->op_sv;
4058     SV * const rstr =
4059                               ((SVOP*)repl)->op_sv;
4060     STRLEN tlen;
4061     STRLEN rlen;
4062     const U8 *t = (U8*)SvPV_const(tstr, tlen);
4063     const U8 *r = (U8*)SvPV_const(rstr, rlen);
4064     I32 i;
4065     I32 j;
4066     I32 grows = 0;
4067     short *tbl;
4068
4069     const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
4070     const I32 squash     = o->op_private & OPpTRANS_SQUASH;
4071     I32 del              = o->op_private & OPpTRANS_DELETE;
4072     SV* swash;
4073
4074     PERL_ARGS_ASSERT_PMTRANS;
4075
4076     PL_hints |= HINT_BLOCK_SCOPE;
4077
4078     if (SvUTF8(tstr))
4079         o->op_private |= OPpTRANS_FROM_UTF;
4080
4081     if (SvUTF8(rstr))
4082         o->op_private |= OPpTRANS_TO_UTF;
4083
4084     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
4085         SV* const listsv = newSVpvs("# comment\n");
4086         SV* transv = NULL;
4087         const U8* tend = t + tlen;
4088         const U8* rend = r + rlen;
4089         STRLEN ulen;
4090         UV tfirst = 1;
4091         UV tlast = 0;
4092         IV tdiff;
4093         UV rfirst = 1;
4094         UV rlast = 0;
4095         IV rdiff;
4096         IV diff;
4097         I32 none = 0;
4098         U32 max = 0;
4099         I32 bits;
4100         I32 havefinal = 0;
4101         U32 final = 0;
4102         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
4103         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
4104         U8* tsave = NULL;
4105         U8* rsave = NULL;
4106         const U32 flags = UTF8_ALLOW_DEFAULT;
4107
4108         if (!from_utf) {
4109             STRLEN len = tlen;
4110             t = tsave = bytes_to_utf8(t, &len);
4111             tend = t + len;
4112         }
4113         if (!to_utf && rlen) {
4114             STRLEN len = rlen;
4115             r = rsave = bytes_to_utf8(r, &len);
4116             rend = r + len;
4117         }
4118
4119 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
4120  * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
4121  * odd.  */
4122
4123         if (complement) {
4124             U8 tmpbuf[UTF8_MAXBYTES+1];
4125             UV *cp;
4126             UV nextmin = 0;
4127             Newx(cp, 2*tlen, UV);
4128             i = 0;
4129             transv = newSVpvs("");
4130             while (t < tend) {
4131                 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
4132                 t += ulen;
4133                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
4134                     t++;
4135                     cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
4136                     t += ulen;
4137                 }
4138                 else {
4139                  cp[2*i+1] = cp[2*i];
4140                 }
4141                 i++;
4142             }
4143             qsort(cp, i, 2*sizeof(UV), uvcompare);
4144             for (j = 0; j < i; j++) {
4145                 UV  val = cp[2*j];
4146                 diff = val - nextmin;
4147                 if (diff > 0) {
4148                     t = uvchr_to_utf8(tmpbuf,nextmin);
4149                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4150                     if (diff > 1) {
4151                         U8  range_mark = ILLEGAL_UTF8_BYTE;
4152                         t = uvchr_to_utf8(tmpbuf, val - 1);
4153                         sv_catpvn(transv, (char *)&range_mark, 1);
4154                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4155                     }
4156                 }
4157                 val = cp[2*j+1];
4158                 if (val >= nextmin)
4159                     nextmin = val + 1;
4160             }
4161             t = uvchr_to_utf8(tmpbuf,nextmin);
4162             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4163             {
4164                 U8 range_mark = ILLEGAL_UTF8_BYTE;
4165                 sv_catpvn(transv, (char *)&range_mark, 1);
4166             }
4167             t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
4168             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4169             t = (const U8*)SvPVX_const(transv);
4170             tlen = SvCUR(transv);
4171             tend = t + tlen;
4172             Safefree(cp);
4173         }
4174         else if (!rlen && !del) {
4175             r = t; rlen = tlen; rend = tend;
4176         }
4177         if (!squash) {
4178                 if ((!rlen && !del) || t == r ||
4179                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
4180                 {
4181                     o->op_private |= OPpTRANS_IDENTICAL;
4182                 }
4183         }
4184
4185         while (t < tend || tfirst <= tlast) {
4186             /* see if we need more "t" chars */
4187             if (tfirst > tlast) {
4188                 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
4189                 t += ulen;
4190                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {      /* illegal utf8 val indicates range */
4191                     t++;
4192                     tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
4193                     t += ulen;
4194                 }
4195                 else
4196                     tlast = tfirst;
4197             }
4198
4199             /* now see if we need more "r" chars */
4200             if (rfirst > rlast) {
4201                 if (r < rend) {
4202                     rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
4203                     r += ulen;
4204                     if (r < rend && *r == ILLEGAL_UTF8_BYTE) {  /* illegal utf8 val indicates range */
4205                         r++;
4206                         rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
4207                         r += ulen;
4208                     }
4209                     else
4210                         rlast = rfirst;
4211                 }
4212                 else {
4213                     if (!havefinal++)
4214                         final = rlast;
4215                     rfirst = rlast = 0xffffffff;
4216                 }
4217             }
4218
4219             /* now see which range will peter our first, if either. */
4220             tdiff = tlast - tfirst;
4221             rdiff = rlast - rfirst;
4222
4223             if (tdiff <= rdiff)
4224                 diff = tdiff;
4225             else
4226                 diff = rdiff;
4227
4228             if (rfirst == 0xffffffff) {
4229                 diff = tdiff;   /* oops, pretend rdiff is infinite */
4230                 if (diff > 0)
4231                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
4232                                    (long)tfirst, (long)tlast);
4233                 else
4234                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
4235             }
4236             else {
4237                 if (diff > 0)
4238                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
4239                                    (long)tfirst, (long)(tfirst + diff),
4240                                    (long)rfirst);
4241                 else
4242                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
4243                                    (long)tfirst, (long)rfirst);
4244
4245                 if (rfirst + diff > max)
4246                     max = rfirst + diff;
4247                 if (!grows)
4248                     grows = (tfirst < rfirst &&
4249                              UNISKIP(tfirst) < UNISKIP(rfirst + diff));
4250                 rfirst += diff + 1;
4251             }
4252             tfirst += diff + 1;
4253         }
4254
4255         none = ++max;
4256         if (del)
4257             del = ++max;
4258
4259         if (max > 0xffff)
4260             bits = 32;
4261         else if (max > 0xff)
4262             bits = 16;
4263         else
4264             bits = 8;
4265
4266         swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
4267 #ifdef USE_ITHREADS
4268         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
4269         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
4270         PAD_SETSV(cPADOPo->op_padix, swash);
4271         SvPADTMP_on(swash);
4272         SvREADONLY_on(swash);
4273 #else
4274         cSVOPo->op_sv = swash;
4275 #endif
4276         SvREFCNT_dec(listsv);
4277         SvREFCNT_dec(transv);
4278
4279         if (!del && havefinal && rlen)
4280             (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
4281                            newSVuv((UV)final), 0);
4282
4283         if (grows)
4284             o->op_private |= OPpTRANS_GROWS;
4285
4286         Safefree(tsave);
4287         Safefree(rsave);
4288
4289         op_free(expr);
4290         op_free(repl);
4291         return o;
4292     }
4293
4294     tbl = (short*)PerlMemShared_calloc(
4295         (o->op_private & OPpTRANS_COMPLEMENT) &&
4296             !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
4297         sizeof(short));
4298     cPVOPo->op_pv = (char*)tbl;
4299     if (complement) {
4300         for (i = 0; i < (I32)tlen; i++)
4301             tbl[t[i]] = -1;
4302         for (i = 0, j = 0; i < 256; i++) {
4303             if (!tbl[i]) {
4304                 if (j >= (I32)rlen) {
4305                     if (del)
4306                         tbl[i] = -2;
4307                     else if (rlen)
4308                         tbl[i] = r[j-1];
4309                     else
4310                         tbl[i] = (short)i;
4311                 }
4312                 else {
4313                     if (i < 128 && r[j] >= 128)
4314                         grows = 1;
4315                     tbl[i] = r[j++];
4316                 }
4317             }
4318         }
4319         if (!del) {
4320             if (!rlen) {
4321                 j = rlen;
4322                 if (!squash)
4323                     o->op_private |= OPpTRANS_IDENTICAL;
4324             }
4325             else if (j >= (I32)rlen)
4326                 j = rlen - 1;
4327             else {
4328                 tbl =
4329                     (short *)
4330                     PerlMemShared_realloc(tbl,
4331                                           (0x101+rlen-j) * sizeof(short));
4332                 cPVOPo->op_pv = (char*)tbl;
4333             }
4334             tbl[0x100] = (short)(rlen - j);
4335             for (i=0; i < (I32)rlen - j; i++)
4336                 tbl[0x101+i] = r[j+i];
4337         }
4338     }
4339     else {
4340         if (!rlen && !del) {
4341             r = t; rlen = tlen;
4342             if (!squash)
4343                 o->op_private |= OPpTRANS_IDENTICAL;
4344         }
4345         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
4346             o->op_private |= OPpTRANS_IDENTICAL;
4347         }
4348         for (i = 0; i < 256; i++)
4349             tbl[i] = -1;
4350         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
4351             if (j >= (I32)rlen) {
4352                 if (del) {
4353                     if (tbl[t[i]] == -1)
4354                         tbl[t[i]] = -2;
4355                     continue;
4356                 }
4357                 --j;
4358             }
4359             if (tbl[t[i]] == -1) {
4360                 if (t[i] < 128 && r[j] >= 128)
4361                     grows = 1;
4362                 tbl[t[i]] = r[j];
4363             }
4364         }
4365     }
4366
4367     if(del && rlen == tlen) {
4368         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
4369     } else if(rlen > tlen && !complement) {
4370         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
4371     }
4372
4373     if (grows)
4374         o->op_private |= OPpTRANS_GROWS;
4375     op_free(expr);
4376     op_free(repl);
4377
4378     return o;
4379 }
4380
4381 /*
4382 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
4383
4384 Constructs, checks, and returns an op of any pattern matching type.
4385 I<type> is the opcode.  I<flags> gives the eight bits of C<op_flags>
4386 and, shifted up eight bits, the eight bits of C<op_private>.
4387
4388 =cut
4389 */
4390
4391 OP *
4392 Perl_newPMOP(pTHX_ I32 type, I32 flags)
4393 {
4394     dVAR;
4395     PMOP *pmop;
4396
4397     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
4398
4399     NewOp(1101, pmop, 1, PMOP);
4400     pmop->op_type = (OPCODE)type;
4401     pmop->op_ppaddr = PL_ppaddr[type];
4402     pmop->op_flags = (U8)flags;
4403     pmop->op_private = (U8)(0 | (flags >> 8));
4404
4405     if (PL_hints & HINT_RE_TAINT)
4406         pmop->op_pmflags |= PMf_RETAINT;
4407 #ifdef USE_LOCALE_CTYPE
4408     if (IN_LC_COMPILETIME(LC_CTYPE)) {
4409         set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
4410     }
4411     else
4412 #endif
4413          if (IN_UNI_8_BIT) {
4414         set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
4415     }
4416     if (PL_hints & HINT_RE_FLAGS) {
4417         SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4418          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
4419         );
4420         if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
4421         reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4422          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
4423         );
4424         if (reflags && SvOK(reflags)) {
4425             set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
4426         }
4427     }
4428
4429
4430 #ifdef USE_ITHREADS
4431     assert(SvPOK(PL_regex_pad[0]));
4432     if (SvCUR(PL_regex_pad[0])) {
4433         /* Pop off the "packed" IV from the end.  */
4434         SV *const repointer_list = PL_regex_pad[0];
4435         const char *p = SvEND(repointer_list) - sizeof(IV);
4436         const IV offset = *((IV*)p);
4437
4438         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
4439
4440         SvEND_set(repointer_list, p);
4441
4442         pmop->op_pmoffset = offset;
4443         /* This slot should be free, so assert this:  */
4444         assert(PL_regex_pad[offset] == &PL_sv_undef);
4445     } else {
4446         SV * const repointer = &PL_sv_undef;
4447         av_push(PL_regex_padav, repointer);
4448         pmop->op_pmoffset = av_tindex(PL_regex_padav);
4449         PL_regex_pad = AvARRAY(PL_regex_padav);
4450     }
4451 #endif
4452
4453     return CHECKOP(type, pmop);
4454 }
4455
4456 /* Given some sort of match op o, and an expression expr containing a
4457  * pattern, either compile expr into a regex and attach it to o (if it's
4458  * constant), or convert expr into a runtime regcomp op sequence (if it's
4459  * not)
4460  *
4461  * isreg indicates that the pattern is part of a regex construct, eg
4462  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
4463  * split "pattern", which aren't. In the former case, expr will be a list
4464  * if the pattern contains more than one term (eg /a$b/) or if it contains
4465  * a replacement, ie s/// or tr///.
4466  *
4467  * When the pattern has been compiled within a new anon CV (for
4468  * qr/(?{...})/ ), then floor indicates the savestack level just before
4469  * the new sub was created
4470  */
4471
4472 OP *
4473 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor)
4474 {
4475     dVAR;
4476     PMOP *pm;
4477     LOGOP *rcop;
4478     I32 repl_has_vars = 0;
4479     OP* repl = NULL;
4480     bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
4481     bool is_compiletime;
4482     bool has_code;
4483
4484     PERL_ARGS_ASSERT_PMRUNTIME;
4485
4486     /* for s/// and tr///, last element in list is the replacement; pop it */
4487
4488     if (is_trans || o->op_type == OP_SUBST) {
4489         OP* kid;
4490         repl = cLISTOPx(expr)->op_last;
4491         kid = cLISTOPx(expr)->op_first;
4492         while (kid->op_sibling != repl)
4493             kid = kid->op_sibling;
4494         kid->op_sibling = NULL;
4495         cLISTOPx(expr)->op_last = kid;
4496     }
4497
4498     /* for TRANS, convert LIST/PUSH/CONST into CONST, and pass to pmtrans() */
4499
4500     if (is_trans) {
4501         OP* const oe = expr;
4502         assert(expr->op_type == OP_LIST);
4503         assert(cLISTOPx(expr)->op_first->op_type == OP_PUSHMARK);
4504         assert(cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last);
4505         expr = cLISTOPx(oe)->op_last;
4506         cLISTOPx(oe)->op_first->op_sibling = NULL;
4507         cLISTOPx(oe)->op_last = NULL;
4508         op_free(oe);
4509
4510         return pmtrans(o, expr, repl);
4511     }
4512
4513     /* find whether we have any runtime or code elements;
4514      * at the same time, temporarily set the op_next of each DO block;
4515      * then when we LINKLIST, this will cause the DO blocks to be excluded
4516      * from the op_next chain (and from having LINKLIST recursively
4517      * applied to them). We fix up the DOs specially later */
4518
4519     is_compiletime = 1;
4520     has_code = 0;
4521     if (expr->op_type == OP_LIST) {
4522         OP *o;
4523         for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
4524             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
4525                 has_code = 1;
4526                 assert(!o->op_next && o->op_sibling);
4527                 o->op_next = o->op_sibling;
4528             }
4529             else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
4530                 is_compiletime = 0;
4531         }
4532     }
4533     else if (expr->op_type != OP_CONST)
4534         is_compiletime = 0;
4535
4536     LINKLIST(expr);
4537
4538     /* fix up DO blocks; treat each one as a separate little sub;
4539      * also, mark any arrays as LIST/REF */
4540
4541     if (expr->op_type == OP_LIST) {
4542         OP *o;
4543         for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
4544
4545             if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
4546                 assert( !(o->op_flags  & OPf_WANT));
4547                 /* push the array rather than its contents. The regex
4548                  * engine will retrieve and join the elements later */
4549                 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
4550                 continue;
4551             }
4552
4553             if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
4554                 continue;
4555             o->op_next = NULL; /* undo temporary hack from above */
4556             scalar(o);
4557             LINKLIST(o);
4558             if (cLISTOPo->op_first->op_type == OP_LEAVE) {
4559                 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
4560                 /* skip ENTER */
4561                 assert(leaveop->op_first->op_type == OP_ENTER);
4562                 assert(leaveop->op_first->op_sibling);
4563                 o->op_next = leaveop->op_first->op_sibling;
4564                 /* skip leave */
4565                 assert(leaveop->op_flags & OPf_KIDS);
4566                 assert(leaveop->op_last->op_next == (OP*)leaveop);
4567                 leaveop->op_next = NULL; /* stop on last op */
4568                 op_null((OP*)leaveop);
4569             }
4570             else {
4571                 /* skip SCOPE */
4572                 OP *scope = cLISTOPo->op_first;
4573                 assert(scope->op_type == OP_SCOPE);
4574                 assert(scope->op_flags & OPf_KIDS);
4575                 scope->op_next = NULL; /* stop on last op */
4576                 op_null(scope);
4577             }
4578             /* have to peep the DOs individually as we've removed it from
4579              * the op_next chain */
4580             CALL_PEEP(o);
4581             S_prune_chain_head(&(o->op_next));
4582             if (is_compiletime)
4583                 /* runtime finalizes as part of finalizing whole tree */
4584                 finalize_optree(o);
4585         }
4586     }
4587     else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
4588         assert( !(expr->op_flags  & OPf_WANT));
4589         /* push the array rather than its contents. The regex
4590          * engine will retrieve and join the elements later */
4591         expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
4592     }
4593
4594     PL_hints |= HINT_BLOCK_SCOPE;
4595     pm = (PMOP*)o;
4596     assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
4597
4598     if (is_compiletime) {
4599         U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
4600         regexp_engine const *eng = current_re_engine();
4601
4602         if (o->op_flags & OPf_SPECIAL)
4603             rx_flags |= RXf_SPLIT;
4604
4605         if (!has_code || !eng->op_comp) {
4606             /* compile-time simple constant pattern */
4607
4608             if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
4609                 /* whoops! we guessed that a qr// had a code block, but we
4610                  * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
4611                  * that isn't required now. Note that we have to be pretty
4612                  * confident that nothing used that CV's pad while the
4613                  * regex was parsed */
4614                 assert(AvFILLp(PL_comppad) == 0); /* just @_ */
4615                 /* But we know that one op is using this CV's slab. */
4616                 cv_forget_slab(PL_compcv);
4617                 LEAVE_SCOPE(floor);
4618                 pm->op_pmflags &= ~PMf_HAS_CV;
4619             }
4620
4621             PM_SETRE(pm,
4622                 eng->op_comp
4623                     ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4624                                         rx_flags, pm->op_pmflags)
4625                     : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4626                                         rx_flags, pm->op_pmflags)
4627             );
4628             op_free(expr);
4629         }
4630         else {
4631             /* compile-time pattern that includes literal code blocks */
4632             REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4633                         rx_flags,
4634                         (pm->op_pmflags |
4635                             ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
4636                     );
4637             PM_SETRE(pm, re);
4638             if (pm->op_pmflags & PMf_HAS_CV) {
4639                 CV *cv;
4640                 /* this QR op (and the anon sub we embed it in) is never
4641                  * actually executed. It's just a placeholder where we can
4642                  * squirrel away expr in op_code_list without the peephole
4643                  * optimiser etc processing it for a second time */
4644                 OP *qr = newPMOP(OP_QR, 0);
4645                 ((PMOP*)qr)->op_code_list = expr;
4646
4647                 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
4648                 SvREFCNT_inc_simple_void(PL_compcv);
4649                 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
4650                 ReANY(re)->qr_anoncv = cv;
4651
4652                 /* attach the anon CV to the pad so that
4653                  * pad_fixup_inner_anons() can find it */
4654                 (void)pad_add_anon(cv, o->op_type);
4655                 SvREFCNT_inc_simple_void(cv);
4656             }
4657             else {
4658                 pm->op_code_list = expr;
4659             }
4660         }
4661     }
4662     else {
4663         /* runtime pattern: build chain of regcomp etc ops */
4664         bool reglist;
4665         PADOFFSET cv_targ = 0;
4666
4667         reglist = isreg && expr->op_type == OP_LIST;
4668         if (reglist)
4669             op_null(expr);
4670
4671         if (has_code) {
4672             pm->op_code_list = expr;
4673             /* don't free op_code_list; its ops are embedded elsewhere too */
4674             pm->op_pmflags |= PMf_CODELIST_PRIVATE;
4675         }
4676
4677         if (o->op_flags & OPf_SPECIAL)
4678             pm->op_pmflags |= PMf_SPLIT;
4679
4680         /* the OP_REGCMAYBE is a placeholder in the non-threaded case
4681          * to allow its op_next to be pointed past the regcomp and
4682          * preceding stacking ops;
4683          * OP_REGCRESET is there to reset taint before executing the
4684          * stacking ops */
4685         if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
4686             expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
4687
4688         if (pm->op_pmflags & PMf_HAS_CV) {
4689             /* we have a runtime qr with literal code. This means
4690              * that the qr// has been wrapped in a new CV, which
4691              * means that runtime consts, vars etc will have been compiled
4692              * against a new pad. So... we need to execute those ops
4693              * within the environment of the new CV. So wrap them in a call
4694              * to a new anon sub. i.e. for
4695              *
4696              *     qr/a$b(?{...})/,
4697              *
4698              * we build an anon sub that looks like
4699              *
4700              *     sub { "a", $b, '(?{...})' }
4701              *
4702              * and call it, passing the returned list to regcomp.
4703              * Or to put it another way, the list of ops that get executed
4704              * are:
4705              *
4706              *     normal              PMf_HAS_CV
4707              *     ------              -------------------
4708              *                         pushmark (for regcomp)
4709              *                         pushmark (for entersub)
4710              *                         pushmark (for refgen)
4711              *                         anoncode
4712              *                         refgen
4713              *                         entersub
4714              *     regcreset                  regcreset
4715              *     pushmark                   pushmark
4716              *     const("a")                 const("a")
4717              *     gvsv(b)                    gvsv(b)
4718              *     const("(?{...})")          const("(?{...})")
4719              *                                leavesub
4720              *     regcomp             regcomp
4721              */
4722
4723             SvREFCNT_inc_simple_void(PL_compcv);
4724             /* these lines are just an unrolled newANONATTRSUB */
4725             expr = newSVOP(OP_ANONCODE, 0,
4726                     MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
4727             cv_targ = expr->op_targ;
4728             expr = newUNOP(OP_REFGEN, 0, expr);
4729
4730             expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr))));
4731         }
4732
4733         NewOp(1101, rcop, 1, LOGOP);
4734         rcop->op_type = OP_REGCOMP;
4735         rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
4736         rcop->op_first = scalar(expr);
4737         rcop->op_flags |= OPf_KIDS
4738                             | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
4739                             | (reglist ? OPf_STACKED : 0);
4740         rcop->op_private = 0;
4741         rcop->op_other = o;
4742         rcop->op_targ = cv_targ;
4743
4744         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
4745         if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
4746
4747         /* establish postfix order */
4748         if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
4749             LINKLIST(expr);
4750             rcop->op_next = expr;
4751             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
4752         }
4753         else {
4754             rcop->op_next = LINKLIST(expr);
4755             expr->op_next = (OP*)rcop;
4756         }
4757
4758         op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
4759     }
4760
4761     if (repl) {
4762         OP *curop = repl;
4763         bool konst;
4764         /* If we are looking at s//.../e with a single statement, get past
4765            the implicit do{}. */
4766         if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
4767          && cUNOPx(curop)->op_first->op_type == OP_SCOPE
4768          && cUNOPx(curop)->op_first->op_flags & OPf_KIDS) {
4769             OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
4770             if (kid->op_type == OP_NULL && kid->op_sibling
4771              && !kid->op_sibling->op_sibling)
4772                 curop = kid->op_sibling;
4773         }
4774         if (curop->op_type == OP_CONST)
4775             konst = TRUE;
4776         else if (( (curop->op_type == OP_RV2SV ||
4777                     curop->op_type == OP_RV2AV ||
4778                     curop->op_type == OP_RV2HV ||
4779                     curop->op_type == OP_RV2GV)
4780                    && cUNOPx(curop)->op_first
4781                    && cUNOPx(curop)->op_first->op_type == OP_GV )
4782                 || curop->op_type == OP_PADSV
4783                 || curop->op_type == OP_PADAV
4784                 || curop->op_type == OP_PADHV
4785                 || curop->op_type == OP_PADANY) {
4786             repl_has_vars = 1;
4787             konst = TRUE;
4788         }
4789         else konst = FALSE;
4790         if (konst
4791             && !(repl_has_vars
4792                  && (!PM_GETRE(pm)
4793                      || !RX_PRELEN(PM_GETRE(pm))
4794                      || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
4795         {
4796             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
4797             op_prepend_elem(o->op_type, scalar(repl), o);
4798         }
4799         else {
4800             NewOp(1101, rcop, 1, LOGOP);
4801             rcop->op_type = OP_SUBSTCONT;
4802             rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
4803             rcop->op_first = scalar(repl);
4804             rcop->op_flags |= OPf_KIDS;
4805             rcop->op_private = 1;
4806             rcop->op_other = o;
4807
4808             /* establish postfix order */
4809             rcop->op_next = LINKLIST(repl);
4810             repl->op_next = (OP*)rcop;
4811
4812             pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
4813             assert(!(pm->op_pmflags & PMf_ONCE));
4814             pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
4815             rcop->op_next = 0;
4816         }
4817     }
4818
4819     return (OP*)pm;
4820 }
4821
4822 /*
4823 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
4824
4825 Constructs, checks, and returns an op of any type that involves an
4826 embedded SV.  I<type> is the opcode.  I<flags> gives the eight bits
4827 of C<op_flags>.  I<sv> gives the SV to embed in the op; this function
4828 takes ownership of one reference to it.
4829
4830 =cut
4831 */
4832
4833 OP *
4834 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
4835 {
4836     dVAR;
4837     SVOP *svop;
4838
4839     PERL_ARGS_ASSERT_NEWSVOP;
4840
4841     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4842         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4843         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4844
4845     NewOp(1101, svop, 1, SVOP);
4846     svop->op_type = (OPCODE)type;
4847     svop->op_ppaddr = PL_ppaddr[type];
4848     svop->op_sv = sv;
4849     svop->op_next = (OP*)svop;
4850     svop->op_flags = (U8)flags;
4851     svop->op_private = (U8)(0 | (flags >> 8));
4852     if (PL_opargs[type] & OA_RETSCALAR)
4853         scalar((OP*)svop);
4854     if (PL_opargs[type] & OA_TARGET)
4855         svop->op_targ = pad_alloc(type, SVs_PADTMP);
4856     return CHECKOP(type, svop);
4857 }
4858
4859 #ifdef USE_ITHREADS
4860
4861 /*
4862 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
4863
4864 Constructs, checks, and returns an op of any type that involves a
4865 reference to a pad element.  I<type> is the opcode.  I<flags> gives the
4866 eight bits of C<op_flags>.  A pad slot is automatically allocated, and
4867 is populated with I<sv>; this function takes ownership of one reference
4868 to it.
4869
4870 This function only exists if Perl has been compiled to use ithreads.
4871
4872 =cut
4873 */
4874
4875 OP *
4876 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
4877 {
4878     dVAR;
4879     PADOP *padop;
4880
4881     PERL_ARGS_ASSERT_NEWPADOP;
4882
4883     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4884         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4885         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4886
4887     NewOp(1101, padop, 1, PADOP);
4888     padop->op_type = (OPCODE)type;
4889     padop->op_ppaddr = PL_ppaddr[type];
4890     padop->op_padix = pad_alloc(type, SVs_PADTMP);
4891     SvREFCNT_dec(PAD_SVl(padop->op_padix));
4892     PAD_SETSV(padop->op_padix, sv);
4893     assert(sv);
4894     padop->op_next = (OP*)padop;
4895     padop->op_flags = (U8)flags;
4896     if (PL_opargs[type] & OA_RETSCALAR)
4897         scalar((OP*)padop);
4898     if (PL_opargs[type] & OA_TARGET)
4899         padop->op_targ = pad_alloc(type, SVs_PADTMP);
4900     return CHECKOP(type, padop);
4901 }
4902
4903 #endif /* USE_ITHREADS */
4904
4905 /*
4906 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
4907
4908 Constructs, checks, and returns an op of any type that involves an
4909 embedded reference to a GV.  I<type> is the opcode.  I<flags> gives the
4910 eight bits of C<op_flags>.  I<gv> identifies the GV that the op should
4911 reference; calling this function does not transfer ownership of any
4912 reference to it.
4913
4914 =cut
4915 */
4916
4917 OP *
4918 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
4919 {
4920     dVAR;
4921
4922     PERL_ARGS_ASSERT_NEWGVOP;
4923
4924 #ifdef USE_ITHREADS
4925     GvIN_PAD_on(gv);
4926     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4927 #else
4928     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4929 #endif
4930 }
4931
4932 /*
4933 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
4934
4935 Constructs, checks, and returns an op of any type that involves an
4936 embedded C-level pointer (PV).  I<type> is the opcode.  I<flags> gives
4937 the eight bits of C<op_flags>.  I<pv> supplies the C-level pointer, which
4938 must have been allocated using C<PerlMemShared_malloc>; the memory will
4939 be freed when the op is destroyed.
4940
4941 =cut
4942 */
4943
4944 OP *
4945 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
4946 {
4947     dVAR;
4948     const bool utf8 = cBOOL(flags & SVf_UTF8);
4949     PVOP *pvop;
4950
4951     flags &= ~SVf_UTF8;
4952
4953     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4954         || type == OP_RUNCV
4955         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4956
4957     NewOp(1101, pvop, 1, PVOP);
4958     pvop->op_type = (OPCODE)type;
4959     pvop->op_ppaddr = PL_ppaddr[type];
4960     pvop->op_pv = pv;
4961     pvop->op_next = (OP*)pvop;
4962     pvop->op_flags = (U8)flags;
4963     pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
4964     if (PL_opargs[type] & OA_RETSCALAR)
4965         scalar((OP*)pvop);
4966     if (PL_opargs[type] & OA_TARGET)
4967         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
4968     return CHECKOP(type, pvop);
4969 }
4970
4971 void
4972 Perl_package(pTHX_ OP *o)
4973 {
4974     dVAR;
4975     SV *const sv = cSVOPo->op_sv;
4976
4977     PERL_ARGS_ASSERT_PACKAGE;
4978
4979     SAVEGENERICSV(PL_curstash);
4980     save_item(PL_curstname);
4981
4982     PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
4983
4984     sv_setsv(PL_curstname, sv);
4985
4986     PL_hints |= HINT_BLOCK_SCOPE;
4987     PL_parser->copline = NOLINE;
4988     PL_parser->expect = XSTATE;
4989
4990     op_free(o);
4991 }
4992
4993 void
4994 Perl_package_version( pTHX_ OP *v )
4995 {
4996     dVAR;
4997     U32 savehints = PL_hints;
4998     PERL_ARGS_ASSERT_PACKAGE_VERSION;
4999     PL_hints &= ~HINT_STRICT_VARS;
5000     sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
5001     PL_hints = savehints;
5002     op_free(v);
5003 }
5004
5005 void
5006 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
5007 {
5008     dVAR;
5009     OP *pack;
5010     OP *imop;
5011     OP *veop;
5012     SV *use_version = NULL;
5013
5014     PERL_ARGS_ASSERT_UTILIZE;
5015
5016     if (idop->op_type != OP_CONST)
5017         Perl_croak(aTHX_ "Module name must be constant");
5018
5019     veop = NULL;
5020
5021     if (version) {
5022         SV * const vesv = ((SVOP*)version)->op_sv;
5023
5024         if (!arg && !SvNIOKp(vesv)) {
5025             arg = version;
5026         }
5027         else {
5028             OP *pack;
5029             SV *meth;
5030
5031             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
5032                 Perl_croak(aTHX_ "Version number must be a constant number");
5033
5034             /* Make copy of idop so we don't free it twice */
5035             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
5036
5037             /* Fake up a method call to VERSION */
5038             meth = newSVpvs_share("VERSION");
5039             veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
5040                             op_append_elem(OP_LIST,
5041                                         op_prepend_elem(OP_LIST, pack, list(version)),
5042                                         newSVOP(OP_METHOD_NAMED, 0, meth)));
5043         }
5044     }
5045
5046     /* Fake up an import/unimport */
5047     if (arg && arg->op_type == OP_STUB) {
5048         imop = arg;             /* no import on explicit () */
5049     }
5050     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
5051         imop = NULL;            /* use 5.0; */
5052         if (aver)
5053             use_version = ((SVOP*)idop)->op_sv;
5054         else
5055             idop->op_private |= OPpCONST_NOVER;
5056     }
5057     else {
5058         SV *meth;
5059
5060         /* Make copy of idop so we don't free it twice */
5061         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
5062
5063         /* Fake up a method call to import/unimport */
5064         meth = aver
5065             ? newSVpvs_share("import") : newSVpvs_share("unimport");
5066         imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
5067                        op_append_elem(OP_LIST,
5068                                    op_prepend_elem(OP_LIST, pack, list(arg)),
5069                                    newSVOP(OP_METHOD_NAMED, 0, meth)));
5070     }
5071
5072     /* Fake up the BEGIN {}, which does its thing immediately. */
5073     newATTRSUB(floor,
5074         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
5075         NULL,
5076         NULL,
5077         op_append_elem(OP_LINESEQ,
5078             op_append_elem(OP_LINESEQ,
5079                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
5080                 newSTATEOP(0, NULL, veop)),
5081             newSTATEOP(0, NULL, imop) ));
5082
5083     if (use_version) {
5084         /* Enable the
5085          * feature bundle that corresponds to the required version. */
5086         use_version = sv_2mortal(new_version(use_version));
5087         S_enable_feature_bundle(aTHX_ use_version);
5088
5089         /* If a version >= 5.11.0 is requested, strictures are on by default! */
5090         if (vcmp(use_version,
5091                  sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
5092             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
5093                 PL_hints |= HINT_STRICT_REFS;
5094             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
5095                 PL_hints |= HINT_STRICT_SUBS;
5096             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
5097                 PL_hints |= HINT_STRICT_VARS;
5098         }
5099         /* otherwise they are off */
5100         else {
5101             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
5102                 PL_hints &= ~HINT_STRICT_REFS;
5103             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
5104                 PL_hints &= ~HINT_STRICT_SUBS;
5105             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
5106                 PL_hints &= ~HINT_STRICT_VARS;
5107         }
5108     }
5109
5110     /* The "did you use incorrect case?" warning used to be here.
5111      * The problem is that on case-insensitive filesystems one
5112      * might get false positives for "use" (and "require"):
5113      * "use Strict" or "require CARP" will work.  This causes
5114      * portability problems for the script: in case-strict
5115      * filesystems the script will stop working.
5116      *
5117      * The "incorrect case" warning checked whether "use Foo"
5118      * imported "Foo" to your namespace, but that is wrong, too:
5119      * there is no requirement nor promise in the language that
5120      * a Foo.pm should or would contain anything in package "Foo".
5121      *
5122      * There is very little Configure-wise that can be done, either:
5123      * the case-sensitivity of the build filesystem of Perl does not
5124      * help in guessing the case-sensitivity of the runtime environment.
5125      */
5126
5127     PL_hints |= HINT_BLOCK_SCOPE;
5128     PL_parser->copline = NOLINE;
5129     PL_parser->expect = XSTATE;
5130     PL_cop_seqmax++; /* Purely for B::*'s benefit */
5131     if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
5132         PL_cop_seqmax++;
5133
5134 }
5135
5136 /*
5137 =head1 Embedding Functions
5138
5139 =for apidoc load_module
5140
5141 Loads the module whose name is pointed to by the string part of name.
5142 Note that the actual module name, not its filename, should be given.
5143 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
5144 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
5145 (or 0 for no flags).  ver, if specified
5146 and not NULL, provides version semantics
5147 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
5148 arguments can be used to specify arguments to the module's import()
5149 method, similar to C<use Foo::Bar VERSION LIST>.  They must be
5150 terminated with a final NULL pointer.  Note that this list can only
5151 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
5152 Otherwise at least a single NULL pointer to designate the default
5153 import list is required.
5154
5155 The reference count for each specified C<SV*> parameter is decremented.
5156
5157 =cut */
5158
5159 void
5160 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
5161 {
5162     va_list args;
5163
5164     PERL_ARGS_ASSERT_LOAD_MODULE;
5165
5166     va_start(args, ver);
5167     vload_module(flags, name, ver, &args);
5168     va_end(args);
5169 }
5170
5171 #ifdef PERL_IMPLICIT_CONTEXT
5172 void
5173 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
5174 {
5175     dTHX;
5176     va_list args;
5177     PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
5178     va_start(args, ver);
5179     vload_module(flags, name, ver, &args);
5180     va_end(args);
5181 }
5182 #endif
5183
5184 void
5185 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
5186 {
5187     dVAR;
5188     OP *veop, *imop;
5189     OP * const modname = newSVOP(OP_CONST, 0, name);
5190
5191     PERL_ARGS_ASSERT_VLOAD_MODULE;
5192
5193     modname->op_private |= OPpCONST_BARE;
5194     if (ver) {
5195         veop = newSVOP(OP_CONST, 0, ver);
5196     }
5197     else
5198         veop = NULL;
5199     if (flags & PERL_LOADMOD_NOIMPORT) {
5200         imop = sawparens(newNULLLIST());
5201     }
5202     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
5203         imop = va_arg(*args, OP*);
5204     }
5205     else {
5206         SV *sv;
5207         imop = NULL;
5208         sv = va_arg(*args, SV*);
5209         while (sv) {
5210             imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
5211             sv = va_arg(*args, SV*);
5212         }
5213     }
5214
5215     /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
5216      * that it has a PL_parser to play with while doing that, and also
5217      * that it doesn't mess with any existing parser, by creating a tmp
5218      * new parser with lex_start(). This won't actually be used for much,
5219      * since pp_require() will create another parser for the real work.
5220      * The ENTER/LEAVE pair protect callers from any side effects of use.  */
5221
5222     ENTER;
5223     SAVEVPTR(PL_curcop);
5224     lex_start(NULL, NULL, LEX_START_SAME_FILTER);
5225     utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
5226             veop, modname, imop);
5227     LEAVE;
5228 }
5229
5230 PERL_STATIC_INLINE OP *
5231 S_new_entersubop(pTHX_ GV *gv, OP *arg)
5232 {
5233     return newUNOP(OP_ENTERSUB, OPf_STACKED,
5234                    newLISTOP(OP_LIST, 0, arg,
5235                              newUNOP(OP_RV2CV, 0,
5236                                      newGVOP(OP_GV, 0, gv))));
5237 }
5238
5239 OP *
5240 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
5241 {
5242     dVAR;
5243     OP *doop;
5244     GV *gv;
5245
5246     PERL_ARGS_ASSERT_DOFILE;
5247
5248     if (!force_builtin && (gv = gv_override("do", 2))) {
5249         doop = S_new_entersubop(aTHX_ gv, term);
5250     }
5251     else {
5252         doop = newUNOP(OP_DOFILE, 0, scalar(term));
5253     }
5254     return doop;
5255 }
5256
5257 /*
5258 =head1 Optree construction
5259
5260 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
5261
5262 Constructs, checks, and returns an C<lslice> (list slice) op.  I<flags>
5263 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
5264 be set automatically, and, shifted up eight bits, the eight bits of
5265 C<op_private>, except that the bit with value 1 or 2 is automatically
5266 set as required.  I<listval> and I<subscript> supply the parameters of
5267 the slice; they are consumed by this function and become part of the
5268 constructed op tree.
5269
5270 =cut
5271 */
5272
5273 OP *
5274 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
5275 {
5276     return newBINOP(OP_LSLICE, flags,
5277             list(force_list(subscript)),
5278             list(force_list(listval)) );
5279 }
5280
5281 STATIC I32
5282 S_is_list_assignment(pTHX_ const OP *o)
5283 {
5284     unsigned type;
5285     U8 flags;
5286
5287     if (!o)
5288         return TRUE;
5289
5290     if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
5291         o = cUNOPo->op_first;
5292
5293     flags = o->op_flags;
5294     type = o->op_type;
5295     if (type == OP_COND_EXPR) {
5296         const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
5297         const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
5298
5299         if (t && f)
5300             return TRUE;
5301         if (t || f)
5302             yyerror("Assignment to both a list and a scalar");
5303         return FALSE;
5304     }
5305
5306     if (type == OP_LIST &&
5307         (flags & OPf_WANT) == OPf_WANT_SCALAR &&
5308         o->op_private & OPpLVAL_INTRO)
5309         return FALSE;
5310
5311     if (type == OP_LIST || flags & OPf_PARENS ||
5312         type == OP_RV2AV || type == OP_RV2HV ||
5313         type == OP_ASLICE || type == OP_HSLICE ||
5314         type == OP_KVASLICE || type == OP_KVHSLICE)
5315         return TRUE;
5316
5317     if (type == OP_PADAV || type == OP_PADHV)
5318         return TRUE;
5319
5320     if (type == OP_RV2SV)
5321         return FALSE;
5322
5323     return FALSE;
5324 }
5325
5326 /*
5327   Helper function for newASSIGNOP to detection commonality between the
5328   lhs and the rhs.  Marks all variables with PL_generation.  If it
5329   returns TRUE the assignment must be able to handle common variables.
5330 */
5331 PERL_STATIC_INLINE bool
5332 S_aassign_common_vars(pTHX_ OP* o)
5333 {
5334     OP *curop;
5335     for (curop = cUNOPo->op_first; curop; curop=curop->op_sibling) {
5336         if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
5337             if (curop->op_type == OP_GV) {
5338                 GV *gv = cGVOPx_gv(curop);
5339                 if (gv == PL_defgv
5340                     || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5341                     return TRUE;
5342                 GvASSIGN_GENERATION_set(gv, PL_generation);
5343             }
5344             else if (curop->op_type == OP_PADSV ||
5345                 curop->op_type == OP_PADAV ||
5346                 curop->op_type == OP_PADHV ||
5347                 curop->op_type == OP_PADANY)
5348                 {
5349                     if (PAD_COMPNAME_GEN(curop->op_targ)
5350                         == (STRLEN)PL_generation)
5351                         return TRUE;
5352                     PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
5353
5354                 }
5355             else if (curop->op_type == OP_RV2CV)
5356                 return TRUE;
5357             else if (curop->op_type == OP_RV2SV ||
5358                 curop->op_type == OP_RV2AV ||
5359                 curop->op_type == OP_RV2HV ||
5360                 curop->op_type == OP_RV2GV) {
5361                 if (cUNOPx(curop)->op_first->op_type != OP_GV)  /* funny deref? */
5362                     return TRUE;
5363             }
5364             else if (curop->op_type == OP_PUSHRE) {
5365                 GV *const gv =
5366 #ifdef USE_ITHREADS
5367                     ((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff
5368                         ? MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff))
5369                         : NULL;
5370 #else
5371                     ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
5372 #endif
5373                 if (gv) {
5374                     if (gv == PL_defgv
5375                         || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5376                         return TRUE;
5377                     GvASSIGN_GENERATION_set(gv, PL_generation);
5378                 }
5379             }
5380             else
5381                 return TRUE;
5382         }
5383
5384         if (curop->op_flags & OPf_KIDS) {
5385             if (aassign_common_vars(curop))
5386                 return TRUE;
5387         }
5388     }
5389     return FALSE;
5390 }
5391
5392 /*
5393 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
5394
5395 Constructs, checks, and returns an assignment op.  I<left> and I<right>
5396 supply the parameters of the assignment; they are consumed by this
5397 function and become part of the constructed op tree.
5398
5399 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
5400 a suitable conditional optree is constructed.  If I<optype> is the opcode
5401 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
5402 performs the binary operation and assigns the result to the left argument.
5403 Either way, if I<optype> is non-zero then I<flags> has no effect.
5404
5405 If I<optype> is zero, then a plain scalar or list assignment is
5406 constructed.  Which type of assignment it is is automatically determined.
5407 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5408 will be set automatically, and, shifted up eight bits, the eight bits
5409 of C<op_private>, except that the bit with value 1 or 2 is automatically
5410 set as required.
5411
5412 =cut
5413 */
5414
5415 OP *
5416 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
5417 {
5418     dVAR;
5419     OP *o;
5420
5421     if (optype) {
5422         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
5423             return newLOGOP(optype, 0,
5424                 op_lvalue(scalar(left), optype),
5425                 newUNOP(OP_SASSIGN, 0, scalar(right)));
5426         }
5427         else {
5428             return newBINOP(optype, OPf_STACKED,
5429                 op_lvalue(scalar(left), optype), scalar(right));
5430         }
5431     }
5432
5433     if (is_list_assignment(left)) {
5434         static const char no_list_state[] = "Initialization of state variables"
5435             " in list context currently forbidden";
5436         OP *curop;
5437         bool maybe_common_vars = TRUE;
5438
5439         if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
5440             left->op_private &= ~ OPpSLICEWARNING;
5441
5442         PL_modcount = 0;
5443         left = op_lvalue(left, OP_AASSIGN);
5444         curop = list(force_list(left));
5445         o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
5446         o->op_private = (U8)(0 | (flags >> 8));
5447
5448         if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
5449         {
5450             OP* lop = ((LISTOP*)left)->op_first;
5451             maybe_common_vars = FALSE;
5452             while (lop) {
5453                 if (lop->op_type == OP_PADSV ||
5454                     lop->op_type == OP_PADAV ||
5455                     lop->op_type == OP_PADHV ||
5456                     lop->op_type == OP_PADANY) {
5457                     if (!(lop->op_private & OPpLVAL_INTRO))
5458                         maybe_common_vars = TRUE;
5459
5460                     if (lop->op_private & OPpPAD_STATE) {
5461                         if (left->op_private & OPpLVAL_INTRO) {
5462                             /* Each variable in state($a, $b, $c) = ... */
5463                         }
5464                         else {
5465                             /* Each state variable in
5466                                (state $a, my $b, our $c, $d, undef) = ... */
5467                         }
5468                         yyerror(no_list_state);
5469                     } else {
5470                         /* Each my variable in
5471                            (state $a, my $b, our $c, $d, undef) = ... */
5472                     }
5473                 } else if (lop->op_type == OP_UNDEF ||
5474                            OP_TYPE_IS_OR_WAS(lop, OP_PUSHMARK)) {
5475                     /* undef may be interesting in
5476                        (state $a, undef, state $c) */
5477                 } else {
5478                     /* Other ops in the list. */
5479                     maybe_common_vars = TRUE;
5480                 }
5481                 lop = lop->op_sibling;
5482             }
5483         }
5484         else if ((left->op_private & OPpLVAL_INTRO)
5485                 && (   left->op_type == OP_PADSV
5486                     || left->op_type == OP_PADAV
5487                     || left->op_type == OP_PADHV
5488                     || left->op_type == OP_PADANY))
5489         {
5490             if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
5491             if (left->op_private & OPpPAD_STATE) {
5492                 /* All single variable list context state assignments, hence
5493                    state ($a) = ...
5494                    (state $a) = ...
5495                    state @a = ...
5496                    state (@a) = ...
5497                    (state @a) = ...
5498                    state %a = ...
5499                    state (%a) = ...
5500                    (state %a) = ...
5501                 */
5502                 yyerror(no_list_state);
5503             }
5504         }
5505
5506         /* PL_generation sorcery:
5507          * an assignment like ($a,$b) = ($c,$d) is easier than
5508          * ($a,$b) = ($c,$a), since there is no need for temporary vars.
5509          * To detect whether there are common vars, the global var
5510          * PL_generation is incremented for each assign op we compile.
5511          * Then, while compiling the assign op, we run through all the
5512          * variables on both sides of the assignment, setting a spare slot
5513          * in each of them to PL_generation. If any of them already have
5514          * that value, we know we've got commonality.  We could use a
5515          * single bit marker, but then we'd have to make 2 passes, first
5516          * to clear the flag, then to test and set it.  To find somewhere
5517          * to store these values, evil chicanery is done with SvUVX().
5518          */
5519
5520         if (maybe_common_vars) {
5521             PL_generation++;
5522             if (aassign_common_vars(o))
5523                 o->op_private |= OPpASSIGN_COMMON;
5524             LINKLIST(o);
5525         }
5526
5527         if (right && right->op_type == OP_SPLIT) {
5528             OP* tmpop = ((LISTOP*)right)->op_first;
5529             if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
5530                 PMOP * const pm = (PMOP*)tmpop;
5531                 if (left->op_type == OP_RV2AV &&
5532                     !(left->op_private & OPpLVAL_INTRO) &&
5533                     !(o->op_private & OPpASSIGN_COMMON) )
5534                 {
5535                     tmpop = ((UNOP*)left)->op_first;
5536                     if (tmpop->op_type == OP_GV
5537 #ifdef USE_ITHREADS
5538                         && !pm->op_pmreplrootu.op_pmtargetoff
5539 #else
5540                         && !pm->op_pmreplrootu.op_pmtargetgv
5541 #endif
5542                         ) {
5543 #ifdef USE_ITHREADS
5544                         pm->op_pmreplrootu.op_pmtargetoff
5545                             = cPADOPx(tmpop)->op_padix;
5546                         cPADOPx(tmpop)->op_padix = 0;   /* steal it */
5547 #else
5548                         pm->op_pmreplrootu.op_pmtargetgv
5549                             = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
5550                         cSVOPx(tmpop)->op_sv = NULL;    /* steal it */
5551 #endif
5552                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
5553                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
5554                         tmpop->op_sibling = NULL;       /* don't free split */
5555                         right->op_next = tmpop->op_next;  /* fix starting loc */
5556                         op_free(o);                     /* blow off assign */
5557                         right->op_flags &= ~OPf_WANT;
5558                                 /* "I don't know and I don't care." */
5559                         return right;
5560                     }
5561                 }
5562                 else {
5563                    if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
5564                       ((LISTOP*)right)->op_last->op_type == OP_CONST)
5565                     {
5566                         SV ** const svp =
5567                             &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
5568                         SV * const sv = *svp;
5569                         if (SvIOK(sv) && SvIVX(sv) == 0)
5570                         {
5571                           if (right->op_private & OPpSPLIT_IMPLIM) {
5572                             /* our own SV, created in ck_split */
5573                             SvREADONLY_off(sv);
5574                             sv_setiv(sv, PL_modcount+1);
5575                           }
5576                           else {
5577                             /* SV may belong to someone else */
5578                             SvREFCNT_dec(sv);
5579                             *svp = newSViv(PL_modcount+1);
5580                           }
5581                         }
5582                     }
5583                 }
5584             }
5585         }
5586         return o;
5587     }
5588     if (!right)
5589         right = newOP(OP_UNDEF, 0);
5590     if (right->op_type == OP_READLINE) {
5591         right->op_flags |= OPf_STACKED;
5592         return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
5593                 scalar(right));
5594     }
5595     else {
5596         o = newBINOP(OP_SASSIGN, flags,
5597             scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
5598     }
5599     return o;
5600 }
5601
5602 /*
5603 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
5604
5605 Constructs a state op (COP).  The state op is normally a C<nextstate> op,
5606 but will be a C<dbstate> op if debugging is enabled for currently-compiled
5607 code.  The state op is populated from C<PL_curcop> (or C<PL_compiling>).
5608 If I<label> is non-null, it supplies the name of a label to attach to
5609 the state op; this function takes ownership of the memory pointed at by
5610 I<label>, and will free it.  I<flags> gives the eight bits of C<op_flags>
5611 for the state op.
5612
5613 If I<o> is null, the state op is returned.  Otherwise the state op is
5614 combined with I<o> into a C<lineseq> list op, which is returned.  I<o>
5615 is consumed by this function and becomes part of the returned op tree.
5616
5617 =cut
5618 */
5619
5620 OP *
5621 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
5622 {
5623     dVAR;
5624     const U32 seq = intro_my();
5625     const U32 utf8 = flags & SVf_UTF8;
5626     COP *cop;
5627
5628     flags &= ~SVf_UTF8;
5629
5630     NewOp(1101, cop, 1, COP);
5631     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
5632         cop->op_type = OP_DBSTATE;
5633         cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
5634     }
5635     else {
5636         cop->op_type = OP_NEXTSTATE;
5637         cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
5638     }
5639     cop->op_flags = (U8)flags;
5640     CopHINTS_set(cop, PL_hints);
5641 #ifdef NATIVE_HINTS
5642     cop->op_private |= NATIVE_HINTS;
5643 #endif
5644 #ifdef VMS
5645     if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
5646 #endif
5647     cop->op_next = (OP*)cop;
5648
5649     cop->cop_seq = seq;
5650     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
5651     CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
5652     if (label) {
5653         Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
5654
5655         PL_hints |= HINT_BLOCK_SCOPE;
5656         /* It seems that we need to defer freeing this pointer, as other parts
5657            of the grammar end up wanting to copy it after this op has been
5658            created. */
5659         SAVEFREEPV(label);
5660     }
5661
5662     if (PL_parser->preambling != NOLINE) {
5663         CopLINE_set(cop, PL_parser->preambling);
5664         PL_parser->copline = NOLINE;
5665     }
5666     else if (PL_parser->copline == NOLINE)
5667         CopLINE_set(cop, CopLINE(PL_curcop));
5668     else {
5669         CopLINE_set(cop, PL_parser->copline);
5670         PL_parser->copline = NOLINE;
5671     }
5672 #ifdef USE_ITHREADS
5673     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
5674 #else
5675     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
5676 #endif
5677     CopSTASH_set(cop, PL_curstash);
5678
5679     if (cop->op_type == OP_DBSTATE) {
5680         /* this line can have a breakpoint - store the cop in IV */
5681         AV *av = CopFILEAVx(PL_curcop);
5682         if (av) {
5683             SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
5684             if (svp && *svp != &PL_sv_undef ) {
5685                 (void)SvIOK_on(*svp);
5686                 SvIV_set(*svp, PTR2IV(cop));
5687             }
5688         }
5689     }
5690
5691     if (flags & OPf_SPECIAL)
5692         op_null((OP*)cop);
5693     return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
5694 }
5695
5696 /*
5697 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
5698
5699 Constructs, checks, and returns a logical (flow control) op.  I<type>
5700 is the opcode.  I<flags> gives the eight bits of C<op_flags>, except
5701 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
5702 the eight bits of C<op_private>, except that the bit with value 1 is
5703 automatically set.  I<first> supplies the expression controlling the
5704 flow, and I<other> supplies the side (alternate) chain of ops; they are
5705 consumed by this function and become part of the constructed op tree.
5706
5707 =cut
5708 */
5709
5710 OP *
5711 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
5712 {
5713     dVAR;
5714
5715     PERL_ARGS_ASSERT_NEWLOGOP;
5716
5717     return new_logop(type, flags, &first, &other);
5718 }
5719
5720 STATIC OP *
5721 S_search_const(pTHX_ OP *o)
5722 {
5723     PERL_ARGS_ASSERT_SEARCH_CONST;
5724
5725     switch (o->op_type) {
5726         case OP_CONST:
5727             return o;
5728         case OP_NULL:
5729             if (o->op_flags & OPf_KIDS)
5730                 return search_const(cUNOPo->op_first);
5731             break;
5732         case OP_LEAVE:
5733         case OP_SCOPE:
5734         case OP_LINESEQ:
5735         {
5736             OP *kid;
5737             if (!(o->op_flags & OPf_KIDS))
5738                 return NULL;
5739             kid = cLISTOPo->op_first;
5740             do {
5741                 switch (kid->op_type) {
5742                     case OP_ENTER:
5743                     case OP_NULL:
5744                     case OP_NEXTSTATE:
5745                         kid = kid->op_sibling;
5746                         break;
5747                     default:
5748                         if (kid != cLISTOPo->op_last)
5749                             return NULL;
5750                         goto last;
5751                 }
5752             } while (kid);
5753             if (!kid)
5754                 kid = cLISTOPo->op_last;
5755 last:
5756             return search_const(kid);
5757         }
5758     }
5759
5760     return NULL;
5761 }
5762
5763 STATIC OP *
5764 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
5765 {
5766     dVAR;
5767     LOGOP *logop;
5768     OP *o;
5769     OP *first;
5770     OP *other;
5771     OP *cstop = NULL;
5772     int prepend_not = 0;
5773
5774     PERL_ARGS_ASSERT_NEW_LOGOP;
5775
5776     first = *firstp;
5777     other = *otherp;
5778
5779     /* [perl #59802]: Warn about things like "return $a or $b", which
5780        is parsed as "(return $a) or $b" rather than "return ($a or
5781        $b)".  NB: This also applies to xor, which is why we do it
5782        here.
5783      */
5784     switch (first->op_type) {
5785     case OP_NEXT:
5786     case OP_LAST:
5787     case OP_REDO:
5788         /* XXX: Perhaps we should emit a stronger warning for these.
5789            Even with the high-precedence operator they don't seem to do
5790            anything sensible.
5791
5792            But until we do, fall through here.
5793          */
5794     case OP_RETURN:
5795     case OP_EXIT:
5796     case OP_DIE:
5797     case OP_GOTO:
5798         /* XXX: Currently we allow people to "shoot themselves in the
5799            foot" by explicitly writing "(return $a) or $b".
5800
5801            Warn unless we are looking at the result from folding or if
5802            the programmer explicitly grouped the operators like this.
5803            The former can occur with e.g.
5804
5805                 use constant FEATURE => ( $] >= ... );
5806                 sub { not FEATURE and return or do_stuff(); }
5807          */
5808         if (!first->op_folded && !(first->op_flags & OPf_PARENS))
5809             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
5810                            "Possible precedence issue with control flow operator");
5811         /* XXX: Should we optimze this to "return $a;" (i.e. remove
5812            the "or $b" part)?
5813         */
5814         break;
5815     }
5816
5817     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
5818         return newBINOP(type, flags, scalar(first), scalar(other));
5819
5820     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
5821
5822     scalarboolean(first);
5823     /* optimize AND and OR ops that have NOTs as children */
5824     if (first->op_type == OP_NOT
5825         && (first->op_flags & OPf_KIDS)
5826         && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
5827             || (other->op_type == OP_NOT))  /* if (!$x && !$y) { } */
5828         ) {
5829         if (type == OP_AND || type == OP_OR) {
5830             if (type == OP_AND)
5831                 type = OP_OR;
5832             else
5833                 type = OP_AND;
5834             op_null(first);
5835             if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
5836                 op_null(other);
5837                 prepend_not = 1; /* prepend a NOT op later */
5838             }
5839         }
5840     }
5841     /* search for a constant op that could let us fold the test */
5842     if ((cstop = search_const(first))) {
5843         if (cstop->op_private & OPpCONST_STRICT)
5844             no_bareword_allowed(cstop);
5845         else if ((cstop->op_private & OPpCONST_BARE))
5846                 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
5847         if ((type == OP_AND &&  SvTRUE(((SVOP*)cstop)->op_sv)) ||
5848             (type == OP_OR  && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
5849             (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
5850             *firstp = NULL;
5851             if (other->op_type == OP_CONST)
5852                 other->op_private |= OPpCONST_SHORTCIRCUIT;
5853             op_free(first);
5854             if (other->op_type == OP_LEAVE)
5855                 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
5856             else if (other->op_type == OP_MATCH
5857                   || other->op_type == OP_SUBST
5858                   || other->op_type == OP_TRANSR
5859                   || other->op_type == OP_TRANS)
5860                 /* Mark the op as being unbindable with =~ */
5861                 other->op_flags |= OPf_SPECIAL;
5862
5863             other->op_folded = 1;
5864             return other;
5865         }
5866         else {
5867             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
5868             const OP *o2 = other;
5869             if ( ! (o2->op_type == OP_LIST
5870                     && (( o2 = cUNOPx(o2)->op_first))
5871                     && o2->op_type == OP_PUSHMARK
5872                     && (( o2 = o2->op_sibling)) )
5873             )
5874                 o2 = other;
5875             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
5876                         || o2->op_type == OP_PADHV)
5877                 && o2->op_private & OPpLVAL_INTRO
5878                 && !(o2->op_private & OPpPAD_STATE))
5879             {
5880                 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
5881                                  "Deprecated use of my() in false conditional");
5882             }
5883
5884             *otherp = NULL;
5885             if (cstop->op_type == OP_CONST)
5886                 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
5887                 op_free(other);
5888             return first;
5889         }
5890     }
5891     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
5892         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
5893     {
5894         const OP * const k1 = ((UNOP*)first)->op_first;
5895         const OP * const k2 = k1->op_sibling;
5896         OPCODE warnop = 0;
5897         switch (first->op_type)
5898         {
5899         case OP_NULL:
5900             if (k2 && k2->op_type == OP_READLINE
5901                   && (k2->op_flags & OPf_STACKED)
5902                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5903             {
5904                 warnop = k2->op_type;
5905             }
5906             break;
5907
5908         case OP_SASSIGN:
5909             if (k1->op_type == OP_READDIR
5910                   || k1->op_type == OP_GLOB
5911                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5912                  || k1->op_type == OP_EACH
5913                  || k1->op_type == OP_AEACH)
5914             {
5915                 warnop = ((k1->op_type == OP_NULL)
5916                           ? (OPCODE)k1->op_targ : k1->op_type);
5917             }
5918             break;
5919         }
5920         if (warnop) {
5921             const line_t oldline = CopLINE(PL_curcop);
5922             /* This ensures that warnings are reported at the first line
5923                of the construction, not the last.  */
5924             CopLINE_set(PL_curcop, PL_parser->copline);
5925             Perl_warner(aTHX_ packWARN(WARN_MISC),
5926                  "Value of %s%s can be \"0\"; test with defined()",
5927                  PL_op_desc[warnop],
5928                  ((warnop == OP_READLINE || warnop == OP_GLOB)
5929                   ? " construct" : "() operator"));
5930             CopLINE_set(PL_curcop, oldline);
5931         }
5932     }
5933
5934     if (!other)
5935         return first;
5936
5937     if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
5938         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
5939
5940     NewOp(1101, logop, 1, LOGOP);
5941
5942     logop->op_type = (OPCODE)type;
5943     logop->op_ppaddr = PL_ppaddr[type];
5944     logop->op_first = first;
5945     logop->op_flags = (U8)(flags | OPf_KIDS);
5946     logop->op_other = LINKLIST(other);
5947     logop->op_private = (U8)(1 | (flags >> 8));
5948
5949     /* establish postfix order */
5950     logop->op_next = LINKLIST(first);
5951     first->op_next = (OP*)logop;
5952     first->op_sibling = other;
5953
5954     CHECKOP(type,logop);
5955
5956     o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
5957     other->op_next = o;
5958
5959     return o;
5960 }
5961
5962 /*
5963 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
5964
5965 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
5966 op.  I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5967 will be set automatically, and, shifted up eight bits, the eight bits of
5968 C<op_private>, except that the bit with value 1 is automatically set.
5969 I<first> supplies the expression selecting between the two branches,
5970 and I<trueop> and I<falseop> supply the branches; they are consumed by
5971 this function and become part of the constructed op tree.
5972
5973 =cut
5974 */
5975
5976 OP *
5977 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
5978 {
5979     dVAR;
5980     LOGOP *logop;
5981     OP *start;
5982     OP *o;
5983     OP *cstop;
5984
5985     PERL_ARGS_ASSERT_NEWCONDOP;
5986
5987     if (!falseop)
5988         return newLOGOP(OP_AND, 0, first, trueop);
5989     if (!trueop)
5990         return newLOGOP(OP_OR, 0, first, falseop);
5991
5992     scalarboolean(first);
5993     if ((cstop = search_const(first))) {
5994         /* Left or right arm of the conditional?  */
5995         const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
5996         OP *live = left ? trueop : falseop;
5997         OP *const dead = left ? falseop : trueop;
5998         if (cstop->op_private & OPpCONST_BARE &&
5999             cstop->op_private & OPpCONST_STRICT) {
6000             no_bareword_allowed(cstop);
6001         }
6002         op_free(first);
6003         op_free(dead);
6004         if (live->op_type == OP_LEAVE)
6005             live = newUNOP(OP_NULL, OPf_SPECIAL, live);
6006         else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
6007               || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
6008             /* Mark the op as being unbindable with =~ */
6009             live->op_flags |= OPf_SPECIAL;
6010         live->op_folded = 1;
6011         return live;
6012     }
6013     NewOp(1101, logop, 1, LOGOP);
6014     logop->op_type = OP_COND_EXPR;
6015     logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
6016     logop->op_first = first;
6017     logop->op_flags = (U8)(flags | OPf_KIDS);
6018     logop->op_private = (U8)(1 | (flags >> 8));
6019     logop->op_other = LINKLIST(trueop);
6020     logop->op_next = LINKLIST(falseop);
6021
6022     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
6023             logop);
6024
6025     /* establish postfix order */
6026     start = LINKLIST(first);
6027     first->op_next = (OP*)logop;
6028
6029     first->op_sibling = trueop;
6030     trueop->op_sibling = falseop;
6031     o = newUNOP(OP_NULL, 0, (OP*)logop);
6032
6033     trueop->op_next = falseop->op_next = o;
6034
6035     o->op_next = start;
6036     return o;
6037 }
6038
6039 /*
6040 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
6041
6042 Constructs and returns a C<range> op, with subordinate C<flip> and
6043 C<flop> ops.  I<flags> gives the eight bits of C<op_flags> for the
6044 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
6045 for both the C<flip> and C<range> ops, except that the bit with value
6046 1 is automatically set.  I<left> and I<right> supply the expressions
6047 controlling the endpoints of the range; they are consumed by this function
6048 and become part of the constructed op tree.
6049
6050 =cut
6051 */
6052
6053 OP *
6054 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
6055 {
6056     dVAR;
6057     LOGOP *range;
6058     OP *flip;
6059     OP *flop;
6060     OP *leftstart;
6061     OP *o;
6062
6063     PERL_ARGS_ASSERT_NEWRANGE;
6064
6065     NewOp(1101, range, 1, LOGOP);
6066
6067     range->op_type = OP_RANGE;
6068     range->op_ppaddr = PL_ppaddr[OP_RANGE];
6069     range->op_first = left;
6070     range->op_flags = OPf_KIDS;
6071     leftstart = LINKLIST(left);
6072     range->op_other = LINKLIST(right);
6073     range->op_private = (U8)(1 | (flags >> 8));
6074
6075     left->op_sibling = right;
6076
6077     range->op_next = (OP*)range;
6078     flip = newUNOP(OP_FLIP, flags, (OP*)range);
6079     flop = newUNOP(OP_FLOP, 0, flip);
6080     o = newUNOP(OP_NULL, 0, flop);
6081     LINKLIST(flop);
6082     range->op_next = leftstart;
6083
6084     left->op_next = flip;
6085     right->op_next = flop;
6086
6087     range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
6088     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
6089     flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
6090     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
6091
6092     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6093     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6094
6095     /* check barewords before they might be optimized aways */
6096     if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
6097         no_bareword_allowed(left);
6098     if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
6099         no_bareword_allowed(right);
6100
6101     flip->op_next = o;
6102     if (!flip->op_private || !flop->op_private)
6103         LINKLIST(o);            /* blow off optimizer unless constant */
6104
6105     return o;
6106 }
6107
6108 /*
6109 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
6110
6111 Constructs, checks, and returns an op tree expressing a loop.  This is
6112 only a loop in the control flow through the op tree; it does not have
6113 the heavyweight loop structure that allows exiting the loop by C<last>
6114 and suchlike.  I<flags> gives the eight bits of C<op_flags> for the
6115 top-level op, except that some bits will be set automatically as required.
6116 I<expr> supplies the expression controlling loop iteration, and I<block>
6117 supplies the body of the loop; they are consumed by this function and
6118 become part of the constructed op tree.  I<debuggable> is currently
6119 unused and should always be 1.
6120
6121 =cut
6122 */
6123
6124 OP *
6125 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
6126 {
6127     dVAR;
6128     OP* listop;
6129     OP* o;
6130     const bool once = block && block->op_flags & OPf_SPECIAL &&
6131                       block->op_type == OP_NULL;
6132
6133     PERL_UNUSED_ARG(debuggable);
6134
6135     if (expr) {
6136         if (once && (
6137               (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
6138            || (  expr->op_type == OP_NOT
6139               && cUNOPx(expr)->op_first->op_type == OP_CONST
6140               && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
6141               )
6142            ))
6143             /* Return the block now, so that S_new_logop does not try to
6144                fold it away. */
6145             return block;       /* do {} while 0 does once */
6146         if (expr->op_type == OP_READLINE
6147             || expr->op_type == OP_READDIR
6148             || expr->op_type == OP_GLOB
6149             || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
6150             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
6151             expr = newUNOP(OP_DEFINED, 0,
6152                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
6153         } else if (expr->op_flags & OPf_KIDS) {
6154             const OP * const k1 = ((UNOP*)expr)->op_first;
6155             const OP * const k2 = k1 ? k1->op_sibling : NULL;
6156             switch (expr->op_type) {
6157               case OP_NULL:
6158                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
6159                       && (k2->op_flags & OPf_STACKED)
6160                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6161                     expr = newUNOP(OP_DEFINED, 0, expr);
6162                 break;
6163
6164               case OP_SASSIGN:
6165                 if (k1 && (k1->op_type == OP_READDIR
6166                       || k1->op_type == OP_GLOB
6167                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6168                      || k1->op_type == OP_EACH
6169                      || k1->op_type == OP_AEACH))
6170                     expr = newUNOP(OP_DEFINED, 0, expr);
6171                 break;
6172             }
6173         }
6174     }
6175
6176     /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
6177      * op, in listop. This is wrong. [perl #27024] */
6178     if (!block)
6179         block = newOP(OP_NULL, 0);
6180     listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
6181     o = new_logop(OP_AND, 0, &expr, &listop);
6182
6183     if (once) {
6184         ASSUME(listop);
6185     }
6186
6187     if (listop)
6188         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
6189
6190     if (once && o != listop)
6191     {
6192         assert(cUNOPo->op_first->op_type == OP_AND
6193             || cUNOPo->op_first->op_type == OP_OR);
6194         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
6195     }
6196
6197     if (o == listop)
6198         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
6199
6200     o->op_flags |= flags;
6201     o = op_scope(o);
6202     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
6203     return o;
6204 }
6205
6206 /*
6207 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
6208
6209 Constructs, checks, and returns an op tree expressing a C<while> loop.
6210 This is a heavyweight loop, with structure that allows exiting the loop
6211 by C<last> and suchlike.
6212
6213 I<loop> is an optional preconstructed C<enterloop> op to use in the
6214 loop; if it is null then a suitable op will be constructed automatically.
6215 I<expr> supplies the loop's controlling expression.  I<block> supplies the
6216 main body of the loop, and I<cont> optionally supplies a C<continue> block
6217 that operates as a second half of the body.  All of these optree inputs
6218 are consumed by this function and become part of the constructed op tree.
6219
6220 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
6221 op and, shifted up eight bits, the eight bits of C<op_private> for
6222 the C<leaveloop> op, except that (in both cases) some bits will be set
6223 automatically.  I<debuggable> is currently unused and should always be 1.
6224 I<has_my> can be supplied as true to force the
6225 loop body to be enclosed in its own scope.
6226
6227 =cut
6228 */
6229
6230 OP *
6231 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
6232         OP *expr, OP *block, OP *cont, I32 has_my)
6233 {
6234     dVAR;
6235     OP *redo;
6236     OP *next = NULL;
6237     OP *listop;
6238     OP *o;
6239     U8 loopflags = 0;
6240
6241     PERL_UNUSED_ARG(debuggable);
6242
6243     if (expr) {
6244         if (expr->op_type == OP_READLINE
6245          || expr->op_type == OP_READDIR
6246          || expr->op_type == OP_GLOB
6247          || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
6248                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
6249             expr = newUNOP(OP_DEFINED, 0,
6250                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
6251         } else if (expr->op_flags & OPf_KIDS) {
6252             const OP * const k1 = ((UNOP*)expr)->op_first;
6253             const OP * const k2 = (k1) ? k1->op_sibling : NULL;
6254             switch (expr->op_type) {
6255               case OP_NULL:
6256                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
6257                       && (k2->op_flags & OPf_STACKED)
6258                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6259                     expr = newUNOP(OP_DEFINED, 0, expr);
6260                 break;
6261
6262               case OP_SASSIGN:
6263                 if (k1 && (k1->op_type == OP_READDIR
6264                       || k1->op_type == OP_GLOB
6265                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6266                      || k1->op_type == OP_EACH
6267                      || k1->op_type == OP_AEACH))
6268                     expr = newUNOP(OP_DEFINED, 0, expr);
6269                 break;
6270             }
6271         }
6272     }
6273
6274     if (!block)
6275         block = newOP(OP_NULL, 0);
6276     else if (cont || has_my) {
6277         block = op_scope(block);
6278     }
6279
6280     if (cont) {
6281         next = LINKLIST(cont);
6282     }
6283     if (expr) {
6284         OP * const unstack = newOP(OP_UNSTACK, 0);
6285         if (!next)
6286             next = unstack;
6287         cont = op_append_elem(OP_LINESEQ, cont, unstack);
6288     }
6289
6290     assert(block);
6291     listop = op_append_list(OP_LINESEQ, block, cont);
6292     assert(listop);
6293     redo = LINKLIST(listop);
6294
6295     if (expr) {
6296         scalar(listop);
6297         o = new_logop(OP_AND, 0, &expr, &listop);
6298         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
6299             op_free((OP*)loop);
6300             return expr;                /* listop already freed by new_logop */
6301         }
6302         if (listop)
6303             ((LISTOP*)listop)->op_last->op_next =
6304                 (o == listop ? redo : LINKLIST(o));
6305     }
6306     else
6307         o = listop;
6308
6309     if (!loop) {
6310         NewOp(1101,loop,1,LOOP);
6311         loop->op_type = OP_ENTERLOOP;
6312         loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
6313         loop->op_private = 0;
6314         loop->op_next = (OP*)loop;
6315     }
6316
6317     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
6318
6319     loop->op_redoop = redo;
6320     loop->op_lastop = o;
6321     o->op_private |= loopflags;
6322
6323     if (next)
6324         loop->op_nextop = next;
6325     else
6326         loop->op_nextop = o;
6327
6328     o->op_flags |= flags;
6329     o->op_private |= (flags >> 8);
6330     return o;
6331 }
6332
6333 /*
6334 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
6335
6336 Constructs, checks, and returns an op tree expressing a C<foreach>
6337 loop (iteration through a list of values).  This is a heavyweight loop,
6338 with structure that allows exiting the loop by C<last> and suchlike.
6339
6340 I<sv> optionally supplies the variable that will be aliased to each
6341 item in turn; if null, it defaults to C<$_> (either lexical or global).
6342 I<expr> supplies the list of values to iterate over.  I<block> supplies
6343 the main body of the loop, and I<cont> optionally supplies a C<continue>
6344 block that operates as a second half of the body.  All of these optree
6345 inputs are consumed by this function and become part of the constructed
6346 op tree.
6347
6348 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
6349 op and, shifted up eight bits, the eight bits of C<op_private> for
6350 the C<leaveloop> op, except that (in both cases) some bits will be set
6351 automatically.
6352
6353 =cut
6354 */
6355
6356 OP *
6357 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
6358 {
6359     dVAR;
6360     LOOP *loop;
6361     OP *wop;
6362     PADOFFSET padoff = 0;
6363     I32 iterflags = 0;
6364     I32 iterpflags = 0;
6365
6366     PERL_ARGS_ASSERT_NEWFOROP;
6367
6368     if (sv) {
6369         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
6370             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
6371             sv->op_type = OP_RV2GV;
6372             sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
6373
6374             /* The op_type check is needed to prevent a possible segfault
6375              * if the loop variable is undeclared and 'strict vars' is in
6376              * effect. This is illegal but is nonetheless parsed, so we
6377              * may reach this point with an OP_CONST where we're expecting
6378              * an OP_GV.
6379              */
6380             if (cUNOPx(sv)->op_first->op_type == OP_GV
6381              && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
6382                 iterpflags |= OPpITER_DEF;
6383         }
6384         else if (sv->op_type == OP_PADSV) { /* private variable */
6385             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
6386             padoff = sv->op_targ;
6387             sv->op_targ = 0;
6388             op_free(sv);
6389             sv = NULL;
6390         }
6391         else
6392             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
6393         if (padoff) {
6394             SV *const namesv = PAD_COMPNAME_SV(padoff);
6395             STRLEN len;
6396             const char *const name = SvPV_const(namesv, len);
6397
6398             if (len == 2 && name[0] == '$' && name[1] == '_')
6399                 iterpflags |= OPpITER_DEF;
6400         }
6401     }
6402     else {
6403         const PADOFFSET offset = pad_findmy_pvs("$_", 0);
6404         if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6405             sv = newGVOP(OP_GV, 0, PL_defgv);
6406         }
6407         else {
6408             padoff = offset;
6409         }
6410         iterpflags |= OPpITER_DEF;
6411     }
6412     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
6413         expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
6414         iterflags |= OPf_STACKED;
6415     }
6416     else if (expr->op_type == OP_NULL &&
6417              (expr->op_flags & OPf_KIDS) &&
6418              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
6419     {
6420         /* Basically turn for($x..$y) into the same as for($x,$y), but we
6421          * set the STACKED flag to indicate that these values are to be
6422          * treated as min/max values by 'pp_enteriter'.
6423          */
6424         const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
6425         LOGOP* const range = (LOGOP*) flip->op_first;
6426         OP* const left  = range->op_first;
6427         OP* const right = left->op_sibling;
6428         LISTOP* listop;
6429
6430         range->op_flags &= ~OPf_KIDS;
6431         range->op_first = NULL;
6432
6433         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
6434         listop->op_first->op_next = range->op_next;
6435         left->op_next = range->op_other;
6436         right->op_next = (OP*)listop;
6437         listop->op_next = listop->op_first;
6438
6439         op_free(expr);
6440         expr = (OP*)(listop);
6441         op_null(expr);
6442         iterflags |= OPf_STACKED;
6443     }
6444     else {
6445         expr = op_lvalue(force_list(expr), OP_GREPSTART);
6446     }
6447
6448     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
6449                                op_append_elem(OP_LIST, expr, scalar(sv))));
6450     assert(!loop->op_next);
6451     /* for my  $x () sets OPpLVAL_INTRO;
6452      * for our $x () sets OPpOUR_INTRO */
6453     loop->op_private = (U8)iterpflags;
6454     if (loop->op_slabbed
6455      && DIFF(loop, OpSLOT(loop)->opslot_next)
6456          < SIZE_TO_PSIZE(sizeof(LOOP)))
6457     {
6458         LOOP *tmp;
6459         NewOp(1234,tmp,1,LOOP);
6460         Copy(loop,tmp,1,LISTOP);
6461         S_op_destroy(aTHX_ (OP*)loop);
6462         loop = tmp;
6463     }
6464     else if (!loop->op_slabbed)
6465         loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
6466     loop->op_targ = padoff;
6467     wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
6468     return wop;
6469 }
6470
6471 /*
6472 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
6473
6474 Constructs, checks, and returns a loop-exiting op (such as C<goto>
6475 or C<last>).  I<type> is the opcode.  I<label> supplies the parameter
6476 determining the target of the op; it is consumed by this function and
6477 becomes part of the constructed op tree.
6478
6479 =cut
6480 */
6481
6482 OP*
6483 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
6484 {
6485     dVAR;
6486     OP *o = NULL;
6487
6488     PERL_ARGS_ASSERT_NEWLOOPEX;
6489
6490     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6491
6492     if (type != OP_GOTO) {
6493         /* "last()" means "last" */
6494         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
6495             o = newOP(type, OPf_SPECIAL);
6496         }
6497     }
6498     else {
6499         /* Check whether it's going to be a goto &function */
6500         if (label->op_type == OP_ENTERSUB
6501                 && !(label->op_flags & OPf_STACKED))
6502             label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
6503     }
6504
6505     /* Check for a constant argument */
6506     if (label->op_type == OP_CONST) {
6507             SV * const sv = ((SVOP *)label)->op_sv;
6508             STRLEN l;
6509             const char *s = SvPV_const(sv,l);
6510             if (l == strlen(s)) {
6511                 o = newPVOP(type,
6512                             SvUTF8(((SVOP*)label)->op_sv),
6513                             savesharedpv(
6514                                 SvPV_nolen_const(((SVOP*)label)->op_sv)));
6515             }
6516     }
6517
6518     /* If we have already created an op, we do not need the label. */
6519     if (o)
6520                 op_free(label);
6521     else o = newUNOP(type, OPf_STACKED, label);
6522
6523     PL_hints |= HINT_BLOCK_SCOPE;
6524     return o;
6525 }
6526
6527 /* if the condition is a literal array or hash
6528    (or @{ ... } etc), make a reference to it.
6529  */
6530 STATIC OP *
6531 S_ref_array_or_hash(pTHX_ OP *cond)
6532 {
6533     if (cond
6534     && (cond->op_type == OP_RV2AV
6535     ||  cond->op_type == OP_PADAV
6536     ||  cond->op_type == OP_RV2HV
6537     ||  cond->op_type == OP_PADHV))
6538
6539         return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
6540
6541     else if(cond
6542     && (cond->op_type == OP_ASLICE
6543     ||  cond->op_type == OP_KVASLICE
6544     ||  cond->op_type == OP_HSLICE
6545     ||  cond->op_type == OP_KVHSLICE)) {
6546
6547         /* anonlist now needs a list from this op, was previously used in
6548          * scalar context */
6549         cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
6550         cond->op_flags |= OPf_WANT_LIST;
6551
6552         return newANONLIST(op_lvalue(cond, OP_ANONLIST));
6553     }
6554
6555     else
6556         return cond;
6557 }
6558
6559 /* These construct the optree fragments representing given()
6560    and when() blocks.
6561
6562    entergiven and enterwhen are LOGOPs; the op_other pointer
6563    points up to the associated leave op. We need this so we
6564    can put it in the context and make break/continue work.
6565    (Also, of course, pp_enterwhen will jump straight to
6566    op_other if the match fails.)
6567  */
6568
6569 STATIC OP *
6570 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
6571                    I32 enter_opcode, I32 leave_opcode,
6572                    PADOFFSET entertarg)
6573 {
6574     dVAR;
6575     LOGOP *enterop;
6576     OP *o;
6577
6578     PERL_ARGS_ASSERT_NEWGIVWHENOP;
6579
6580     NewOp(1101, enterop, 1, LOGOP);
6581     enterop->op_type = (Optype)enter_opcode;
6582     enterop->op_ppaddr = PL_ppaddr[enter_opcode];
6583     enterop->op_flags =  (U8) OPf_KIDS;
6584     enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
6585     enterop->op_private = 0;
6586
6587     o = newUNOP(leave_opcode, 0, (OP *) enterop);
6588
6589     if (cond) {
6590         enterop->op_first = scalar(cond);
6591         cond->op_sibling = block;
6592
6593         o->op_next = LINKLIST(cond);
6594         cond->op_next = (OP *) enterop;
6595     }
6596     else {
6597         /* This is a default {} block */
6598         enterop->op_first = block;
6599         enterop->op_flags |= OPf_SPECIAL;
6600         o      ->op_flags |= OPf_SPECIAL;
6601
6602         o->op_next = (OP *) enterop;
6603     }
6604
6605     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
6606                                        entergiven and enterwhen both
6607                                        use ck_null() */
6608
6609     enterop->op_next = LINKLIST(block);
6610     block->op_next = enterop->op_other = o;
6611
6612     return o;
6613 }
6614
6615 /* Does this look like a boolean operation? For these purposes
6616    a boolean operation is:
6617      - a subroutine call [*]
6618      - a logical connective
6619      - a comparison operator
6620      - a filetest operator, with the exception of -s -M -A -C
6621      - defined(), exists() or eof()
6622      - /$re/ or $foo =~ /$re/
6623
6624    [*] possibly surprising
6625  */
6626 STATIC bool
6627 S_looks_like_bool(pTHX_ const OP *o)
6628 {
6629     dVAR;
6630
6631     PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
6632
6633     switch(o->op_type) {
6634         case OP_OR:
6635         case OP_DOR:
6636             return looks_like_bool(cLOGOPo->op_first);
6637
6638         case OP_AND:
6639             return (
6640                 looks_like_bool(cLOGOPo->op_first)
6641              && looks_like_bool(cLOGOPo->op_first->op_sibling));
6642
6643         case OP_NULL:
6644         case OP_SCALAR:
6645             return (
6646                 o->op_flags & OPf_KIDS
6647             && looks_like_bool(cUNOPo->op_first));
6648
6649         case OP_ENTERSUB:
6650
6651         case OP_NOT:    case OP_XOR:
6652
6653         case OP_EQ:     case OP_NE:     case OP_LT:
6654         case OP_GT:     case OP_LE:     case OP_GE:
6655
6656         case OP_I_EQ:   case OP_I_NE:   case OP_I_LT:
6657         case OP_I_GT:   case OP_I_LE:   case OP_I_GE:
6658
6659         case OP_SEQ:    case OP_SNE:    case OP_SLT:
6660         case OP_SGT:    case OP_SLE:    case OP_SGE:
6661
6662         case OP_SMARTMATCH:
6663
6664         case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
6665         case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
6666         case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
6667         case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
6668         case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
6669         case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
6670         case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
6671         case OP_FTTEXT:   case OP_FTBINARY:
6672
6673         case OP_DEFINED: case OP_EXISTS:
6674         case OP_MATCH:   case OP_EOF:
6675
6676         case OP_FLOP:
6677
6678             return TRUE;
6679
6680         case OP_CONST:
6681             /* Detect comparisons that have been optimized away */
6682             if (cSVOPo->op_sv == &PL_sv_yes
6683             ||  cSVOPo->op_sv == &PL_sv_no)
6684
6685                 return TRUE;
6686             else
6687                 return FALSE;
6688
6689         /* FALLTHROUGH */
6690         default:
6691             return FALSE;
6692     }
6693 }
6694
6695 /*
6696 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
6697
6698 Constructs, checks, and returns an op tree expressing a C<given> block.
6699 I<cond> supplies the expression that will be locally assigned to a lexical
6700 variable, and I<block> supplies the body of the C<given> construct; they
6701 are consumed by this function and become part of the constructed op tree.
6702 I<defsv_off> is the pad offset of the scalar lexical variable that will
6703 be affected.  If it is 0, the global $_ will be used.
6704
6705 =cut
6706 */
6707
6708 OP *
6709 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
6710 {
6711     dVAR;
6712     PERL_ARGS_ASSERT_NEWGIVENOP;
6713     return newGIVWHENOP(
6714         ref_array_or_hash(cond),
6715         block,
6716         OP_ENTERGIVEN, OP_LEAVEGIVEN,
6717         defsv_off);
6718 }
6719
6720 /*
6721 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
6722
6723 Constructs, checks, and returns an op tree expressing a C<when> block.
6724 I<cond> supplies the test expression, and I<block> supplies the block
6725 that will be executed if the test evaluates to true; they are consumed
6726 by this function and become part of the constructed op tree.  I<cond>
6727 will be interpreted DWIMically, often as a comparison against C<$_>,
6728 and may be null to generate a C<default> block.
6729
6730 =cut
6731 */
6732
6733 OP *
6734 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
6735 {
6736     const bool cond_llb = (!cond || looks_like_bool(cond));
6737     OP *cond_op;
6738
6739     PERL_ARGS_ASSERT_NEWWHENOP;
6740
6741     if (cond_llb)
6742         cond_op = cond;
6743     else {
6744         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
6745                 newDEFSVOP(),
6746                 scalar(ref_array_or_hash(cond)));
6747     }
6748
6749     return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
6750 }
6751
6752 void
6753 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
6754                     const STRLEN len, const U32 flags)
6755 {
6756     SV *name = NULL, *msg;
6757     const char * cvp = SvROK(cv) ? "" : CvPROTO(cv);
6758     STRLEN clen = CvPROTOLEN(cv), plen = len;
6759
6760     PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
6761
6762     if (p == NULL && cvp == NULL)
6763         return;
6764
6765     if (!ckWARN_d(WARN_PROTOTYPE))
6766         return;
6767
6768     if (p && cvp) {
6769         p = S_strip_spaces(aTHX_ p, &plen);
6770         cvp = S_strip_spaces(aTHX_ cvp, &clen);
6771         if ((flags & SVf_UTF8) == SvUTF8(cv)) {
6772             if (plen == clen && memEQ(cvp, p, plen))
6773                 return;
6774         } else {
6775             if (flags & SVf_UTF8) {
6776                 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
6777                     return;
6778             }
6779             else {
6780                 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
6781                     return;
6782             }
6783         }
6784     }
6785
6786     msg = sv_newmortal();
6787
6788     if (gv)
6789     {
6790         if (isGV(gv))
6791             gv_efullname3(name = sv_newmortal(), gv, NULL);
6792         else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
6793             name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
6794         else name = (SV *)gv;
6795     }
6796     sv_setpvs(msg, "Prototype mismatch:");
6797     if (name)
6798         Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
6799     if (cvp)
6800         Perl_sv_catpvf(aTHX_ msg, " (%"UTF8f")",
6801             UTF8fARG(SvUTF8(cv),clen,cvp)
6802         );
6803     else
6804         sv_catpvs(msg, ": none");
6805     sv_catpvs(msg, " vs ");
6806     if (p)
6807         Perl_sv_catpvf(aTHX_ msg, "(%"UTF8f")", UTF8fARG(flags & SVf_UTF8,len,p));
6808     else
6809         sv_catpvs(msg, "none");
6810     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
6811 }
6812
6813 static void const_sv_xsub(pTHX_ CV* cv);
6814 static void const_av_xsub(pTHX_ CV* cv);
6815
6816 /*
6817
6818 =head1 Optree Manipulation Functions
6819
6820 =for apidoc cv_const_sv
6821
6822 If C<cv> is a constant sub eligible for inlining, returns the constant
6823 value returned by the sub.  Otherwise, returns NULL.
6824
6825 Constant subs can be created with C<newCONSTSUB> or as described in
6826 L<perlsub/"Constant Functions">.
6827
6828 =cut
6829 */
6830 SV *
6831 Perl_cv_const_sv(pTHX_ const CV *const cv)
6832 {
6833     SV *sv;
6834     PERL_UNUSED_CONTEXT;
6835     if (!cv)
6836         return NULL;
6837     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
6838         return NULL;
6839     sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
6840     if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
6841     return sv;
6842 }
6843
6844 SV *
6845 Perl_cv_const_sv_or_av(pTHX_ const CV * const cv)
6846 {
6847     PERL_UNUSED_CONTEXT;
6848     if (!cv)
6849         return NULL;
6850     assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
6851     return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
6852 }
6853
6854 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
6855  * Can be called in 3 ways:
6856  *
6857  * !cv
6858  *      look for a single OP_CONST with attached value: return the value
6859  *
6860  * cv && CvCLONE(cv) && !CvCONST(cv)
6861  *
6862  *      examine the clone prototype, and if contains only a single
6863  *      OP_CONST referencing a pad const, or a single PADSV referencing
6864  *      an outer lexical, return a non-zero value to indicate the CV is
6865  *      a candidate for "constizing" at clone time
6866  *
6867  * cv && CvCONST(cv)
6868  *
6869  *      We have just cloned an anon prototype that was marked as a const
6870  *      candidate. Try to grab the current value, and in the case of
6871  *      PADSV, ignore it if it has multiple references. In this case we
6872  *      return a newly created *copy* of the value.
6873  */
6874
6875 SV *
6876 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
6877 {
6878     dVAR;
6879     SV *sv = NULL;
6880
6881     if (!o)
6882         return NULL;
6883
6884     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
6885         o = cLISTOPo->op_first->op_sibling;
6886
6887     for (; o; o = o->op_next) {
6888         const OPCODE type = o->op_type;
6889
6890         if (sv && o->op_next == o)
6891             return sv;
6892         if (o->op_next != o) {
6893             if (type == OP_NEXTSTATE
6894              || (type == OP_NULL && !(o->op_flags & OPf_KIDS))
6895              || type == OP_PUSHMARK)
6896                 continue;
6897             if (type == OP_DBSTATE)
6898                 continue;
6899         }
6900         if (type == OP_LEAVESUB || type == OP_RETURN)
6901             break;
6902         if (sv)
6903             return NULL;
6904         if (type == OP_CONST && cSVOPo->op_sv)
6905             sv = cSVOPo->op_sv;
6906         else if (cv && type == OP_CONST) {
6907             sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6908             if (!sv)
6909                 return NULL;
6910         }
6911         else if (cv && type == OP_PADSV) {
6912             if (CvCONST(cv)) { /* newly cloned anon */
6913                 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6914                 /* the candidate should have 1 ref from this pad and 1 ref
6915                  * from the parent */
6916                 if (!sv || SvREFCNT(sv) != 2)
6917                     return NULL;
6918                 sv = newSVsv(sv);
6919                 SvREADONLY_on(sv);
6920                 return sv;
6921             }
6922             else {
6923                 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
6924                     sv = &PL_sv_undef; /* an arbitrary non-null value */
6925             }
6926         }
6927         else {
6928             return NULL;
6929         }
6930     }
6931     return sv;
6932 }
6933
6934 static bool
6935 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
6936                         PADNAME * const name, SV ** const const_svp)
6937 {
6938     assert (cv);
6939     assert (o || name);
6940     assert (const_svp);
6941     if ((!block
6942          )) {
6943         if (CvFLAGS(PL_compcv)) {
6944             /* might have had built-in attrs applied */
6945             const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
6946             if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
6947              && ckWARN(WARN_MISC))
6948             {
6949                 /* protect against fatal warnings leaking compcv */
6950                 SAVEFREESV(PL_compcv);
6951                 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
6952                 SvREFCNT_inc_simple_void_NN(PL_compcv);
6953             }
6954             CvFLAGS(cv) |=
6955                 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
6956                   & ~(CVf_LVALUE * pureperl));
6957         }
6958         return FALSE;
6959     }
6960
6961     /* redundant check for speed: */
6962     if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
6963         const line_t oldline = CopLINE(PL_curcop);
6964         SV *namesv = o
6965             ? cSVOPo->op_sv
6966             : sv_2mortal(newSVpvn_utf8(
6967                 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
6968               ));
6969         if (PL_parser && PL_parser->copline != NOLINE)
6970             /* This ensures that warnings are reported at the first
6971                line of a redefinition, not the last.  */
6972             CopLINE_set(PL_curcop, PL_parser->copline);
6973         /* protect against fatal warnings leaking compcv */
6974         SAVEFREESV(PL_compcv);
6975         report_redefined_cv(namesv, cv, const_svp);
6976         SvREFCNT_inc_simple_void_NN(PL_compcv);
6977         CopLINE_set(PL_curcop, oldline);
6978     }
6979     SAVEFREESV(cv);
6980     return TRUE;
6981 }
6982
6983 CV *
6984 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6985 {
6986     dVAR;
6987     CV **spot;
6988     SV **svspot;
6989     const char *ps;
6990     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
6991     U32 ps_utf8 = 0;
6992     CV *cv = NULL;
6993     CV *compcv = PL_compcv;
6994     SV *const_sv;
6995     PADNAME *name;
6996     PADOFFSET pax = o->op_targ;
6997     CV *outcv = CvOUTSIDE(PL_compcv);
6998     CV *clonee = NULL;
6999     HEK *hek = NULL;
7000     bool reusable = FALSE;
7001
7002     PERL_ARGS_ASSERT_NEWMYSUB;
7003
7004     /* Find the pad slot for storing the new sub.
7005        We cannot use PL_comppad, as it is the pad owned by the new sub.  We
7006        need to look in CvOUTSIDE and find the pad belonging to the enclos-
7007        ing sub.  And then we need to dig deeper if this is a lexical from
7008        outside, as in:
7009            my sub foo; sub { sub foo { } }
7010      */
7011    redo:
7012     name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
7013     if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
7014         pax = PARENT_PAD_INDEX(name);
7015         outcv = CvOUTSIDE(outcv);
7016         assert(outcv);
7017         goto redo;
7018     }
7019     svspot =
7020         &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
7021                         [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
7022     spot = (CV **)svspot;
7023
7024     if (!(PL_parser && PL_parser->error_count))
7025         move_proto_attr(&proto, &attrs, (GV *)name);
7026
7027     if (proto) {
7028         assert(proto->op_type == OP_CONST);
7029         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
7030         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
7031     }
7032     else
7033         ps = NULL;
7034
7035     if (proto)
7036         SAVEFREEOP(proto);
7037     if (attrs)
7038         SAVEFREEOP(attrs);
7039
7040     if (PL_parser && PL_parser->error_count) {
7041         op_free(block);
7042         SvREFCNT_dec(PL_compcv);
7043         PL_compcv = 0;
7044         goto done;
7045     }
7046
7047     if (CvDEPTH(outcv) && CvCLONE(compcv)) {
7048         cv = *spot;
7049         svspot = (SV **)(spot = &clonee);
7050     }
7051     else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
7052         cv = *spot;
7053     else {
7054         MAGIC *mg;
7055         SvUPGRADE(name, SVt_PVMG);
7056         mg = mg_find(name, PERL_MAGIC_proto);
7057         assert (SvTYPE(*spot) == SVt_PVCV);
7058         if (CvNAMED(*spot))
7059             hek = CvNAME_HEK(*spot);
7060         else {
7061             CvNAME_HEK_set(*spot, hek =
7062                 share_hek(
7063                     PadnamePV(name)+1,
7064                     PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1), 0
7065                 )
7066             );
7067         }
7068         if (mg) {
7069             assert(mg->mg_obj);
7070             cv = (CV *)mg->mg_obj;
7071         }
7072         else {
7073             sv_magic(name, &PL_sv_undef, PERL_MAGIC_proto, NULL, 0);
7074             mg = mg_find(name, PERL_MAGIC_proto);
7075         }
7076         spot = (CV **)(svspot = &mg->mg_obj);
7077     }
7078
7079     if (!block || !ps || *ps || attrs
7080         || (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS)
7081         )
7082         const_sv = NULL;
7083     else
7084         const_sv = op_const_sv(block, NULL);
7085
7086     if (cv) {
7087         const bool exists = CvROOT(cv) || CvXSUB(cv);
7088
7089         /* if the subroutine doesn't exist and wasn't pre-declared
7090          * with a prototype, assume it will be AUTOLOADed,
7091          * skipping the prototype check
7092          */
7093         if (exists || SvPOK(cv))
7094             cv_ckproto_len_flags(cv, (GV *)name, ps, ps_len, ps_utf8);
7095         /* already defined? */
7096         if (exists) {
7097             if (S_already_defined(aTHX_ cv,block,NULL,name,&const_sv))
7098                 cv = NULL;
7099             else {
7100                 if (attrs) goto attrs;
7101                 /* just a "sub foo;" when &foo is already defined */
7102                 SAVEFREESV(compcv);
7103                 goto done;
7104             }
7105         }
7106         else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
7107             cv = NULL;
7108             reusable = TRUE;
7109         }
7110     }
7111     if (const_sv) {
7112         SvREFCNT_inc_simple_void_NN(const_sv);
7113         SvFLAGS(const_sv) = (SvFLAGS(const_sv) & ~SVs_PADMY) | SVs_PADTMP;
7114         if (cv) {
7115             assert(!CvROOT(cv) && !CvCONST(cv));
7116             cv_forget_slab(cv);
7117         }
7118         else {
7119             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
7120             CvFILE_set_from_cop(cv, PL_curcop);
7121             CvSTASH_set(cv, PL_curstash);
7122             *spot = cv;
7123         }
7124         sv_setpvs(MUTABLE_SV(cv), "");  /* prototype is "" */
7125         CvXSUBANY(cv).any_ptr = const_sv;
7126         CvXSUB(cv) = const_sv_xsub;
7127         CvCONST_on(cv);
7128         CvISXSUB_on(cv);
7129         op_free(block);
7130         SvREFCNT_dec(compcv);
7131         PL_compcv = NULL;
7132         goto setname;
7133     }
7134     /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
7135        determine whether this sub definition is in the same scope as its
7136        declaration.  If this sub definition is inside an inner named pack-
7137        age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
7138        the package sub.  So check PadnameOUTER(name) too.
7139      */
7140     if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
7141         assert(!CvWEAKOUTSIDE(compcv));
7142         SvREFCNT_dec(CvOUTSIDE(compcv));
7143         CvWEAKOUTSIDE_on(compcv);
7144     }
7145     /* XXX else do we have a circular reference? */
7146     if (cv) {   /* must reuse cv in case stub is referenced elsewhere */
7147         /* transfer PL_compcv to cv */
7148         if (block
7149         ) {
7150             cv_flags_t preserved_flags =
7151                 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
7152             PADLIST *const temp_padl = CvPADLIST(cv);
7153             CV *const temp_cv = CvOUTSIDE(cv);
7154             const cv_flags_t other_flags =
7155                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
7156             OP * const cvstart = CvSTART(cv);
7157
7158             SvPOK_off(cv);
7159             CvFLAGS(cv) =
7160                 CvFLAGS(compcv) | preserved_flags;
7161             CvOUTSIDE(cv) = CvOUTSIDE(compcv);
7162             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
7163             CvPADLIST(cv) = CvPADLIST(compcv);
7164             CvOUTSIDE(compcv) = temp_cv;
7165             CvPADLIST(compcv) = temp_padl;
7166             CvSTART(cv) = CvSTART(compcv);
7167             CvSTART(compcv) = cvstart;
7168             CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
7169             CvFLAGS(compcv) |= other_flags;
7170
7171             if (CvFILE(cv) && CvDYNFILE(cv)) {
7172                 Safefree(CvFILE(cv));
7173             }
7174
7175             /* inner references to compcv must be fixed up ... */
7176             pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
7177             if (PERLDB_INTER)/* Advice debugger on the new sub. */
7178               ++PL_sub_generation;
7179         }
7180         else {
7181             /* Might have had built-in attributes applied -- propagate them. */
7182             CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
7183         }
7184         /* ... before we throw it away */
7185         SvREFCNT_dec(compcv);
7186         PL_compcv = compcv = cv;
7187     }
7188     else {
7189         cv = compcv;
7190         *spot = cv;
7191     }
7192    setname:
7193     if (!CvNAME_HEK(cv)) {
7194         CvNAME_HEK_set(cv,
7195          hek
7196           ? share_hek_hek(hek)
7197           : share_hek(PadnamePV(name)+1,
7198                       PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1),
7199                       0)
7200         );
7201     }
7202     if (const_sv) goto clone;
7203
7204     CvFILE_set_from_cop(cv, PL_curcop);
7205     CvSTASH_set(cv, PL_curstash);
7206
7207     if (ps) {
7208         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
7209         if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
7210     }
7211
7212     if (!block)
7213         goto attrs;
7214
7215     /* If we assign an optree to a PVCV, then we've defined a subroutine that
7216        the debugger could be able to set a breakpoint in, so signal to
7217        pp_entereval that it should not throw away any saved lines at scope
7218        exit.  */
7219
7220     PL_breakable_sub_gen++;
7221     /* This makes sub {}; work as expected.  */
7222     if (block->op_type == OP_STUB) {
7223             OP* const newblock = newSTATEOP(0, NULL, 0);
7224             op_free(block);
7225             block = newblock;
7226     }
7227     CvROOT(cv) = CvLVALUE(cv)
7228                    ? newUNOP(OP_LEAVESUBLV, 0,
7229                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
7230                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
7231     CvROOT(cv)->op_private |= OPpREFCOUNTED;
7232     OpREFCNT_set(CvROOT(cv), 1);
7233     /* The cv no longer needs to hold a refcount on the slab, as CvROOT
7234        itself has a refcount. */
7235     CvSLABBED_off(cv);
7236     OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
7237     CvSTART(cv) = LINKLIST(CvROOT(cv));
7238     CvROOT(cv)->op_next = 0;
7239     CALL_PEEP(CvSTART(cv));
7240     finalize_optree(CvROOT(cv));
7241     S_prune_chain_head(&CvSTART(cv));
7242
7243     /* now that optimizer has done its work, adjust pad values */
7244
7245     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
7246
7247     if (CvCLONE(cv)) {
7248         assert(!CvCONST(cv));
7249         if (ps && !*ps && op_const_sv(block, cv))
7250             CvCONST_on(cv);
7251     }
7252
7253   attrs:
7254     if (attrs) {
7255         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
7256         apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
7257     }
7258
7259     if (block) {
7260         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
7261             SV * const tmpstr = sv_newmortal();
7262             GV * const db_postponed = gv_fetchpvs("DB::postponed",
7263                                                   GV_ADDMULTI, SVt_PVHV);
7264             HV *hv;
7265             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
7266                                           CopFILE(PL_curcop),
7267                                           (long)PL_subline,
7268                                           (long)CopLINE(PL_curcop));
7269             if (HvNAME_HEK(PL_curstash)) {
7270                 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
7271                 sv_catpvs(tmpstr, "::");
7272             }
7273             else sv_setpvs(tmpstr, "__ANON__::");
7274             sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
7275                             PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
7276             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
7277                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
7278             hv = GvHVn(db_postponed);
7279             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
7280                 CV * const pcv = GvCV(db_postponed);
7281                 if (pcv) {
7282                     dSP;
7283                     PUSHMARK(SP);
7284                     XPUSHs(tmpstr);
7285                     PUTBACK;
7286                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
7287                 }
7288             }
7289         }
7290     }
7291
7292   clone:
7293     if (clonee) {
7294         assert(CvDEPTH(outcv));
7295         spot = (CV **)
7296             &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
7297         if (reusable) cv_clone_into(clonee, *spot);
7298         else *spot = cv_clone(clonee);
7299         SvREFCNT_dec_NN(clonee);
7300         cv = *spot;
7301         SvPADMY_on(cv);
7302     }
7303     if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
7304         PADOFFSET depth = CvDEPTH(outcv);
7305         while (--depth) {
7306             SV *oldcv;
7307             svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
7308             oldcv = *svspot;
7309             *svspot = SvREFCNT_inc_simple_NN(cv);
7310             SvREFCNT_dec(oldcv);
7311         }
7312     }
7313
7314   done:
7315     if (PL_parser)
7316         PL_parser->copline = NOLINE;
7317     LEAVE_SCOPE(floor);
7318     if (o) op_free(o);
7319     return cv;
7320 }
7321
7322 /* _x = extended */
7323 CV *
7324 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
7325                             OP *block, bool o_is_gv)
7326 {
7327     dVAR;
7328     GV *gv;
7329     const char *ps;
7330     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
7331     U32 ps_utf8 = 0;
7332     CV *cv = NULL;
7333     SV *const_sv;
7334     const bool ec = PL_parser && PL_parser->error_count;
7335     /* If the subroutine has no body, no attributes, and no builtin attributes
7336        then it's just a sub declaration, and we may be able to get away with
7337        storing with a placeholder scalar in the symbol table, rather than a
7338        full GV and CV.  If anything is present then it will take a full CV to
7339        store it.  */
7340     const I32 gv_fetch_flags
7341         = ec ? GV_NOADD_NOINIT :
7342         (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
7343         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
7344     STRLEN namlen = 0;
7345     const char * const name =
7346          o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
7347     bool has_name;
7348     bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
7349 #ifdef PERL_DEBUG_READONLY_OPS
7350     OPSLAB *slab = NULL;
7351 #endif
7352
7353     if (o_is_gv) {
7354         gv = (GV*)o;
7355         o = NULL;
7356         has_name = TRUE;
7357     } else if (name) {
7358         gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
7359         has_name = TRUE;
7360     } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
7361         SV * const sv = sv_newmortal();
7362         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
7363                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
7364                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
7365         gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
7366         has_name = TRUE;
7367     } else if (PL_curstash) {
7368         gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
7369         has_name = FALSE;
7370     } else {
7371         gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
7372         has_name = FALSE;
7373     }
7374
7375     if (!ec)
7376         move_proto_attr(&proto, &attrs, gv);
7377
7378     if (proto) {
7379         assert(proto->op_type == OP_CONST);
7380         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
7381         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
7382     }
7383     else
7384         ps = NULL;
7385
7386     if (o)
7387         SAVEFREEOP(o);
7388     if (proto)
7389         SAVEFREEOP(proto);
7390     if (attrs)
7391         SAVEFREEOP(attrs);
7392
7393     if (ec) {
7394         op_free(block);
7395         if (name) SvREFCNT_dec(PL_compcv);
7396         else cv = PL_compcv;
7397         PL_compcv = 0;
7398         if (name && block) {
7399             const char *s = strrchr(name, ':');
7400             s = s ? s+1 : name;
7401             if (strEQ(s, "BEGIN")) {
7402                 if (PL_in_eval & EVAL_KEEPERR)
7403                     Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
7404                 else {
7405                     SV * const errsv = ERRSV;
7406                     /* force display of errors found but not reported */
7407                     sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
7408                     Perl_croak_nocontext("%"SVf, SVfARG(errsv));
7409                 }
7410             }
7411         }
7412         goto done;
7413     }
7414
7415     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
7416                                            maximum a prototype before. */
7417         if (SvTYPE(gv) > SVt_NULL) {
7418             cv_ckproto_len_flags((const CV *)gv,
7419                                  o ? (const GV *)cSVOPo->op_sv : NULL, ps,
7420                                  ps_len, ps_utf8);
7421         }
7422         if (ps) {
7423             sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
7424             if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
7425         }
7426         else
7427             sv_setiv(MUTABLE_SV(gv), -1);
7428
7429         SvREFCNT_dec(PL_compcv);
7430         cv = PL_compcv = NULL;
7431         goto done;
7432     }
7433
7434     cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
7435
7436     if (!block || !ps || *ps || attrs
7437         || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
7438         )
7439         const_sv = NULL;
7440     else
7441         const_sv = op_const_sv(block, NULL);
7442
7443     if (cv) {
7444         const bool exists = CvROOT(cv) || CvXSUB(cv);
7445
7446         /* if the subroutine doesn't exist and wasn't pre-declared
7447          * with a prototype, assume it will be AUTOLOADed,
7448          * skipping the prototype check
7449          */
7450         if (exists || SvPOK(cv))
7451             cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
7452         /* already defined (or promised)? */
7453         if (exists || GvASSUMECV(gv)) {
7454             if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv))
7455                 cv = NULL;
7456             else {
7457                 if (attrs) goto attrs;
7458                 /* just a "sub foo;" when &foo is already defined */
7459                 SAVEFREESV(PL_compcv);
7460                 goto done;
7461             }
7462         }
7463     }
7464     if (const_sv) {
7465         SvREFCNT_inc_simple_void_NN(const_sv);
7466         SvFLAGS(const_sv) = (SvFLAGS(const_sv) & ~SVs_PADMY) | SVs_PADTMP;
7467         if (cv) {
7468             assert(!CvROOT(cv) && !CvCONST(cv));
7469             cv_forget_slab(cv);
7470             sv_setpvs(MUTABLE_SV(cv), "");  /* prototype is "" */
7471             CvXSUBANY(cv).any_ptr = const_sv;
7472             CvXSUB(cv) = const_sv_xsub;
7473             CvCONST_on(cv);
7474             CvISXSUB_on(cv);
7475         }
7476         else {
7477             GvCV_set(gv, NULL);
7478             cv = newCONSTSUB_flags(
7479                 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
7480                 const_sv
7481             );
7482         }
7483         op_free(block);
7484         SvREFCNT_dec(PL_compcv);
7485         PL_compcv = NULL;
7486         goto done;
7487     }
7488     if (cv) {                           /* must reuse cv if autoloaded */
7489         /* transfer PL_compcv to cv */
7490         if (block
7491         ) {
7492             cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
7493             PADLIST *const temp_av = CvPADLIST(cv);
7494             CV *const temp_cv = CvOUTSIDE(cv);
7495             const cv_flags_t other_flags =
7496                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
7497             OP * const cvstart = CvSTART(cv);
7498
7499             CvGV_set(cv,gv);
7500             assert(!CvCVGV_RC(cv));
7501             assert(CvGV(cv) == gv);
7502
7503             SvPOK_off(cv);
7504             CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
7505             CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
7506             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
7507             CvPADLIST(cv) = CvPADLIST(PL_compcv);
7508             CvOUTSIDE(PL_compcv) = temp_cv;
7509             CvPADLIST(PL_compcv) = temp_av;
7510             CvSTART(cv) = CvSTART(PL_compcv);
7511             CvSTART(PL_compcv) = cvstart;
7512             CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
7513             CvFLAGS(PL_compcv) |= other_flags;
7514
7515             if (CvFILE(cv) && CvDYNFILE(cv)) {
7516                 Safefree(CvFILE(cv));
7517     }
7518             CvFILE_set_from_cop(cv, PL_curcop);
7519             CvSTASH_set(cv, PL_curstash);
7520
7521             /* inner references to PL_compcv must be fixed up ... */
7522             pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
7523             if (PERLDB_INTER)/* Advice debugger on the new sub. */
7524               ++PL_sub_generation;
7525         }
7526         else {
7527             /* Might have had built-in attributes applied -- propagate them. */
7528             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
7529         }
7530         /* ... before we throw it away */
7531         SvREFCNT_dec(PL_compcv);
7532         PL_compcv = cv;
7533     }
7534     else {
7535         cv = PL_compcv;
7536         if (name) {
7537             GvCV_set(gv, cv);
7538             GvCVGEN(gv) = 0;
7539             if (HvENAME_HEK(GvSTASH(gv)))
7540                 /* sub Foo::bar { (shift)+1 } */
7541                 gv_method_changed(gv);
7542         }
7543     }
7544     if (!CvGV(cv)) {
7545         CvGV_set(cv, gv);
7546         CvFILE_set_from_cop(cv, PL_curcop);
7547         CvSTASH_set(cv, PL_curstash);
7548     }
7549
7550     if (ps) {
7551         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
7552         if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
7553     }
7554
7555     if (!block)
7556         goto attrs;
7557
7558     /* If we assign an optree to a PVCV, then we've defined a subroutine that
7559        the debugger could be able to set a breakpoint in, so signal to
7560        pp_entereval that it should not throw away any saved lines at scope
7561        exit.  */
7562
7563     PL_breakable_sub_gen++;
7564     /* This makes sub {}; work as expected.  */
7565     if (block->op_type == OP_STUB) {
7566             OP* const newblock = newSTATEOP(0, NULL, 0);
7567             op_free(block);
7568             block = newblock;
7569     }
7570     CvROOT(cv) = CvLVALUE(cv)
7571                    ? newUNOP(OP_LEAVESUBLV, 0,
7572                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
7573                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
7574     CvROOT(cv)->op_private |= OPpREFCOUNTED;
7575     OpREFCNT_set(CvROOT(cv), 1);
7576     /* The cv no longer needs to hold a refcount on the slab, as CvROOT
7577        itself has a refcount. */
7578     CvSLABBED_off(cv);
7579     OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
7580 #ifdef PERL_DEBUG_READONLY_OPS
7581     slab = (OPSLAB *)CvSTART(cv);
7582 #endif
7583     CvSTART(cv) = LINKLIST(CvROOT(cv));
7584     CvROOT(cv)->op_next = 0;
7585     CALL_PEEP(CvSTART(cv));
7586     finalize_optree(CvROOT(cv));
7587     S_prune_chain_head(&CvSTART(cv));
7588
7589     /* now that optimizer has done its work, adjust pad values */
7590
7591     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
7592
7593     if (CvCLONE(cv)) {
7594         assert(!CvCONST(cv));
7595         if (ps && !*ps && op_const_sv(block, cv))
7596             CvCONST_on(cv);
7597     }
7598
7599   attrs:
7600     if (attrs) {
7601         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
7602         HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
7603         if (!name) SAVEFREESV(cv);
7604         apply_attrs(stash, MUTABLE_SV(cv), attrs);
7605         if (!name) SvREFCNT_inc_simple_void_NN(cv);
7606     }
7607
7608     if (block && has_name) {
7609         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
7610             SV * const tmpstr = sv_newmortal();
7611             GV * const db_postponed = gv_fetchpvs("DB::postponed",
7612                                                   GV_ADDMULTI, SVt_PVHV);
7613             HV *hv;
7614             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
7615                                           CopFILE(PL_curcop),
7616                                           (long)PL_subline,
7617                                           (long)CopLINE(PL_curcop));
7618             gv_efullname3(tmpstr, gv, NULL);
7619             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
7620                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
7621             hv = GvHVn(db_postponed);
7622             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
7623                 CV * const pcv = GvCV(db_postponed);
7624                 if (pcv) {
7625                     dSP;
7626                     PUSHMARK(SP);
7627                     XPUSHs(tmpstr);
7628                     PUTBACK;
7629                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
7630                 }
7631             }
7632         }
7633
7634         if (name && ! (PL_parser && PL_parser->error_count))
7635             process_special_blocks(floor, name, gv, cv);
7636     }
7637
7638   done:
7639     if (PL_parser)
7640         PL_parser->copline = NOLINE;
7641     LEAVE_SCOPE(floor);
7642 #ifdef PERL_DEBUG_READONLY_OPS
7643     /* Watch out for BEGIN blocks */
7644     if (slab && gv && isGV(gv) && GvCV(gv)) Slab_to_ro(slab);
7645 #endif
7646     return cv;
7647 }
7648
7649 STATIC void
7650 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
7651                          GV *const gv,
7652                          CV *const cv)
7653 {
7654     const char *const colon = strrchr(fullname,':');
7655     const char *const name = colon ? colon + 1 : fullname;
7656
7657     PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
7658
7659     if (*name == 'B') {
7660         if (strEQ(name, "BEGIN")) {
7661             const I32 oldscope = PL_scopestack_ix;
7662             dSP;
7663             if (floor) LEAVE_SCOPE(floor);
7664             ENTER;
7665             PUSHSTACKi(PERLSI_REQUIRE);
7666             SAVECOPFILE(&PL_compiling);
7667             SAVECOPLINE(&PL_compiling);
7668             SAVEVPTR(PL_curcop);
7669
7670             DEBUG_x( dump_sub(gv) );
7671             Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
7672             GvCV_set(gv,0);             /* cv has been hijacked */
7673             call_list(oldscope, PL_beginav);
7674
7675             POPSTACK;
7676             LEAVE;
7677         }
7678         else
7679             return;
7680     } else {
7681         if (*name == 'E') {
7682             if strEQ(name, "END") {
7683                 DEBUG_x( dump_sub(gv) );
7684                 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
7685             } else
7686                 return;
7687         } else if (*name == 'U') {
7688             if (strEQ(name, "UNITCHECK")) {
7689                 /* It's never too late to run a unitcheck block */
7690                 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
7691             }
7692             else
7693                 return;
7694         } else if (*name == 'C') {
7695             if (strEQ(name, "CHECK")) {
7696                 if (PL_main_start)
7697                     /* diag_listed_as: Too late to run %s block */
7698                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
7699                                    "Too late to run CHECK block");
7700                 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
7701             }
7702             else
7703                 return;
7704         } else if (*name == 'I') {
7705             if (strEQ(name, "INIT")) {
7706                 if (PL_main_start)
7707                     /* diag_listed_as: Too late to run %s block */
7708                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
7709                                    "Too late to run INIT block");
7710                 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
7711             }
7712             else
7713                 return;
7714         } else
7715             return;
7716         DEBUG_x( dump_sub(gv) );
7717         GvCV_set(gv,0);         /* cv has been hijacked */
7718     }
7719 }
7720
7721 /*
7722 =for apidoc newCONSTSUB
7723
7724 See L</newCONSTSUB_flags>.
7725
7726 =cut
7727 */
7728
7729 CV *
7730 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
7731 {
7732     return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
7733 }
7734
7735 /*
7736 =for apidoc newCONSTSUB_flags
7737
7738 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
7739 eligible for inlining at compile-time.
7740
7741 Currently, the only useful value for C<flags> is SVf_UTF8.
7742
7743 The newly created subroutine takes ownership of a reference to the passed in
7744 SV.
7745
7746 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
7747 which won't be called if used as a destructor, but will suppress the overhead
7748 of a call to C<AUTOLOAD>.  (This form, however, isn't eligible for inlining at
7749 compile time.)
7750
7751 =cut
7752 */
7753
7754 CV *
7755 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
7756                              U32 flags, SV *sv)
7757 {
7758     dVAR;
7759     CV* cv;
7760     const char *const file = CopFILE(PL_curcop);
7761
7762     ENTER;
7763
7764     if (IN_PERL_RUNTIME) {
7765         /* at runtime, it's not safe to manipulate PL_curcop: it may be
7766          * an op shared between threads. Use a non-shared COP for our
7767          * dirty work */
7768          SAVEVPTR(PL_curcop);
7769          SAVECOMPILEWARNINGS();
7770          PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
7771          PL_curcop = &PL_compiling;
7772     }
7773     SAVECOPLINE(PL_curcop);
7774     CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
7775
7776     SAVEHINTS();
7777     PL_hints &= ~HINT_BLOCK_SCOPE;
7778
7779     if (stash) {
7780         SAVEGENERICSV(PL_curstash);
7781         PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
7782     }
7783
7784     /* Protect sv against leakage caused by fatal warnings. */
7785     if (sv) SAVEFREESV(sv);
7786
7787     /* file becomes the CvFILE. For an XS, it's usually static storage,
7788        and so doesn't get free()d.  (It's expected to be from the C pre-
7789        processor __FILE__ directive). But we need a dynamically allocated one,
7790        and we need it to get freed.  */
7791     cv = newXS_len_flags(name, len,
7792                          sv && SvTYPE(sv) == SVt_PVAV
7793                              ? const_av_xsub
7794                              : const_sv_xsub,
7795                          file ? file : "", "",
7796                          &sv, XS_DYNAMIC_FILENAME | flags);
7797     CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
7798     CvCONST_on(cv);
7799
7800     LEAVE;
7801
7802     return cv;
7803 }
7804
7805 CV *
7806 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
7807                  const char *const filename, const char *const proto,
7808                  U32 flags)
7809 {
7810     PERL_ARGS_ASSERT_NEWXS_FLAGS;
7811     return newXS_len_flags(
7812        name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
7813     );
7814 }
7815
7816 CV *
7817 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
7818                            XSUBADDR_t subaddr, const char *const filename,
7819                            const char *const proto, SV **const_svp,
7820                            U32 flags)
7821 {
7822     CV *cv;
7823     bool interleave = FALSE;
7824
7825     PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
7826
7827     {
7828         GV * const gv = gv_fetchpvn(
7829                             name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
7830                             name ? len : PL_curstash ? sizeof("__ANON__") - 1:
7831                                 sizeof("__ANON__::__ANON__") - 1,
7832                             GV_ADDMULTI | flags, SVt_PVCV);
7833
7834         if (!subaddr)
7835             Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
7836
7837         if ((cv = (name ? GvCV(gv) : NULL))) {
7838             if (GvCVGEN(gv)) {
7839                 /* just a cached method */
7840                 SvREFCNT_dec(cv);
7841                 cv = NULL;
7842             }
7843             else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
7844                 /* already defined (or promised) */
7845                 /* Redundant check that allows us to avoid creating an SV
7846                    most of the time: */
7847                 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
7848                     report_redefined_cv(newSVpvn_flags(
7849                                          name,len,(flags&SVf_UTF8)|SVs_TEMP
7850                                         ),
7851                                         cv, const_svp);
7852                 }
7853                 interleave = TRUE;
7854                 ENTER;
7855                 SAVEFREESV(cv);
7856                 cv = NULL;
7857             }
7858         }
7859
7860         if (cv)                         /* must reuse cv if autoloaded */
7861             cv_undef(cv);
7862         else {
7863             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
7864             if (name) {
7865                 GvCV_set(gv,cv);
7866                 GvCVGEN(gv) = 0;
7867                 if (HvENAME_HEK(GvSTASH(gv)))
7868                     gv_method_changed(gv); /* newXS */
7869             }
7870         }
7871         if (!name)
7872             CvANON_on(cv);
7873         CvGV_set(cv, gv);
7874         (void)gv_fetchfile(filename);
7875         CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
7876                                     an external constant string */
7877         assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
7878         CvISXSUB_on(cv);
7879         CvXSUB(cv) = subaddr;
7880
7881         if (name)
7882             process_special_blocks(0, name, gv, cv);
7883     }
7884
7885     if (flags & XS_DYNAMIC_FILENAME) {
7886         CvFILE(cv) = savepv(filename);
7887         CvDYNFILE_on(cv);
7888     }
7889     sv_setpv(MUTABLE_SV(cv), proto);
7890     if (interleave) LEAVE;
7891     return cv;
7892 }
7893
7894 CV *
7895 Perl_newSTUB(pTHX_ GV *gv, bool fake)
7896 {
7897     CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
7898     GV *cvgv;
7899     PERL_ARGS_ASSERT_NEWSTUB;
7900     assert(!GvCVu(gv));
7901     GvCV_set(gv, cv);
7902     GvCVGEN(gv) = 0;
7903     if (!fake && HvENAME_HEK(GvSTASH(gv)))
7904         gv_method_changed(gv);
7905     if (SvFAKE(gv)) {
7906         cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
7907         SvFAKE_off(cvgv);
7908     }
7909     else cvgv = gv;
7910     CvGV_set(cv, cvgv);
7911     CvFILE_set_from_cop(cv, PL_curcop);
7912     CvSTASH_set(cv, PL_curstash);
7913     GvMULTI_on(gv);
7914     return cv;
7915 }
7916
7917 /*
7918 =for apidoc U||newXS
7919
7920 Used by C<xsubpp> to hook up XSUBs as Perl subs.  I<filename> needs to be
7921 static storage, as it is used directly as CvFILE(), without a copy being made.
7922
7923 =cut
7924 */
7925
7926 CV *
7927 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
7928 {
7929     PERL_ARGS_ASSERT_NEWXS;
7930     return newXS_len_flags(
7931         name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
7932     );
7933 }
7934
7935 void
7936 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
7937 {
7938     dVAR;
7939     CV *cv;
7940
7941     GV *gv;
7942
7943     if (PL_parser && PL_parser->error_count) {
7944         op_free(block);
7945         goto finish;
7946     }
7947
7948     gv = o
7949         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
7950         : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
7951
7952     GvMULTI_on(gv);
7953     if ((cv = GvFORM(gv))) {
7954         if (ckWARN(WARN_REDEFINE)) {
7955             const line_t oldline = CopLINE(PL_curcop);
7956             if (PL_parser && PL_parser->copline != NOLINE)
7957                 CopLINE_set(PL_curcop, PL_parser->copline);
7958             if (o) {
7959                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
7960                             "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
7961             } else {
7962                 /* diag_listed_as: Format %s redefined */
7963                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
7964                             "Format STDOUT redefined");
7965             }
7966             CopLINE_set(PL_curcop, oldline);
7967         }
7968         SvREFCNT_dec(cv);
7969     }
7970     cv = PL_compcv;
7971     GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
7972     CvGV_set(cv, gv);
7973     CvFILE_set_from_cop(cv, PL_curcop);
7974
7975
7976     pad_tidy(padtidy_FORMAT);
7977     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
7978     CvROOT(cv)->op_private |= OPpREFCOUNTED;
7979     OpREFCNT_set(CvROOT(cv), 1);
7980     CvSTART(cv) = LINKLIST(CvROOT(cv));
7981     CvROOT(cv)->op_next = 0;
7982     CALL_PEEP(CvSTART(cv));
7983     finalize_optree(CvROOT(cv));
7984     S_prune_chain_head(&CvSTART(cv));
7985     cv_forget_slab(cv);
7986
7987   finish:
7988     op_free(o);
7989     if (PL_parser)
7990         PL_parser->copline = NOLINE;
7991     LEAVE_SCOPE(floor);
7992 }
7993
7994 OP *
7995 Perl_newANONLIST(pTHX_ OP *o)
7996 {
7997     return convert(OP_ANONLIST, OPf_SPECIAL, o);
7998 }
7999
8000 OP *
8001 Perl_newANONHASH(pTHX_ OP *o)
8002 {
8003     return convert(OP_ANONHASH, OPf_SPECIAL, o);
8004 }
8005
8006 OP *
8007 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
8008 {
8009     return newANONATTRSUB(floor, proto, NULL, block);
8010 }
8011
8012 OP *
8013 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
8014 {
8015     return newUNOP(OP_REFGEN, 0,
8016         newSVOP(OP_ANONCODE, 0,
8017                 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
8018 }
8019
8020 OP *
8021 Perl_oopsAV(pTHX_ OP *o)
8022 {
8023     dVAR;
8024
8025     PERL_ARGS_ASSERT_OOPSAV;
8026
8027     switch (o->op_type) {
8028     case OP_PADSV:
8029     case OP_PADHV:
8030         o->op_type = OP_PADAV;
8031         o->op_ppaddr = PL_ppaddr[OP_PADAV];
8032         return ref(o, OP_RV2AV);
8033
8034     case OP_RV2SV:
8035     case OP_RV2HV:
8036         o->op_type = OP_RV2AV;
8037         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
8038         ref(o, OP_RV2AV);
8039         break;
8040
8041     default:
8042         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
8043         break;
8044     }
8045     return o;
8046 }
8047
8048 OP *
8049 Perl_oopsHV(pTHX_ OP *o)
8050 {
8051     dVAR;
8052
8053     PERL_ARGS_ASSERT_OOPSHV;
8054
8055     switch (o->op_type) {
8056     case OP_PADSV:
8057     case OP_PADAV:
8058         o->op_type = OP_PADHV;
8059         o->op_ppaddr = PL_ppaddr[OP_PADHV];
8060         return ref(o, OP_RV2HV);
8061
8062     case OP_RV2SV:
8063     case OP_RV2AV:
8064         o->op_type = OP_RV2HV;
8065         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
8066         ref(o, OP_RV2HV);
8067         break;
8068
8069     default:
8070         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
8071         break;
8072     }
8073     return o;
8074 }
8075
8076 OP *
8077 Perl_newAVREF(pTHX_ OP *o)
8078 {
8079     dVAR;
8080
8081     PERL_ARGS_ASSERT_NEWAVREF;
8082
8083     if (o->op_type == OP_PADANY) {
8084         o->op_type = OP_PADAV;
8085         o->op_ppaddr = PL_ppaddr[OP_PADAV];
8086         return o;
8087     }
8088     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
8089         Perl_croak(aTHX_ "Can't use an array as a reference");
8090     }
8091     return newUNOP(OP_RV2AV, 0, scalar(o));
8092 }
8093
8094 OP *
8095 Perl_newGVREF(pTHX_ I32 type, OP *o)
8096 {
8097     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
8098         return newUNOP(OP_NULL, 0, o);
8099     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
8100 }
8101
8102 OP *
8103 Perl_newHVREF(pTHX_ OP *o)
8104 {
8105     dVAR;
8106
8107     PERL_ARGS_ASSERT_NEWHVREF;
8108
8109     if (o->op_type == OP_PADANY) {
8110         o->op_type = OP_PADHV;
8111         o->op_ppaddr = PL_ppaddr[OP_PADHV];
8112         return o;
8113     }
8114     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
8115         Perl_croak(aTHX_ "Can't use a hash as a reference");
8116     }
8117     return newUNOP(OP_RV2HV, 0, scalar(o));
8118 }
8119
8120 OP *
8121 Perl_newCVREF(pTHX_ I32 flags, OP *o)
8122 {
8123     if (o->op_type == OP_PADANY) {
8124         dVAR;
8125         o->op_type = OP_PADCV;
8126         o->op_ppaddr = PL_ppaddr[OP_PADCV];
8127     }
8128     return newUNOP(OP_RV2CV, flags, scalar(o));
8129 }
8130
8131 OP *
8132 Perl_newSVREF(pTHX_ OP *o)
8133 {
8134     dVAR;
8135
8136     PERL_ARGS_ASSERT_NEWSVREF;
8137
8138     if (o->op_type == OP_PADANY) {
8139         o->op_type = OP_PADSV;
8140         o->op_ppaddr = PL_ppaddr[OP_PADSV];
8141         return o;
8142     }
8143     return newUNOP(OP_RV2SV, 0, scalar(o));
8144 }
8145
8146 /* Check routines. See the comments at the top of this file for details
8147  * on when these are called */
8148
8149 OP *
8150 Perl_ck_anoncode(pTHX_ OP *o)
8151 {
8152     PERL_ARGS_ASSERT_CK_ANONCODE;
8153
8154     cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
8155     cSVOPo->op_sv = NULL;
8156     return o;
8157 }
8158
8159 static void
8160 S_io_hints(pTHX_ OP *o)
8161 {
8162 #if O_BINARY != 0 || O_TEXT != 0
8163     HV * const table =
8164         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
8165     if (table) {
8166         SV **svp = hv_fetchs(table, "open_IN", FALSE);
8167         if (svp && *svp) {
8168             STRLEN len = 0;
8169             const char *d = SvPV_const(*svp, len);
8170             const I32 mode = mode_from_discipline(d, len);
8171             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
8172 #  if O_BINARY != 0
8173             if (mode & O_BINARY)
8174                 o->op_private |= OPpOPEN_IN_RAW;
8175 #  endif
8176 #  if O_TEXT != 0
8177             if (mode & O_TEXT)
8178                 o->op_private |= OPpOPEN_IN_CRLF;
8179 #  endif
8180         }
8181
8182         svp = hv_fetchs(table, "open_OUT", FALSE);
8183         if (svp && *svp) {
8184             STRLEN len = 0;
8185             const char *d = SvPV_const(*svp, len);
8186             const I32 mode = mode_from_discipline(d, len);
8187             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
8188 #  if O_BINARY != 0
8189             if (mode & O_BINARY)
8190                 o->op_private |= OPpOPEN_OUT_RAW;
8191 #  endif
8192 #  if O_TEXT != 0
8193             if (mode & O_TEXT)
8194                 o->op_private |= OPpOPEN_OUT_CRLF;
8195 #  endif
8196         }
8197     }
8198 #else
8199     PERL_UNUSED_CONTEXT;
8200     PERL_UNUSED_ARG(o);
8201 #endif
8202 }
8203
8204 OP *
8205 Perl_ck_backtick(pTHX_ OP *o)
8206 {
8207     GV *gv;
8208     OP *newop = NULL;
8209     PERL_ARGS_ASSERT_CK_BACKTICK;
8210     /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
8211     if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_sibling
8212      && (gv = gv_override("readpipe",8))) {
8213         newop = S_new_entersubop(aTHX_ gv, cUNOPo->op_first->op_sibling);
8214         cUNOPo->op_first->op_sibling = NULL;
8215     }
8216     else if (!(o->op_flags & OPf_KIDS))
8217         newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
8218     if (newop) {
8219         op_free(o);
8220         return newop;
8221     }
8222     S_io_hints(aTHX_ o);
8223     return o;
8224 }
8225
8226 OP *
8227 Perl_ck_bitop(pTHX_ OP *o)
8228 {
8229     dVAR;
8230
8231     PERL_ARGS_ASSERT_CK_BITOP;
8232
8233     o->op_private = (U8)(PL_hints & HINT_INTEGER);
8234     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
8235             && (o->op_type == OP_BIT_OR
8236              || o->op_type == OP_BIT_AND
8237              || o->op_type == OP_BIT_XOR))
8238     {
8239         const OP * const left = cBINOPo->op_first;
8240         const OP * const right = left->op_sibling;
8241         if ((OP_IS_NUMCOMPARE(left->op_type) &&
8242                 (left->op_flags & OPf_PARENS) == 0) ||
8243             (OP_IS_NUMCOMPARE(right->op_type) &&
8244                 (right->op_flags & OPf_PARENS) == 0))
8245             Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
8246                            "Possible precedence problem on bitwise %c operator",
8247                            o->op_type == OP_BIT_OR ? '|'
8248                            : o->op_type == OP_BIT_AND ? '&' : '^'
8249                            );
8250     }
8251     return o;
8252 }
8253
8254 PERL_STATIC_INLINE bool
8255 is_dollar_bracket(pTHX_ const OP * const o)
8256 {
8257     const OP *kid;
8258     return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
8259         && (kid = cUNOPx(o)->op_first)
8260         && kid->op_type == OP_GV
8261         && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
8262 }
8263
8264 OP *
8265 Perl_ck_cmp(pTHX_ OP *o)
8266 {
8267     PERL_ARGS_ASSERT_CK_CMP;
8268     if (ckWARN(WARN_SYNTAX)) {
8269         const OP *kid = cUNOPo->op_first;
8270         if (kid && (
8271                 (
8272                    is_dollar_bracket(aTHX_ kid)
8273                 && kid->op_sibling && kid->op_sibling->op_type == OP_CONST
8274                 )
8275              || (  kid->op_type == OP_CONST
8276                 && (kid = kid->op_sibling) && is_dollar_bracket(aTHX_ kid))
8277            ))
8278             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8279                         "$[ used in %s (did you mean $] ?)", OP_DESC(o));
8280     }
8281     return o;
8282 }
8283
8284 OP *
8285 Perl_ck_concat(pTHX_ OP *o)
8286 {
8287     const OP * const kid = cUNOPo->op_first;
8288
8289     PERL_ARGS_ASSERT_CK_CONCAT;
8290     PERL_UNUSED_CONTEXT;
8291
8292     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
8293             !(kUNOP->op_first->op_flags & OPf_MOD))
8294         o->op_flags |= OPf_STACKED;
8295     return o;
8296 }
8297
8298 OP *
8299 Perl_ck_spair(pTHX_ OP *o)
8300 {
8301     dVAR;
8302
8303     PERL_ARGS_ASSERT_CK_SPAIR;
8304
8305     if (o->op_flags & OPf_KIDS) {
8306         OP* newop;
8307         OP* kid;
8308         const OPCODE type = o->op_type;
8309         o = modkids(ck_fun(o), type);
8310         kid = cUNOPo->op_first;
8311         newop = kUNOP->op_first->op_sibling;
8312         if (newop) {
8313             const OPCODE type = newop->op_type;
8314             if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
8315                     type == OP_PADAV || type == OP_PADHV ||
8316                     type == OP_RV2AV || type == OP_RV2HV)
8317                 return o;
8318         }
8319         op_free(kUNOP->op_first);
8320         kUNOP->op_first = newop;
8321     }
8322     /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
8323      * and OP_CHOMP into OP_SCHOMP */
8324     o->op_ppaddr = PL_ppaddr[++o->op_type];
8325     return ck_fun(o);
8326 }
8327
8328 OP *
8329 Perl_ck_delete(pTHX_ OP *o)
8330 {
8331     PERL_ARGS_ASSERT_CK_DELETE;
8332
8333     o = ck_fun(o);
8334     o->op_private = 0;
8335     if (o->op_flags & OPf_KIDS) {
8336         OP * const kid = cUNOPo->op_first;
8337         switch (kid->op_type) {
8338         case OP_ASLICE:
8339             o->op_flags |= OPf_SPECIAL;
8340             /* FALLTHROUGH */
8341         case OP_HSLICE:
8342             o->op_private |= OPpSLICE;
8343             break;
8344         case OP_AELEM:
8345             o->op_flags |= OPf_SPECIAL;
8346             /* FALLTHROUGH */
8347         case OP_HELEM:
8348             break;
8349         case OP_KVASLICE:
8350             Perl_croak(aTHX_ "delete argument is index/value array slice,"
8351                              " use array slice");
8352         case OP_KVHSLICE:
8353             Perl_croak(aTHX_ "delete argument is key/value hash slice, use"
8354                              " hash slice");
8355         default:
8356             Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
8357                              "element or slice");
8358         }
8359         if (kid->op_private & OPpLVAL_INTRO)
8360             o->op_private |= OPpLVAL_INTRO;
8361         op_null(kid);
8362     }
8363     return o;
8364 }
8365
8366 OP *
8367 Perl_ck_eof(pTHX_ OP *o)
8368 {
8369     dVAR;
8370
8371     PERL_ARGS_ASSERT_CK_EOF;
8372
8373     if (o->op_flags & OPf_KIDS) {
8374         OP *kid;
8375         if (cLISTOPo->op_first->op_type == OP_STUB) {
8376             OP * const newop
8377                 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
8378             op_free(o);
8379             o = newop;
8380         }
8381         o = ck_fun(o);
8382         kid = cLISTOPo->op_first;
8383         if (kid->op_type == OP_RV2GV)
8384             kid->op_private |= OPpALLOW_FAKE;
8385     }
8386     return o;
8387 }
8388
8389 OP *
8390 Perl_ck_eval(pTHX_ OP *o)
8391 {
8392     dVAR;
8393
8394     PERL_ARGS_ASSERT_CK_EVAL;
8395
8396     PL_hints |= HINT_BLOCK_SCOPE;
8397     if (o->op_flags & OPf_KIDS) {
8398         SVOP * const kid = (SVOP*)cUNOPo->op_first;
8399         assert(kid);
8400
8401         if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
8402             LOGOP *enter;
8403
8404             cUNOPo->op_first = 0;
8405             op_free(o);
8406
8407             NewOp(1101, enter, 1, LOGOP);
8408             enter->op_type = OP_ENTERTRY;
8409             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
8410             enter->op_private = 0;
8411
8412             /* establish postfix order */
8413             enter->op_next = (OP*)enter;
8414
8415             o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
8416             o->op_type = OP_LEAVETRY;
8417             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
8418             enter->op_other = o;
8419             return o;
8420         }
8421         else {
8422             scalar((OP*)kid);
8423             PL_cv_has_eval = 1;
8424         }
8425     }
8426     else {
8427         const U8 priv = o->op_private;
8428         op_free(o);
8429         o = newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
8430     }
8431     o->op_targ = (PADOFFSET)PL_hints;
8432     if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
8433     if ((PL_hints & HINT_LOCALIZE_HH) != 0
8434      && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
8435         /* Store a copy of %^H that pp_entereval can pick up. */
8436         OP *hhop = newSVOP(OP_HINTSEVAL, 0,
8437                            MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
8438         cUNOPo->op_first->op_sibling = hhop;
8439         o->op_private |= OPpEVAL_HAS_HH;
8440     }
8441     if (!(o->op_private & OPpEVAL_BYTES)
8442          && FEATURE_UNIEVAL_IS_ENABLED)
8443             o->op_private |= OPpEVAL_UNICODE;
8444     return o;
8445 }
8446
8447 OP *
8448 Perl_ck_exec(pTHX_ OP *o)
8449 {
8450     PERL_ARGS_ASSERT_CK_EXEC;
8451
8452     if (o->op_flags & OPf_STACKED) {
8453         OP *kid;
8454         o = ck_fun(o);
8455         kid = cUNOPo->op_first->op_sibling;
8456         if (kid->op_type == OP_RV2GV)
8457             op_null(kid);
8458     }
8459     else
8460         o = listkids(o);
8461     return o;
8462 }
8463
8464 OP *
8465 Perl_ck_exists(pTHX_ OP *o)
8466 {
8467     dVAR;
8468
8469     PERL_ARGS_ASSERT_CK_EXISTS;
8470
8471     o = ck_fun(o);
8472     if (o->op_flags & OPf_KIDS) {
8473         OP * const kid = cUNOPo->op_first;
8474         if (kid->op_type == OP_ENTERSUB) {
8475             (void) ref(kid, o->op_type);
8476             if (kid->op_type != OP_RV2CV
8477                         && !(PL_parser && PL_parser->error_count))
8478                 Perl_croak(aTHX_
8479                           "exists argument is not a subroutine name");
8480             o->op_private |= OPpEXISTS_SUB;
8481         }
8482         else if (kid->op_type == OP_AELEM)
8483             o->op_flags |= OPf_SPECIAL;
8484         else if (kid->op_type != OP_HELEM)
8485             Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
8486                              "element or a subroutine");
8487         op_null(kid);
8488     }
8489     return o;
8490 }
8491
8492 OP *
8493 Perl_ck_rvconst(pTHX_ OP *o)
8494 {
8495     dVAR;
8496     SVOP * const kid = (SVOP*)cUNOPo->op_first;
8497
8498     PERL_ARGS_ASSERT_CK_RVCONST;
8499
8500     o->op_private |= (PL_hints & HINT_STRICT_REFS);
8501     if (o->op_type == OP_RV2CV)
8502         o->op_private &= ~1;
8503
8504     if (kid->op_type == OP_CONST) {
8505         int iscv;
8506         GV *gv;
8507         SV * const kidsv = kid->op_sv;
8508
8509         /* Is it a constant from cv_const_sv()? */
8510         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
8511             SV * const rsv = SvRV(kidsv);
8512             const svtype type = SvTYPE(rsv);
8513             const char *badtype = NULL;
8514
8515             switch (o->op_type) {
8516             case OP_RV2SV:
8517                 if (type > SVt_PVMG)
8518                     badtype = "a SCALAR";
8519                 break;
8520             case OP_RV2AV:
8521                 if (type != SVt_PVAV)
8522                     badtype = "an ARRAY";
8523                 break;
8524             case OP_RV2HV:
8525                 if (type != SVt_PVHV)
8526                     badtype = "a HASH";
8527                 break;
8528             case OP_RV2CV:
8529                 if (type != SVt_PVCV)
8530                     badtype = "a CODE";
8531                 break;
8532             }
8533             if (badtype)
8534                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
8535             return o;
8536         }
8537         if (SvTYPE(kidsv) == SVt_PVAV) return o;
8538         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
8539             const char *badthing;
8540             switch (o->op_type) {
8541             case OP_RV2SV:
8542                 badthing = "a SCALAR";
8543                 break;
8544             case OP_RV2AV:
8545                 badthing = "an ARRAY";
8546                 break;
8547             case OP_RV2HV:
8548                 badthing = "a HASH";
8549                 break;
8550             default:
8551                 badthing = NULL;
8552                 break;
8553             }
8554             if (badthing)
8555                 Perl_croak(aTHX_
8556                            "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
8557                            SVfARG(kidsv), badthing);
8558         }
8559         /*
8560          * This is a little tricky.  We only want to add the symbol if we
8561          * didn't add it in the lexer.  Otherwise we get duplicate strict
8562          * warnings.  But if we didn't add it in the lexer, we must at
8563          * least pretend like we wanted to add it even if it existed before,
8564          * or we get possible typo warnings.  OPpCONST_ENTERED says
8565          * whether the lexer already added THIS instance of this symbol.
8566          */
8567         iscv = (o->op_type == OP_RV2CV) * 2;
8568         do {
8569             gv = gv_fetchsv(kidsv,
8570                 iscv | !(kid->op_private & OPpCONST_ENTERED),
8571                 iscv
8572                     ? SVt_PVCV
8573                     : o->op_type == OP_RV2SV
8574                         ? SVt_PV
8575                         : o->op_type == OP_RV2AV
8576                             ? SVt_PVAV
8577                             : o->op_type == OP_RV2HV
8578                                 ? SVt_PVHV
8579                                 : SVt_PVGV);
8580         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
8581         if (gv) {
8582             kid->op_type = OP_GV;
8583             SvREFCNT_dec(kid->op_sv);
8584 #ifdef USE_ITHREADS
8585             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
8586             assert (sizeof(PADOP) <= sizeof(SVOP));
8587             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
8588             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
8589             GvIN_PAD_on(gv);
8590             PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
8591 #else
8592             kid->op_sv = SvREFCNT_inc_simple_NN(gv);
8593 #endif
8594             kid->op_private = 0;
8595             kid->op_ppaddr = PL_ppaddr[OP_GV];
8596             /* FAKE globs in the symbol table cause weird bugs (#77810) */
8597             SvFAKE_off(gv);
8598         }
8599     }
8600     return o;
8601 }
8602
8603 OP *
8604 Perl_ck_ftst(pTHX_ OP *o)
8605 {
8606     dVAR;
8607     const I32 type = o->op_type;
8608
8609     PERL_ARGS_ASSERT_CK_FTST;
8610
8611     if (o->op_flags & OPf_REF) {
8612         NOOP;
8613     }
8614     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
8615         SVOP * const kid = (SVOP*)cUNOPo->op_first;
8616         const OPCODE kidtype = kid->op_type;
8617
8618         if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
8619          && !kid->op_folded) {
8620             OP * const newop = newGVOP(type, OPf_REF,
8621                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
8622             op_free(o);
8623             return newop;
8624         }
8625         if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
8626             o->op_private |= OPpFT_ACCESS;
8627         if (PL_check[kidtype] == Perl_ck_ftst
8628                 && kidtype != OP_STAT && kidtype != OP_LSTAT) {
8629             o->op_private |= OPpFT_STACKED;
8630             kid->op_private |= OPpFT_STACKING;
8631             if (kidtype == OP_FTTTY && (
8632                    !(kid->op_private & OPpFT_STACKED)
8633                 || kid->op_private & OPpFT_AFTER_t
8634                ))
8635                 o->op_private |= OPpFT_AFTER_t;
8636         }
8637     }
8638     else {
8639         op_free(o);
8640         if (type == OP_FTTTY)
8641             o = newGVOP(type, OPf_REF, PL_stdingv);
8642         else
8643             o = newUNOP(type, 0, newDEFSVOP());
8644     }
8645     return o;
8646 }
8647
8648 OP *
8649 Perl_ck_fun(pTHX_ OP *o)
8650 {
8651     dVAR;
8652     const int type = o->op_type;
8653     I32 oa = PL_opargs[type] >> OASHIFT;
8654
8655     PERL_ARGS_ASSERT_CK_FUN;
8656
8657     if (o->op_flags & OPf_STACKED) {
8658         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
8659             oa &= ~OA_OPTIONAL;
8660         else
8661             return no_fh_allowed(o);
8662     }
8663
8664     if (o->op_flags & OPf_KIDS) {
8665         OP **tokid = &cLISTOPo->op_first;
8666         OP *kid = cLISTOPo->op_first;
8667         OP *sibl;
8668         I32 numargs = 0;
8669         bool seen_optional = FALSE;
8670
8671         if (kid->op_type == OP_PUSHMARK ||
8672             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
8673         {
8674             tokid = &kid->op_sibling;
8675             kid = kid->op_sibling;
8676         }
8677         if (kid && kid->op_type == OP_COREARGS) {
8678             bool optional = FALSE;
8679             while (oa) {
8680                 numargs++;
8681                 if (oa & OA_OPTIONAL) optional = TRUE;
8682                 oa = oa >> 4;
8683             }
8684             if (optional) o->op_private |= numargs;
8685             return o;
8686         }
8687
8688         while (oa) {
8689             if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
8690                 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV)
8691                     *tokid = kid = newDEFSVOP();
8692                 seen_optional = TRUE;
8693             }
8694             if (!kid) break;
8695
8696             numargs++;
8697             sibl = kid->op_sibling;
8698             switch (oa & 7) {
8699             case OA_SCALAR:
8700                 /* list seen where single (scalar) arg expected? */
8701                 if (numargs == 1 && !(oa >> 4)
8702                     && kid->op_type == OP_LIST && type != OP_SCALAR)
8703                 {
8704                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
8705                 }
8706                 if (type != OP_DELETE) scalar(kid);
8707                 break;
8708             case OA_LIST:
8709                 if (oa < 16) {
8710                     kid = 0;
8711                     continue;
8712                 }
8713                 else
8714                     list(kid);
8715                 break;
8716             case OA_AVREF:
8717                 if ((type == OP_PUSH || type == OP_UNSHIFT)
8718                     && !kid->op_sibling)
8719                     Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
8720                                    "Useless use of %s with no values",
8721                                    PL_op_desc[type]);
8722
8723                 if (kid->op_type == OP_CONST
8724                       && (  !SvROK(cSVOPx_sv(kid))
8725                          || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV  )
8726                         )
8727                     bad_type_pv(numargs, "array", PL_op_desc[type], 0, kid);
8728                 /* Defer checks to run-time if we have a scalar arg */
8729                 if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
8730                     op_lvalue(kid, type);
8731                 else {
8732                     scalar(kid);
8733                     /* diag_listed_as: push on reference is experimental */
8734                     Perl_ck_warner_d(aTHX_
8735                                      packWARN(WARN_EXPERIMENTAL__AUTODEREF),
8736                                     "%s on reference is experimental",
8737                                      PL_op_desc[type]);
8738                 }
8739                 break;
8740             case OA_HVREF:
8741                 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
8742                     bad_type_pv(numargs, "hash", PL_op_desc[type], 0, kid);
8743                 op_lvalue(kid, type);
8744                 break;
8745             case OA_CVREF:
8746                 {
8747                     OP * const newop = newUNOP(OP_NULL, 0, kid);
8748                     kid->op_sibling = 0;
8749                     newop->op_next = newop;
8750                     kid = newop;
8751                     kid->op_sibling = sibl;
8752                     *tokid = kid;
8753                 }
8754                 break;
8755             case OA_FILEREF:
8756                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
8757                     if (kid->op_type == OP_CONST &&
8758                         (kid->op_private & OPpCONST_BARE))
8759                     {
8760                         OP * const newop = newGVOP(OP_GV, 0,
8761                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
8762                         if (!(o->op_private & 1) && /* if not unop */
8763                             kid == cLISTOPo->op_last)
8764                             cLISTOPo->op_last = newop;
8765                         op_free(kid);
8766                         kid = newop;
8767                     }
8768                     else if (kid->op_type == OP_READLINE) {
8769                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
8770                         bad_type_pv(numargs, "HANDLE", OP_DESC(o), 0, kid);
8771                     }
8772                     else {
8773                         I32 flags = OPf_SPECIAL;
8774                         I32 priv = 0;
8775                         PADOFFSET targ = 0;
8776
8777                         /* is this op a FH constructor? */
8778                         if (is_handle_constructor(o,numargs)) {
8779                             const char *name = NULL;
8780                             STRLEN len = 0;
8781                             U32 name_utf8 = 0;
8782                             bool want_dollar = TRUE;
8783
8784                             flags = 0;
8785                             /* Set a flag to tell rv2gv to vivify
8786                              * need to "prove" flag does not mean something
8787                              * else already - NI-S 1999/05/07
8788                              */
8789                             priv = OPpDEREF;
8790                             if (kid->op_type == OP_PADSV) {
8791                                 SV *const namesv
8792                                     = PAD_COMPNAME_SV(kid->op_targ);
8793                                 name = SvPV_const(namesv, len);
8794                                 name_utf8 = SvUTF8(namesv);
8795                             }
8796                             else if (kid->op_type == OP_RV2SV
8797                                      && kUNOP->op_first->op_type == OP_GV)
8798                             {
8799                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
8800                                 name = GvNAME(gv);
8801                                 len = GvNAMELEN(gv);
8802                                 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
8803                             }
8804                             else if (kid->op_type == OP_AELEM
8805                                      || kid->op_type == OP_HELEM)
8806                             {
8807                                  OP *firstop;
8808                                  OP *op = ((BINOP*)kid)->op_first;
8809                                  name = NULL;
8810                                  if (op) {
8811                                       SV *tmpstr = NULL;
8812                                       const char * const a =
8813                                            kid->op_type == OP_AELEM ?
8814                                            "[]" : "{}";
8815                                       if (((op->op_type == OP_RV2AV) ||
8816                                            (op->op_type == OP_RV2HV)) &&
8817                                           (firstop = ((UNOP*)op)->op_first) &&
8818                                           (firstop->op_type == OP_GV)) {
8819                                            /* packagevar $a[] or $h{} */
8820                                            GV * const gv = cGVOPx_gv(firstop);
8821                                            if (gv)
8822                                                 tmpstr =
8823                                                      Perl_newSVpvf(aTHX_
8824                                                                    "%s%c...%c",
8825                                                                    GvNAME(gv),
8826                                                                    a[0], a[1]);
8827                                       }
8828                                       else if (op->op_type == OP_PADAV
8829                                                || op->op_type == OP_PADHV) {
8830                                            /* lexicalvar $a[] or $h{} */
8831                                            const char * const padname =
8832                                                 PAD_COMPNAME_PV(op->op_targ);
8833                                            if (padname)
8834                                                 tmpstr =
8835                                                      Perl_newSVpvf(aTHX_
8836                                                                    "%s%c...%c",
8837                                                                    padname + 1,
8838                                                                    a[0], a[1]);
8839                                       }
8840                                       if (tmpstr) {
8841                                            name = SvPV_const(tmpstr, len);
8842                                            name_utf8 = SvUTF8(tmpstr);
8843                                            sv_2mortal(tmpstr);
8844                                       }
8845                                  }
8846                                  if (!name) {
8847                                       name = "__ANONIO__";
8848                                       len = 10;
8849                                       want_dollar = FALSE;
8850                                  }
8851                                  op_lvalue(kid, type);
8852                             }
8853                             if (name) {
8854                                 SV *namesv;
8855                                 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
8856                                 namesv = PAD_SVl(targ);
8857                                 if (want_dollar && *name != '$')
8858                                     sv_setpvs(namesv, "$");
8859                                 else
8860                                     sv_setpvs(namesv, "");
8861                                 sv_catpvn(namesv, name, len);
8862                                 if ( name_utf8 ) SvUTF8_on(namesv);
8863                             }
8864                         }
8865                         kid->op_sibling = 0;
8866                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
8867                         kid->op_targ = targ;
8868                         kid->op_private |= priv;
8869                     }
8870                     kid->op_sibling = sibl;
8871                     *tokid = kid;
8872                 }
8873                 scalar(kid);
8874                 break;
8875             case OA_SCALARREF:
8876                 if ((type == OP_UNDEF || type == OP_POS)
8877                     && numargs == 1 && !(oa >> 4)
8878                     && kid->op_type == OP_LIST)
8879                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
8880                 op_lvalue(scalar(kid), type);
8881                 break;
8882             }
8883             oa >>= 4;
8884             tokid = &kid->op_sibling;
8885             kid = kid->op_sibling;
8886         }
8887         /* FIXME - should the numargs or-ing move after the too many
8888          * arguments check? */
8889         o->op_private |= numargs;
8890         if (kid)
8891             return too_many_arguments_pv(o,OP_DESC(o), 0);
8892         listkids(o);
8893     }
8894     else if (PL_opargs[type] & OA_DEFGV) {
8895         /* Ordering of these two is important to keep f_map.t passing.  */
8896         op_free(o);
8897         return newUNOP(type, 0, newDEFSVOP());
8898     }
8899
8900     if (oa) {
8901         while (oa & OA_OPTIONAL)
8902             oa >>= 4;
8903         if (oa && oa != OA_LIST)
8904             return too_few_arguments_pv(o,OP_DESC(o), 0);
8905     }
8906     return o;
8907 }
8908
8909 OP *
8910 Perl_ck_glob(pTHX_ OP *o)
8911 {
8912     dVAR;
8913     GV *gv;
8914
8915     PERL_ARGS_ASSERT_CK_GLOB;
8916
8917     o = ck_fun(o);
8918     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
8919         op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
8920
8921     if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
8922     {
8923         /* convert
8924          *     glob
8925          *       \ null - const(wildcard)
8926          * into
8927          *     null
8928          *       \ enter
8929          *            \ list
8930          *                 \ mark - glob - rv2cv
8931          *                             |        \ gv(CORE::GLOBAL::glob)
8932          *                             |
8933          *                              \ null - const(wildcard)
8934          */
8935         o->op_flags |= OPf_SPECIAL;
8936         o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
8937         o = S_new_entersubop(aTHX_ gv, o);
8938         o = newUNOP(OP_NULL, 0, o);
8939         o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
8940         return o;
8941     }
8942     else o->op_flags &= ~OPf_SPECIAL;
8943 #if !defined(PERL_EXTERNAL_GLOB)
8944     if (!PL_globhook) {
8945         ENTER;
8946         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
8947                                newSVpvs("File::Glob"), NULL, NULL, NULL);
8948         LEAVE;
8949     }
8950 #endif /* !PERL_EXTERNAL_GLOB */
8951     gv = (GV *)newSV(0);
8952     gv_init(gv, 0, "", 0, 0);
8953     gv_IOadd(gv);
8954     op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
8955     SvREFCNT_dec_NN(gv); /* newGVOP increased it */
8956     scalarkids(o);
8957     return o;
8958 }
8959
8960 OP *
8961 Perl_ck_grep(pTHX_ OP *o)
8962 {
8963     dVAR;
8964     LOGOP *gwop;
8965     OP *kid;
8966     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
8967     PADOFFSET offset;
8968
8969     PERL_ARGS_ASSERT_CK_GREP;
8970
8971     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
8972     /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
8973
8974     if (o->op_flags & OPf_STACKED) {
8975         kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
8976         if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
8977             return no_fh_allowed(o);
8978         o->op_flags &= ~OPf_STACKED;
8979     }
8980     kid = cLISTOPo->op_first->op_sibling;
8981     if (type == OP_MAPWHILE)
8982         list(kid);
8983     else
8984         scalar(kid);
8985     o = ck_fun(o);
8986     if (PL_parser && PL_parser->error_count)
8987         return o;
8988     kid = cLISTOPo->op_first->op_sibling;
8989     if (kid->op_type != OP_NULL)
8990         Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
8991     kid = kUNOP->op_first;
8992
8993     NewOp(1101, gwop, 1, LOGOP);
8994     gwop->op_type = type;
8995     gwop->op_ppaddr = PL_ppaddr[type];
8996     gwop->op_first = o;
8997     gwop->op_flags |= OPf_KIDS;
8998     gwop->op_other = LINKLIST(kid);
8999     kid->op_next = (OP*)gwop;
9000     offset = pad_findmy_pvs("$_", 0);
9001     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
9002         o->op_private = gwop->op_private = 0;
9003         gwop->op_targ = pad_alloc(type, SVs_PADTMP);
9004     }
9005     else {
9006         o->op_private = gwop->op_private = OPpGREP_LEX;
9007         gwop->op_targ = o->op_targ = offset;
9008     }
9009
9010     kid = cLISTOPo->op_first->op_sibling;
9011     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
9012         op_lvalue(kid, OP_GREPSTART);
9013
9014     return (OP*)gwop;
9015 }
9016
9017 OP *
9018 Perl_ck_index(pTHX_ OP *o)
9019 {
9020     PERL_ARGS_ASSERT_CK_INDEX;
9021
9022     if (o->op_flags & OPf_KIDS) {
9023         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
9024         if (kid)
9025             kid = kid->op_sibling;                      /* get past "big" */
9026         if (kid && kid->op_type == OP_CONST) {
9027             const bool save_taint = TAINT_get;
9028             SV *sv = kSVOP->op_sv;
9029             if ((!SvPOK(sv) || SvNIOKp(sv)) && SvOK(sv) && !SvROK(sv)) {
9030                 sv = newSV(0);
9031                 sv_copypv(sv, kSVOP->op_sv);
9032                 SvREFCNT_dec_NN(kSVOP->op_sv);
9033                 kSVOP->op_sv = sv;
9034             }
9035             if (SvOK(sv)) fbm_compile(sv, 0);
9036             TAINT_set(save_taint);
9037 #ifdef NO_TAINT_SUPPORT
9038             PERL_UNUSED_VAR(save_taint);
9039 #endif
9040         }
9041     }
9042     return ck_fun(o);
9043 }
9044
9045 OP *
9046 Perl_ck_lfun(pTHX_ OP *o)
9047 {
9048     const OPCODE type = o->op_type;
9049
9050     PERL_ARGS_ASSERT_CK_LFUN;
9051
9052     return modkids(ck_fun(o), type);
9053 }
9054
9055 OP *
9056 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
9057 {
9058     PERL_ARGS_ASSERT_CK_DEFINED;
9059
9060     if ((o->op_flags & OPf_KIDS)) {
9061         switch (cUNOPo->op_first->op_type) {
9062         case OP_RV2AV:
9063         case OP_PADAV:
9064         case OP_AASSIGN:                /* Is this a good idea? */
9065             Perl_croak(aTHX_ "Can't use 'defined(@array)'"
9066                              " (Maybe you should just omit the defined()?)");
9067         break;
9068         case OP_RV2HV:
9069         case OP_PADHV:
9070             Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
9071                              " (Maybe you should just omit the defined()?)");
9072             break;
9073         default:
9074             /* no warning */
9075             break;
9076         }
9077     }
9078     return ck_rfun(o);
9079 }
9080
9081 OP *
9082 Perl_ck_readline(pTHX_ OP *o)
9083 {
9084     PERL_ARGS_ASSERT_CK_READLINE;
9085
9086     if (o->op_flags & OPf_KIDS) {
9087          OP *kid = cLISTOPo->op_first;
9088          if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
9089     }
9090     else {
9091         OP * const newop
9092             = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
9093         op_free(o);
9094         return newop;
9095     }
9096     return o;
9097 }
9098
9099 OP *
9100 Perl_ck_rfun(pTHX_ OP *o)
9101 {
9102     const OPCODE type = o->op_type;
9103
9104     PERL_ARGS_ASSERT_CK_RFUN;
9105
9106     return refkids(ck_fun(o), type);
9107 }
9108
9109 OP *
9110 Perl_ck_listiob(pTHX_ OP *o)
9111 {
9112     OP *kid;
9113
9114     PERL_ARGS_ASSERT_CK_LISTIOB;
9115
9116     kid = cLISTOPo->op_first;
9117     if (!kid) {
9118         o = force_list(o);
9119         kid = cLISTOPo->op_first;
9120     }
9121     if (kid->op_type == OP_PUSHMARK)
9122         kid = kid->op_sibling;
9123     if (kid && o->op_flags & OPf_STACKED)
9124         kid = kid->op_sibling;
9125     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
9126         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
9127          && !kid->op_folded) {
9128             o->op_flags |= OPf_STACKED; /* make it a filehandle */
9129             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
9130             cLISTOPo->op_first->op_sibling = kid;
9131             cLISTOPo->op_last = kid;
9132             kid = kid->op_sibling;
9133         }
9134     }
9135
9136     if (!kid)
9137         op_append_elem(o->op_type, o, newDEFSVOP());
9138
9139     if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
9140     return listkids(o);
9141 }
9142
9143 OP *
9144 Perl_ck_smartmatch(pTHX_ OP *o)
9145 {
9146     dVAR;
9147     PERL_ARGS_ASSERT_CK_SMARTMATCH;
9148     if (0 == (o->op_flags & OPf_SPECIAL)) {
9149         OP *first  = cBINOPo->op_first;
9150         OP *second = first->op_sibling;
9151
9152         /* Implicitly take a reference to an array or hash */
9153         first->op_sibling = NULL;
9154         first = cBINOPo->op_first = ref_array_or_hash(first);
9155         second = first->op_sibling = ref_array_or_hash(second);
9156
9157         /* Implicitly take a reference to a regular expression */
9158         if (first->op_type == OP_MATCH) {
9159             first->op_type = OP_QR;
9160             first->op_ppaddr = PL_ppaddr[OP_QR];
9161         }
9162         if (second->op_type == OP_MATCH) {
9163             second->op_type = OP_QR;
9164             second->op_ppaddr = PL_ppaddr[OP_QR];
9165         }
9166     }
9167
9168     return o;
9169 }
9170
9171
9172 OP *
9173 Perl_ck_sassign(pTHX_ OP *o)
9174 {
9175     dVAR;
9176     OP * const kid = cLISTOPo->op_first;
9177
9178     PERL_ARGS_ASSERT_CK_SASSIGN;
9179
9180     /* has a disposable target? */
9181     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
9182         && !(kid->op_flags & OPf_STACKED)
9183         /* Cannot steal the second time! */
9184         && !(kid->op_private & OPpTARGET_MY)
9185         )
9186     {
9187         OP * const kkid = kid->op_sibling;
9188
9189         /* Can just relocate the target. */
9190         if (kkid && kkid->op_type == OP_PADSV
9191             && !(kkid->op_private & OPpLVAL_INTRO))
9192         {
9193             kid->op_targ = kkid->op_targ;
9194             kkid->op_targ = 0;
9195             /* Now we do not need PADSV and SASSIGN. */
9196             kid->op_sibling = o->op_sibling;    /* NULL */
9197             cLISTOPo->op_first = NULL;
9198             op_free(o);
9199             op_free(kkid);
9200             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
9201             return kid;
9202         }
9203     }
9204     if (kid->op_sibling) {
9205         OP *kkid = kid->op_sibling;
9206         /* For state variable assignment, kkid is a list op whose op_last
9207            is a padsv. */
9208         if ((kkid->op_type == OP_PADSV ||
9209              (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
9210               (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
9211              )
9212             )
9213                 && (kkid->op_private & OPpLVAL_INTRO)
9214                 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
9215             const PADOFFSET target = kkid->op_targ;
9216             OP *const other = newOP(OP_PADSV,
9217                                     kkid->op_flags
9218                                     | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
9219             OP *const first = newOP(OP_NULL, 0);
9220             OP *const nullop = newCONDOP(0, first, o, other);
9221             OP *const condop = first->op_next;
9222             /* hijacking PADSTALE for uninitialized state variables */
9223             SvPADSTALE_on(PAD_SVl(target));
9224
9225             condop->op_type = OP_ONCE;
9226             condop->op_ppaddr = PL_ppaddr[OP_ONCE];
9227             condop->op_targ = target;
9228             other->op_targ = target;
9229
9230             /* Because we change the type of the op here, we will skip the
9231                assignment binop->op_last = binop->op_first->op_sibling; at the
9232                end of Perl_newBINOP(). So need to do it here. */
9233             cBINOPo->op_last = cBINOPo->op_first->op_sibling;
9234
9235             return nullop;
9236         }
9237     }
9238     return o;
9239 }
9240
9241 OP *
9242 Perl_ck_match(pTHX_ OP *o)
9243 {
9244     dVAR;
9245
9246     PERL_ARGS_ASSERT_CK_MATCH;
9247
9248     if (o->op_type != OP_QR && PL_compcv) {
9249         const PADOFFSET offset = pad_findmy_pvs("$_", 0);
9250         if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
9251             o->op_targ = offset;
9252             o->op_private |= OPpTARGET_MY;
9253         }
9254     }
9255     if (o->op_type == OP_MATCH || o->op_type == OP_QR)
9256         o->op_private |= OPpRUNTIME;
9257     return o;
9258 }
9259
9260 OP *
9261 Perl_ck_method(pTHX_ OP *o)
9262 {
9263     OP * const kid = cUNOPo->op_first;
9264
9265     PERL_ARGS_ASSERT_CK_METHOD;
9266
9267     if (kid->op_type == OP_CONST) {
9268         SV* sv = kSVOP->op_sv;
9269         const char * const method = SvPVX_const(sv);
9270         if (!(strchr(method, ':') || strchr(method, '\''))) {
9271             OP *cmop;
9272             if (!SvIsCOW_shared_hash(sv)) {
9273                 sv = newSVpvn_share(method, SvUTF8(sv) ? -(I32)SvCUR(sv) : (I32)SvCUR(sv), 0);
9274             }
9275             else {
9276                 kSVOP->op_sv = NULL;
9277             }
9278             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
9279             op_free(o);
9280             return cmop;
9281         }
9282     }
9283     return o;
9284 }
9285
9286 OP *
9287 Perl_ck_null(pTHX_ OP *o)
9288 {
9289     PERL_ARGS_ASSERT_CK_NULL;
9290     PERL_UNUSED_CONTEXT;
9291     return o;
9292 }
9293
9294 OP *
9295 Perl_ck_open(pTHX_ OP *o)
9296 {
9297     dVAR;
9298
9299     PERL_ARGS_ASSERT_CK_OPEN;
9300
9301     S_io_hints(aTHX_ o);
9302     {
9303          /* In case of three-arg dup open remove strictness
9304           * from the last arg if it is a bareword. */
9305          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
9306          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
9307          OP *oa;
9308          const char *mode;
9309
9310          if ((last->op_type == OP_CONST) &&             /* The bareword. */
9311              (last->op_private & OPpCONST_BARE) &&
9312              (last->op_private & OPpCONST_STRICT) &&
9313              (oa = first->op_sibling) &&                /* The fh. */
9314              (oa = oa->op_sibling) &&                   /* The mode. */
9315              (oa->op_type == OP_CONST) &&
9316              SvPOK(((SVOP*)oa)->op_sv) &&
9317              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
9318              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
9319              (last == oa->op_sibling))                  /* The bareword. */
9320               last->op_private &= ~OPpCONST_STRICT;
9321     }
9322     return ck_fun(o);
9323 }
9324
9325 OP *
9326 Perl_ck_repeat(pTHX_ OP *o)
9327 {
9328     PERL_ARGS_ASSERT_CK_REPEAT;
9329
9330     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
9331         o->op_private |= OPpREPEAT_DOLIST;
9332         cBINOPo->op_first = force_list(cBINOPo->op_first);
9333     }
9334     else
9335         scalar(o);
9336     return o;
9337 }
9338
9339 OP *
9340 Perl_ck_require(pTHX_ OP *o)
9341 {
9342     dVAR;
9343     GV* gv;
9344
9345     PERL_ARGS_ASSERT_CK_REQUIRE;
9346
9347     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
9348         SVOP * const kid = (SVOP*)cUNOPo->op_first;
9349
9350         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
9351             SV * const sv = kid->op_sv;
9352             U32 was_readonly = SvREADONLY(sv);
9353             char *s;
9354             STRLEN len;
9355             const char *end;
9356
9357             if (was_readonly) {
9358                     SvREADONLY_off(sv);
9359             }
9360             if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
9361
9362             s = SvPVX(sv);
9363             len = SvCUR(sv);
9364             end = s + len;
9365             for (; s < end; s++) {
9366                 if (*s == ':' && s[1] == ':') {
9367                     *s = '/';
9368                     Move(s+2, s+1, end - s - 1, char);
9369                     --end;
9370                 }
9371             }
9372             SvEND_set(sv, end);
9373             sv_catpvs(sv, ".pm");
9374             SvFLAGS(sv) |= was_readonly;
9375         }
9376     }
9377
9378     if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
9379         /* handle override, if any */
9380      && (gv = gv_override("require", 7))) {
9381         OP *kid, *newop;
9382         if (o->op_flags & OPf_KIDS) {
9383             kid = cUNOPo->op_first;
9384             cUNOPo->op_first = NULL;
9385         }
9386         else {
9387             kid = newDEFSVOP();
9388         }
9389         op_free(o);
9390         newop = S_new_entersubop(aTHX_ gv, kid);
9391         return newop;
9392     }
9393
9394     return scalar(ck_fun(o));
9395 }
9396
9397 OP *
9398 Perl_ck_return(pTHX_ OP *o)
9399 {
9400     dVAR;
9401     OP *kid;
9402
9403     PERL_ARGS_ASSERT_CK_RETURN;
9404
9405     kid = cLISTOPo->op_first->op_sibling;
9406     if (CvLVALUE(PL_compcv)) {
9407         for (; kid; kid = kid->op_sibling)
9408             op_lvalue(kid, OP_LEAVESUBLV);
9409     }
9410
9411     return o;
9412 }
9413
9414 OP *
9415 Perl_ck_select(pTHX_ OP *o)
9416 {
9417     dVAR;
9418     OP* kid;
9419
9420     PERL_ARGS_ASSERT_CK_SELECT;
9421
9422     if (o->op_flags & OPf_KIDS) {
9423         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
9424         if (kid && kid->op_sibling) {
9425             o->op_type = OP_SSELECT;
9426             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
9427             o = ck_fun(o);
9428             return fold_constants(op_integerize(op_std_init(o)));
9429         }
9430     }
9431     o = ck_fun(o);
9432     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
9433     if (kid && kid->op_type == OP_RV2GV)
9434         kid->op_private &= ~HINT_STRICT_REFS;
9435     return o;
9436 }
9437
9438 OP *
9439 Perl_ck_shift(pTHX_ OP *o)
9440 {
9441     dVAR;
9442     const I32 type = o->op_type;
9443
9444     PERL_ARGS_ASSERT_CK_SHIFT;
9445
9446     if (!(o->op_flags & OPf_KIDS)) {
9447         OP *argop;
9448
9449         if (!CvUNIQUE(PL_compcv)) {
9450             o->op_flags |= OPf_SPECIAL;
9451             return o;
9452         }
9453
9454         argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
9455         op_free(o);
9456         return newUNOP(type, 0, scalar(argop));
9457     }
9458     return scalar(ck_fun(o));
9459 }
9460
9461 OP *
9462 Perl_ck_sort(pTHX_ OP *o)
9463 {
9464     dVAR;
9465     OP *firstkid;
9466     OP *kid;
9467     HV * const hinthv =
9468         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
9469     U8 stacked;
9470
9471     PERL_ARGS_ASSERT_CK_SORT;
9472
9473     if (hinthv) {
9474             SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
9475             if (svp) {
9476                 const I32 sorthints = (I32)SvIV(*svp);
9477                 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
9478                     o->op_private |= OPpSORT_QSORT;
9479                 if ((sorthints & HINT_SORT_STABLE) != 0)
9480                     o->op_private |= OPpSORT_STABLE;
9481             }
9482     }
9483
9484     if (o->op_flags & OPf_STACKED)
9485         simplify_sort(o);
9486     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
9487
9488     if ((stacked = o->op_flags & OPf_STACKED)) {        /* may have been cleared */
9489         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
9490
9491         /* if the first arg is a code block, process it and mark sort as
9492          * OPf_SPECIAL */
9493         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
9494             LINKLIST(kid);
9495             if (kid->op_type == OP_LEAVE)
9496                     op_null(kid);                       /* wipe out leave */
9497             /* Prevent execution from escaping out of the sort block. */
9498             kid->op_next = 0;
9499
9500             /* provide scalar context for comparison function/block */
9501             kid = scalar(firstkid);
9502             kid->op_next = kid;
9503             o->op_flags |= OPf_SPECIAL;
9504         }
9505
9506         firstkid = firstkid->op_sibling;
9507     }
9508
9509     for (kid = firstkid; kid; kid = kid->op_sibling) {
9510         /* provide list context for arguments */
9511         list(kid);
9512         if (stacked)
9513             op_lvalue(kid, OP_GREPSTART);
9514     }
9515
9516     return o;
9517 }
9518
9519 /* for sort { X } ..., where X is one of
9520  *   $a <=> $b, $b <= $a, $a cmp $b, $b cmp $a
9521  * elide the second child of the sort (the one containing X),
9522  * and set these flags as appropriate
9523         OPpSORT_NUMERIC;
9524         OPpSORT_INTEGER;
9525         OPpSORT_DESCEND;
9526  * Also, check and warn on lexical $a, $b.
9527  */
9528
9529 STATIC void
9530 S_simplify_sort(pTHX_ OP *o)
9531 {
9532     dVAR;
9533     OP *kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
9534     OP *k;
9535     int descending;
9536     GV *gv;
9537     const char *gvname;
9538     bool have_scopeop;
9539
9540     PERL_ARGS_ASSERT_SIMPLIFY_SORT;
9541
9542     kid = kUNOP->op_first;                              /* get past null */
9543     if (!(have_scopeop = kid->op_type == OP_SCOPE)
9544      && kid->op_type != OP_LEAVE)
9545         return;
9546     kid = kLISTOP->op_last;                             /* get past scope */
9547     switch(kid->op_type) {
9548         case OP_NCMP:
9549         case OP_I_NCMP:
9550         case OP_SCMP:
9551             if (!have_scopeop) goto padkids;
9552             break;
9553         default:
9554             return;
9555     }
9556     k = kid;                                            /* remember this node*/
9557     if (kBINOP->op_first->op_type != OP_RV2SV
9558      || kBINOP->op_last ->op_type != OP_RV2SV)
9559     {
9560         /*
9561            Warn about my($a) or my($b) in a sort block, *if* $a or $b is
9562            then used in a comparison.  This catches most, but not
9563            all cases.  For instance, it catches
9564                sort { my($a); $a <=> $b }
9565            but not
9566                sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
9567            (although why you'd do that is anyone's guess).
9568         */
9569
9570        padkids:
9571         if (!ckWARN(WARN_SYNTAX)) return;
9572         kid = kBINOP->op_first;
9573         do {
9574             if (kid->op_type == OP_PADSV) {
9575                 SV * const name = AvARRAY(PL_comppad_name)[kid->op_targ];
9576                 if (SvCUR(name) == 2 && *SvPVX(name) == '$'
9577                  && (SvPVX(name)[1] == 'a' || SvPVX(name)[1] == 'b'))
9578                     /* diag_listed_as: "my %s" used in sort comparison */
9579                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9580                                      "\"%s %s\" used in sort comparison",
9581                                       SvPAD_STATE(name) ? "state" : "my",
9582                                       SvPVX(name));
9583             }
9584         } while ((kid = kid->op_sibling));
9585         return;
9586     }
9587     kid = kBINOP->op_first;                             /* get past cmp */
9588     if (kUNOP->op_first->op_type != OP_GV)
9589         return;
9590     kid = kUNOP->op_first;                              /* get past rv2sv */
9591     gv = kGVOP_gv;
9592     if (GvSTASH(gv) != PL_curstash)
9593         return;
9594     gvname = GvNAME(gv);
9595     if (*gvname == 'a' && gvname[1] == '\0')
9596         descending = 0;
9597     else if (*gvname == 'b' && gvname[1] == '\0')
9598         descending = 1;
9599     else
9600         return;
9601
9602     kid = k;                                            /* back to cmp */
9603     /* already checked above that it is rv2sv */
9604     kid = kBINOP->op_last;                              /* down to 2nd arg */
9605     if (kUNOP->op_first->op_type != OP_GV)
9606         return;
9607     kid = kUNOP->op_first;                              /* get past rv2sv */
9608     gv = kGVOP_gv;
9609     if (GvSTASH(gv) != PL_curstash)
9610         return;
9611     gvname = GvNAME(gv);
9612     if ( descending
9613          ? !(*gvname == 'a' && gvname[1] == '\0')
9614          : !(*gvname == 'b' && gvname[1] == '\0'))
9615         return;
9616     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
9617     if (descending)
9618         o->op_private |= OPpSORT_DESCEND;
9619     if (k->op_type == OP_NCMP)
9620         o->op_private |= OPpSORT_NUMERIC;
9621     if (k->op_type == OP_I_NCMP)
9622         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
9623     kid = cLISTOPo->op_first->op_sibling;
9624     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
9625     op_free(kid);                                     /* then delete it */
9626 }
9627
9628 OP *
9629 Perl_ck_split(pTHX_ OP *o)
9630 {
9631     dVAR;
9632     OP *kid;
9633
9634     PERL_ARGS_ASSERT_CK_SPLIT;
9635
9636     if (o->op_flags & OPf_STACKED)
9637         return no_fh_allowed(o);
9638
9639     kid = cLISTOPo->op_first;
9640     if (kid->op_type != OP_NULL)
9641         Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
9642     kid = kid->op_sibling;
9643     op_free(cLISTOPo->op_first);
9644     if (kid)
9645         cLISTOPo->op_first = kid;
9646     else {
9647         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
9648         cLISTOPo->op_last = kid; /* There was only one element previously */
9649     }
9650
9651     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
9652         OP * const sibl = kid->op_sibling;
9653         kid->op_sibling = 0;
9654         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0, 0); /* OPf_SPECIAL is used to trigger split " " behavior */
9655         if (cLISTOPo->op_first == cLISTOPo->op_last)
9656             cLISTOPo->op_last = kid;
9657         cLISTOPo->op_first = kid;
9658         kid->op_sibling = sibl;
9659     }
9660
9661     kid->op_type = OP_PUSHRE;
9662     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
9663     scalar(kid);
9664     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
9665       Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
9666                      "Use of /g modifier is meaningless in split");
9667     }
9668
9669     if (!kid->op_sibling)
9670         op_append_elem(OP_SPLIT, o, newDEFSVOP());
9671
9672     kid = kid->op_sibling;
9673     assert(kid);
9674     scalar(kid);
9675
9676     if (!kid->op_sibling)
9677     {
9678         op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
9679         o->op_private |= OPpSPLIT_IMPLIM;
9680     }
9681     assert(kid->op_sibling);
9682
9683     kid = kid->op_sibling;
9684     scalar(kid);
9685
9686     if (kid->op_sibling)
9687         return too_many_arguments_pv(o,OP_DESC(o), 0);
9688
9689     return o;
9690 }
9691
9692 OP *
9693 Perl_ck_join(pTHX_ OP *o)
9694 {
9695     const OP * const kid = cLISTOPo->op_first->op_sibling;
9696
9697     PERL_ARGS_ASSERT_CK_JOIN;
9698
9699     if (kid && kid->op_type == OP_MATCH) {
9700         if (ckWARN(WARN_SYNTAX)) {
9701             const REGEXP *re = PM_GETRE(kPMOP);
9702             const SV *msg = re
9703                     ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
9704                                             SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
9705                     : newSVpvs_flags( "STRING", SVs_TEMP );
9706             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9707                         "/%"SVf"/ should probably be written as \"%"SVf"\"",
9708                         SVfARG(msg), SVfARG(msg));
9709         }
9710     }
9711     return ck_fun(o);
9712 }
9713
9714 /*
9715 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
9716
9717 Examines an op, which is expected to identify a subroutine at runtime,
9718 and attempts to determine at compile time which subroutine it identifies.
9719 This is normally used during Perl compilation to determine whether
9720 a prototype can be applied to a function call.  I<cvop> is the op
9721 being considered, normally an C<rv2cv> op.  A pointer to the identified
9722 subroutine is returned, if it could be determined statically, and a null
9723 pointer is returned if it was not possible to determine statically.
9724
9725 Currently, the subroutine can be identified statically if the RV that the
9726 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
9727 A C<gv> op is suitable if the GV's CV slot is populated.  A C<const> op is
9728 suitable if the constant value must be an RV pointing to a CV.  Details of
9729 this process may change in future versions of Perl.  If the C<rv2cv> op
9730 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
9731 the subroutine statically: this flag is used to suppress compile-time
9732 magic on a subroutine call, forcing it to use default runtime behaviour.
9733
9734 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
9735 of a GV reference is modified.  If a GV was examined and its CV slot was
9736 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
9737 If the op is not optimised away, and the CV slot is later populated with
9738 a subroutine having a prototype, that flag eventually triggers the warning
9739 "called too early to check prototype".
9740
9741 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
9742 of returning a pointer to the subroutine it returns a pointer to the
9743 GV giving the most appropriate name for the subroutine in this context.
9744 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
9745 (C<CvANON>) subroutine that is referenced through a GV it will be the
9746 referencing GV.  The resulting C<GV*> is cast to C<CV*> to be returned.
9747 A null pointer is returned as usual if there is no statically-determinable
9748 subroutine.
9749
9750 =cut
9751 */
9752
9753 /* shared by toke.c:yylex */
9754 CV *
9755 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
9756 {
9757     PADNAME *name = PAD_COMPNAME(off);
9758     CV *compcv = PL_compcv;
9759     while (PadnameOUTER(name)) {
9760         assert(PARENT_PAD_INDEX(name));
9761         compcv = CvOUTSIDE(PL_compcv);
9762         name = PadlistNAMESARRAY(CvPADLIST(compcv))
9763                 [off = PARENT_PAD_INDEX(name)];
9764     }
9765     assert(!PadnameIsOUR(name));
9766     if (!PadnameIsSTATE(name) && SvMAGICAL(name)) {
9767         MAGIC * mg = mg_find(name, PERL_MAGIC_proto);
9768         assert(mg);
9769         assert(mg->mg_obj);
9770         return (CV *)mg->mg_obj;
9771     }
9772     return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
9773 }
9774
9775 CV *
9776 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
9777 {
9778     OP *rvop;
9779     CV *cv;
9780     GV *gv;
9781     PERL_ARGS_ASSERT_RV2CV_OP_CV;
9782     if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
9783         Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
9784     if (cvop->op_type != OP_RV2CV)
9785         return NULL;
9786     if (cvop->op_private & OPpENTERSUB_AMPER)
9787         return NULL;
9788     if (!(cvop->op_flags & OPf_KIDS))
9789         return NULL;
9790     rvop = cUNOPx(cvop)->op_first;
9791     switch (rvop->op_type) {
9792         case OP_GV: {
9793             gv = cGVOPx_gv(rvop);
9794             cv = GvCVu(gv);
9795             if (!cv) {
9796                 if (flags & RV2CVOPCV_MARK_EARLY)
9797                     rvop->op_private |= OPpEARLY_CV;
9798                 return NULL;
9799             }
9800         } break;
9801         case OP_CONST: {
9802             SV *rv = cSVOPx_sv(rvop);
9803             if (!SvROK(rv))
9804                 return NULL;
9805             cv = (CV*)SvRV(rv);
9806             gv = NULL;
9807         } break;
9808         case OP_PADCV: {
9809             cv = find_lexical_cv(rvop->op_targ);
9810             gv = NULL;
9811         } break;
9812         default: {
9813             return NULL;
9814         } NOT_REACHED; /* NOTREACHED */
9815     }
9816     if (SvTYPE((SV*)cv) != SVt_PVCV)
9817         return NULL;
9818     if (flags & RV2CVOPCV_RETURN_NAME_GV) {
9819         if (!CvANON(cv) || !gv)
9820             gv = CvGV(cv);
9821         return (CV*)gv;
9822     } else {
9823         return cv;
9824     }
9825 }
9826
9827 /*
9828 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
9829
9830 Performs the default fixup of the arguments part of an C<entersub>
9831 op tree.  This consists of applying list context to each of the
9832 argument ops.  This is the standard treatment used on a call marked
9833 with C<&>, or a method call, or a call through a subroutine reference,
9834 or any other call where the callee can't be identified at compile time,
9835 or a call where the callee has no prototype.
9836
9837 =cut
9838 */
9839
9840 OP *
9841 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
9842 {
9843     OP *aop;
9844     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
9845     aop = cUNOPx(entersubop)->op_first;
9846     if (!aop->op_sibling)
9847         aop = cUNOPx(aop)->op_first;
9848     for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
9849         list(aop);
9850         op_lvalue(aop, OP_ENTERSUB);
9851     }
9852     return entersubop;
9853 }
9854
9855 /*
9856 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
9857
9858 Performs the fixup of the arguments part of an C<entersub> op tree
9859 based on a subroutine prototype.  This makes various modifications to
9860 the argument ops, from applying context up to inserting C<refgen> ops,
9861 and checking the number and syntactic types of arguments, as directed by
9862 the prototype.  This is the standard treatment used on a subroutine call,
9863 not marked with C<&>, where the callee can be identified at compile time
9864 and has a prototype.
9865
9866 I<protosv> supplies the subroutine prototype to be applied to the call.
9867 It may be a normal defined scalar, of which the string value will be used.
9868 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
9869 that has been cast to C<SV*>) which has a prototype.  The prototype
9870 supplied, in whichever form, does not need to match the actual callee
9871 referenced by the op tree.
9872
9873 If the argument ops disagree with the prototype, for example by having
9874 an unacceptable number of arguments, a valid op tree is returned anyway.
9875 The error is reflected in the parser state, normally resulting in a single
9876 exception at the top level of parsing which covers all the compilation
9877 errors that occurred.  In the error message, the callee is referred to
9878 by the name defined by the I<namegv> parameter.
9879
9880 =cut
9881 */
9882
9883 OP *
9884 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
9885 {
9886     STRLEN proto_len;
9887     const char *proto, *proto_end;
9888     OP *aop, *prev, *cvop;
9889     int optional = 0;
9890     I32 arg = 0;
9891     I32 contextclass = 0;
9892     const char *e = NULL;
9893     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
9894     if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
9895         Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
9896                    "flags=%lx", (unsigned long) SvFLAGS(protosv));
9897     if (SvTYPE(protosv) == SVt_PVCV)
9898          proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
9899     else proto = SvPV(protosv, proto_len);
9900     proto = S_strip_spaces(aTHX_ proto, &proto_len);
9901     proto_end = proto + proto_len;
9902     aop = cUNOPx(entersubop)->op_first;
9903     if (!aop->op_sibling)
9904         aop = cUNOPx(aop)->op_first;
9905     prev = aop;
9906     aop = aop->op_sibling;
9907     for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9908     while (aop != cvop) {
9909         OP* o3 = aop;
9910
9911         if (proto >= proto_end)
9912             return too_many_arguments_sv(entersubop, gv_ename(namegv), 0);
9913
9914         switch (*proto) {
9915             case ';':
9916                 optional = 1;
9917                 proto++;
9918                 continue;
9919             case '_':
9920                 /* _ must be at the end */
9921                 if (proto[1] && !strchr(";@%", proto[1]))
9922                     goto oops;
9923                 /* FALLTHROUGH */
9924             case '$':
9925                 proto++;
9926                 arg++;
9927                 scalar(aop);
9928                 break;
9929             case '%':
9930             case '@':
9931                 list(aop);
9932                 arg++;
9933                 break;
9934             case '&':
9935                 proto++;
9936                 arg++;
9937                 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
9938                     bad_type_gv(arg,
9939                             arg == 1 ? "block or sub {}" : "sub {}",
9940                             namegv, 0, o3);
9941                 break;
9942             case '*':
9943                 /* '*' allows any scalar type, including bareword */
9944                 proto++;
9945                 arg++;
9946                 if (o3->op_type == OP_RV2GV)
9947                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
9948                 else if (o3->op_type == OP_CONST)
9949                     o3->op_private &= ~OPpCONST_STRICT;
9950                 else if (o3->op_type == OP_ENTERSUB) {
9951                     /* accidental subroutine, revert to bareword */
9952                     OP *gvop = ((UNOP*)o3)->op_first;
9953                     if (gvop && gvop->op_type == OP_NULL) {
9954                         gvop = ((UNOP*)gvop)->op_first;
9955                         if (gvop) {
9956                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
9957                                 ;
9958                             if (gvop &&
9959                                     (gvop->op_private & OPpENTERSUB_NOPAREN) &&
9960                                     (gvop = ((UNOP*)gvop)->op_first) &&
9961                                     gvop->op_type == OP_GV)
9962                             {
9963                                 GV * const gv = cGVOPx_gv(gvop);
9964                                 OP * const sibling = aop->op_sibling;
9965                                 SV * const n = newSVpvs("");
9966                                 op_free(aop);
9967                                 gv_fullname4(n, gv, "", FALSE);
9968                                 aop = newSVOP(OP_CONST, 0, n);
9969                                 prev->op_sibling = aop;
9970                                 aop->op_sibling = sibling;
9971                             }
9972                         }
9973                     }
9974                 }
9975                 scalar(aop);
9976                 break;
9977             case '+':
9978                 proto++;
9979                 arg++;
9980                 if (o3->op_type == OP_RV2AV ||
9981                     o3->op_type == OP_PADAV ||
9982                     o3->op_type == OP_RV2HV ||
9983                     o3->op_type == OP_PADHV
9984                 ) {
9985                     goto wrapref;
9986                 }
9987                 scalar(aop);
9988                 break;
9989             case '[': case ']':
9990                 goto oops;
9991
9992             case '\\':
9993                 proto++;
9994                 arg++;
9995             again:
9996                 switch (*proto++) {
9997                     case '[':
9998                         if (contextclass++ == 0) {
9999                             e = strchr(proto, ']');
10000                             if (!e || e == proto)
10001                                 goto oops;
10002                         }
10003                         else
10004                             goto oops;
10005                         goto again;
10006
10007                     case ']':
10008                         if (contextclass) {
10009                             const char *p = proto;
10010                             const char *const end = proto;
10011                             contextclass = 0;
10012                             while (*--p != '[')
10013                                 /* \[$] accepts any scalar lvalue */
10014                                 if (*p == '$'
10015                                  && Perl_op_lvalue_flags(aTHX_
10016                                      scalar(o3),
10017                                      OP_READ, /* not entersub */
10018                                      OP_LVALUE_NO_CROAK
10019                                     )) goto wrapref;
10020                             bad_type_gv(arg, Perl_form(aTHX_ "one of %.*s",
10021                                         (int)(end - p), p),
10022                                     namegv, 0, o3);
10023                         } else
10024                             goto oops;
10025                         break;
10026                     case '*':
10027                         if (o3->op_type == OP_RV2GV)
10028                             goto wrapref;
10029                         if (!contextclass)
10030                             bad_type_gv(arg, "symbol", namegv, 0, o3);
10031                         break;
10032                     case '&':
10033                         if (o3->op_type == OP_ENTERSUB)
10034                             goto wrapref;
10035                         if (!contextclass)
10036                             bad_type_gv(arg, "subroutine entry", namegv, 0,
10037                                     o3);
10038                         break;
10039                     case '$':
10040                         if (o3->op_type == OP_RV2SV ||
10041                                 o3->op_type == OP_PADSV ||
10042                                 o3->op_type == OP_HELEM ||
10043                                 o3->op_type == OP_AELEM)
10044                             goto wrapref;
10045                         if (!contextclass) {
10046                             /* \$ accepts any scalar lvalue */
10047                             if (Perl_op_lvalue_flags(aTHX_
10048                                     scalar(o3),
10049                                     OP_READ,  /* not entersub */
10050                                     OP_LVALUE_NO_CROAK
10051                                )) goto wrapref;
10052                             bad_type_gv(arg, "scalar", namegv, 0, o3);
10053                         }
10054                         break;
10055                     case '@':
10056                         if (o3->op_type == OP_RV2AV ||
10057                                 o3->op_type == OP_PADAV)
10058                             goto wrapref;
10059                         if (!contextclass)
10060                             bad_type_gv(arg, "array", namegv, 0, o3);
10061                         break;
10062                     case '%':
10063                         if (o3->op_type == OP_RV2HV ||
10064                                 o3->op_type == OP_PADHV)
10065                             goto wrapref;
10066                         if (!contextclass)
10067                             bad_type_gv(arg, "hash", namegv, 0, o3);
10068                         break;
10069                     wrapref:
10070                         {
10071                             OP* const kid = aop;
10072                             OP* const sib = kid->op_sibling;
10073                             kid->op_sibling = 0;
10074                             aop = newUNOP(OP_REFGEN, 0, kid);
10075                             aop->op_sibling = sib;
10076                             prev->op_sibling = aop;
10077                         }
10078                         if (contextclass && e) {
10079                             proto = e + 1;
10080                             contextclass = 0;
10081                         }
10082                         break;
10083                     default: goto oops;
10084                 }
10085                 if (contextclass)
10086                     goto again;
10087                 break;
10088             case ' ':
10089                 proto++;
10090                 continue;
10091             default:
10092             oops: {
10093                 SV* const tmpsv = sv_newmortal();
10094                 gv_efullname3(tmpsv, namegv, NULL);
10095                 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
10096                         SVfARG(tmpsv), SVfARG(protosv));
10097             }
10098         }
10099
10100         op_lvalue(aop, OP_ENTERSUB);
10101         prev = aop;
10102         aop = aop->op_sibling;
10103     }
10104     if (aop == cvop && *proto == '_') {
10105         /* generate an access to $_ */
10106         aop = newDEFSVOP();
10107         aop->op_sibling = prev->op_sibling;
10108         prev->op_sibling = aop; /* instead of cvop */
10109     }
10110     if (!optional && proto_end > proto &&
10111         (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
10112         return too_few_arguments_sv(entersubop, gv_ename(namegv), 0);
10113     return entersubop;
10114 }
10115
10116 /*
10117 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
10118
10119 Performs the fixup of the arguments part of an C<entersub> op tree either
10120 based on a subroutine prototype or using default list-context processing.
10121 This is the standard treatment used on a subroutine call, not marked
10122 with C<&>, where the callee can be identified at compile time.
10123
10124 I<protosv> supplies the subroutine prototype to be applied to the call,
10125 or indicates that there is no prototype.  It may be a normal scalar,
10126 in which case if it is defined then the string value will be used
10127 as a prototype, and if it is undefined then there is no prototype.
10128 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
10129 that has been cast to C<SV*>), of which the prototype will be used if it
10130 has one.  The prototype (or lack thereof) supplied, in whichever form,
10131 does not need to match the actual callee referenced by the op tree.
10132
10133 If the argument ops disagree with the prototype, for example by having
10134 an unacceptable number of arguments, a valid op tree is returned anyway.
10135 The error is reflected in the parser state, normally resulting in a single
10136 exception at the top level of parsing which covers all the compilation
10137 errors that occurred.  In the error message, the callee is referred to
10138 by the name defined by the I<namegv> parameter.
10139
10140 =cut
10141 */
10142
10143 OP *
10144 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
10145         GV *namegv, SV *protosv)
10146 {
10147     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
10148     if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
10149         return ck_entersub_args_proto(entersubop, namegv, protosv);
10150     else
10151         return ck_entersub_args_list(entersubop);
10152 }
10153
10154 OP *
10155 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
10156 {
10157     int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
10158     OP *aop = cUNOPx(entersubop)->op_first;
10159
10160     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
10161
10162     if (!opnum) {
10163         OP *cvop;
10164         if (!aop->op_sibling)
10165             aop = cUNOPx(aop)->op_first;
10166         aop = aop->op_sibling;
10167         for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
10168         if (aop != cvop)
10169             (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
10170
10171         op_free(entersubop);
10172         switch(GvNAME(namegv)[2]) {
10173         case 'F': return newSVOP(OP_CONST, 0,
10174                                         newSVpv(CopFILE(PL_curcop),0));
10175         case 'L': return newSVOP(
10176                            OP_CONST, 0,
10177                            Perl_newSVpvf(aTHX_
10178                              "%"IVdf, (IV)CopLINE(PL_curcop)
10179                            )
10180                          );
10181         case 'P': return newSVOP(OP_CONST, 0,
10182                                    (PL_curstash
10183                                      ? newSVhek(HvNAME_HEK(PL_curstash))
10184                                      : &PL_sv_undef
10185                                    )
10186                                 );
10187         }
10188         NOT_REACHED;
10189     }
10190     else {
10191         OP *prev, *cvop;
10192         U32 flags;
10193         if (!aop->op_sibling)
10194             aop = cUNOPx(aop)->op_first;
10195
10196         prev = aop;
10197         aop = aop->op_sibling;
10198         prev->op_sibling = NULL;
10199         for (cvop = aop;
10200              cvop->op_sibling;
10201              prev=cvop, cvop = cvop->op_sibling)
10202             ;
10203         prev->op_sibling = NULL;
10204         flags = OPf_SPECIAL * !(cvop->op_private & OPpENTERSUB_NOPAREN);
10205         op_free(cvop);
10206         if (aop == cvop) aop = NULL;
10207         op_free(entersubop);
10208
10209         if (opnum == OP_ENTEREVAL
10210          && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
10211             flags |= OPpEVAL_BYTES <<8;
10212
10213         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
10214         case OA_UNOP:
10215         case OA_BASEOP_OR_UNOP:
10216         case OA_FILESTATOP:
10217             return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
10218         case OA_BASEOP:
10219             if (aop) {
10220                     (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
10221                 op_free(aop);
10222             }
10223             return opnum == OP_RUNCV
10224                 ? newPVOP(OP_RUNCV,0,NULL)
10225                 : newOP(opnum,0);
10226         default:
10227             return convert(opnum,0,aop);
10228         }
10229     }
10230     assert(0);
10231     return entersubop;
10232 }
10233
10234 /*
10235 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
10236
10237 Retrieves the function that will be used to fix up a call to I<cv>.
10238 Specifically, the function is applied to an C<entersub> op tree for a
10239 subroutine call, not marked with C<&>, where the callee can be identified
10240 at compile time as I<cv>.
10241
10242 The C-level function pointer is returned in I<*ckfun_p>, and an SV
10243 argument for it is returned in I<*ckobj_p>.  The function is intended
10244 to be called in this manner:
10245
10246     entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
10247
10248 In this call, I<entersubop> is a pointer to the C<entersub> op,
10249 which may be replaced by the check function, and I<namegv> is a GV
10250 supplying the name that should be used by the check function to refer
10251 to the callee of the C<entersub> op if it needs to emit any diagnostics.
10252 It is permitted to apply the check function in non-standard situations,
10253 such as to a call to a different subroutine or to a method call.
10254
10255 By default, the function is
10256 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
10257 and the SV parameter is I<cv> itself.  This implements standard
10258 prototype processing.  It can be changed, for a particular subroutine,
10259 by L</cv_set_call_checker>.
10260
10261 =cut
10262 */
10263
10264 void
10265 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
10266 {
10267     MAGIC *callmg;
10268     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
10269     callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
10270     if (callmg) {
10271         *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
10272         *ckobj_p = callmg->mg_obj;
10273     } else {
10274         *ckfun_p = Perl_ck_entersub_args_proto_or_list;
10275         *ckobj_p = (SV*)cv;
10276     }
10277 }
10278
10279 /*
10280 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
10281
10282 Sets the function that will be used to fix up a call to I<cv>.
10283 Specifically, the function is applied to an C<entersub> op tree for a
10284 subroutine call, not marked with C<&>, where the callee can be identified
10285 at compile time as I<cv>.
10286
10287 The C-level function pointer is supplied in I<ckfun>, and an SV argument
10288 for it is supplied in I<ckobj>.  The function should be defined like this:
10289
10290     STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
10291
10292 It is intended to be called in this manner:
10293
10294     entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
10295
10296 In this call, I<entersubop> is a pointer to the C<entersub> op,
10297 which may be replaced by the check function, and I<namegv> is a GV
10298 supplying the name that should be used by the check function to refer
10299 to the callee of the C<entersub> op if it needs to emit any diagnostics.
10300 It is permitted to apply the check function in non-standard situations,
10301 such as to a call to a different subroutine or to a method call.
10302
10303 The current setting for a particular CV can be retrieved by
10304 L</cv_get_call_checker>.
10305
10306 =cut
10307 */
10308
10309 void
10310 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
10311 {
10312     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
10313     if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
10314         if (SvMAGICAL((SV*)cv))
10315             mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
10316     } else {
10317         MAGIC *callmg;
10318         sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
10319         callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
10320         assert(callmg);
10321         if (callmg->mg_flags & MGf_REFCOUNTED) {
10322             SvREFCNT_dec(callmg->mg_obj);
10323             callmg->mg_flags &= ~MGf_REFCOUNTED;
10324         }
10325         callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
10326         callmg->mg_obj = ckobj;
10327         if (ckobj != (SV*)cv) {
10328             SvREFCNT_inc_simple_void_NN(ckobj);
10329             callmg->mg_flags |= MGf_REFCOUNTED;
10330         }
10331         callmg->mg_flags |= MGf_COPY;
10332     }
10333 }
10334
10335 OP *
10336 Perl_ck_subr(pTHX_ OP *o)
10337 {
10338     OP *aop, *cvop;
10339     CV *cv;
10340     GV *namegv;
10341
10342     PERL_ARGS_ASSERT_CK_SUBR;
10343
10344     aop = cUNOPx(o)->op_first;
10345     if (!aop->op_sibling)
10346         aop = cUNOPx(aop)->op_first;
10347     aop = aop->op_sibling;
10348     for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
10349     cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
10350     namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
10351
10352     o->op_private &= ~1;
10353     o->op_private |= OPpENTERSUB_HASTARG;
10354     o->op_private |= (PL_hints & HINT_STRICT_REFS);
10355     if (PERLDB_SUB && PL_curstash != PL_debstash)
10356         o->op_private |= OPpENTERSUB_DB;
10357     if (cvop->op_type == OP_RV2CV) {
10358         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
10359         op_null(cvop);
10360     } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
10361         if (aop->op_type == OP_CONST)
10362             aop->op_private &= ~OPpCONST_STRICT;
10363         else if (aop->op_type == OP_LIST) {
10364             OP * const sib = ((UNOP*)aop)->op_first->op_sibling;
10365             if (sib && sib->op_type == OP_CONST)
10366                 sib->op_private &= ~OPpCONST_STRICT;
10367         }
10368     }
10369
10370     if (!cv) {
10371         return ck_entersub_args_list(o);
10372     } else {
10373         Perl_call_checker ckfun;
10374         SV *ckobj;
10375         cv_get_call_checker(cv, &ckfun, &ckobj);
10376         if (!namegv) { /* expletive! */
10377             /* XXX The call checker API is public.  And it guarantees that
10378                    a GV will be provided with the right name.  So we have
10379                    to create a GV.  But it is still not correct, as its
10380                    stringification will include the package.  What we
10381                    really need is a new call checker API that accepts a
10382                    GV or string (or GV or CV). */
10383             HEK * const hek = CvNAME_HEK(cv);
10384             /* After a syntax error in a lexical sub, the cv that
10385                rv2cv_op_cv returns may be a nameless stub. */
10386             if (!hek) return ck_entersub_args_list(o);;
10387             namegv = (GV *)sv_newmortal();
10388             gv_init_pvn(namegv, PL_curstash, HEK_KEY(hek), HEK_LEN(hek),
10389                         SVf_UTF8 * !!HEK_UTF8(hek));
10390         }
10391         return ckfun(aTHX_ o, namegv, ckobj);
10392     }
10393 }
10394
10395 OP *
10396 Perl_ck_svconst(pTHX_ OP *o)
10397 {
10398     SV * const sv = cSVOPo->op_sv;
10399     PERL_ARGS_ASSERT_CK_SVCONST;
10400     PERL_UNUSED_CONTEXT;
10401 #ifdef PERL_OLD_COPY_ON_WRITE
10402     if (SvIsCOW(sv)) sv_force_normal(sv);
10403 #elif defined(PERL_NEW_COPY_ON_WRITE)
10404     /* Since the read-only flag may be used to protect a string buffer, we
10405        cannot do copy-on-write with existing read-only scalars that are not
10406        already copy-on-write scalars.  To allow $_ = "hello" to do COW with
10407        that constant, mark the constant as COWable here, if it is not
10408        already read-only. */
10409     if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
10410         SvIsCOW_on(sv);
10411         CowREFCNT(sv) = 0;
10412 # ifdef PERL_DEBUG_READONLY_COW
10413         sv_buf_to_ro(sv);
10414 # endif
10415     }
10416 #endif
10417     SvREADONLY_on(sv);
10418     return o;
10419 }
10420
10421 OP *
10422 Perl_ck_trunc(pTHX_ OP *o)
10423 {
10424     PERL_ARGS_ASSERT_CK_TRUNC;
10425
10426     if (o->op_flags & OPf_KIDS) {
10427         SVOP *kid = (SVOP*)cUNOPo->op_first;
10428
10429         if (kid->op_type == OP_NULL)
10430             kid = (SVOP*)kid->op_sibling;
10431         if (kid && kid->op_type == OP_CONST &&
10432             (kid->op_private & OPpCONST_BARE) &&
10433             !kid->op_folded)
10434         {
10435             o->op_flags |= OPf_SPECIAL;
10436             kid->op_private &= ~OPpCONST_STRICT;
10437         }
10438     }
10439     return ck_fun(o);
10440 }
10441
10442 OP *
10443 Perl_ck_substr(pTHX_ OP *o)
10444 {
10445     PERL_ARGS_ASSERT_CK_SUBSTR;
10446
10447     o = ck_fun(o);
10448     if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
10449         OP *kid = cLISTOPo->op_first;
10450
10451         if (kid->op_type == OP_NULL)
10452             kid = kid->op_sibling;
10453         if (kid)
10454             kid->op_flags |= OPf_MOD;
10455
10456     }
10457     return o;
10458 }
10459
10460 OP *
10461 Perl_ck_tell(pTHX_ OP *o)
10462 {
10463     PERL_ARGS_ASSERT_CK_TELL;
10464     o = ck_fun(o);
10465     if (o->op_flags & OPf_KIDS) {
10466      OP *kid = cLISTOPo->op_first;
10467      if (kid->op_type == OP_NULL && kid->op_sibling) kid = kid->op_sibling;
10468      if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
10469     }
10470     return o;
10471 }
10472
10473 OP *
10474 Perl_ck_each(pTHX_ OP *o)
10475 {
10476     dVAR;
10477     OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
10478     const unsigned orig_type  = o->op_type;
10479     const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
10480                               : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
10481     const unsigned ref_type   = orig_type == OP_EACH ? OP_REACH
10482                               : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
10483
10484     PERL_ARGS_ASSERT_CK_EACH;
10485
10486     if (kid) {
10487         switch (kid->op_type) {
10488             case OP_PADHV:
10489             case OP_RV2HV:
10490                 break;
10491             case OP_PADAV:
10492             case OP_RV2AV:
10493                 CHANGE_TYPE(o, array_type);
10494                 break;
10495             case OP_CONST:
10496                 if (kid->op_private == OPpCONST_BARE
10497                  || !SvROK(cSVOPx_sv(kid))
10498                  || (  SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
10499                     && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV  )
10500                    )
10501                     /* we let ck_fun handle it */
10502                     break;
10503             default:
10504                 CHANGE_TYPE(o, ref_type);
10505                 scalar(kid);
10506         }
10507     }
10508     /* if treating as a reference, defer additional checks to runtime */
10509     if (o->op_type == ref_type) {
10510         /* diag_listed_as: keys on reference is experimental */
10511         Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__AUTODEREF),
10512                               "%s is experimental", PL_op_desc[ref_type]);
10513         return o;
10514     }
10515     return ck_fun(o);
10516 }
10517
10518 OP *
10519 Perl_ck_length(pTHX_ OP *o)
10520 {
10521     PERL_ARGS_ASSERT_CK_LENGTH;
10522
10523     o = ck_fun(o);
10524
10525     if (ckWARN(WARN_SYNTAX)) {
10526         const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
10527
10528         if (kid) {
10529             SV *name = NULL;
10530             const bool hash = kid->op_type == OP_PADHV
10531                            || kid->op_type == OP_RV2HV;
10532             switch (kid->op_type) {
10533                 case OP_PADHV:
10534                 case OP_PADAV:
10535                 case OP_RV2HV:
10536                 case OP_RV2AV:
10537                     name = S_op_varname(aTHX_ kid);
10538                     break;
10539                 default:
10540                     return o;
10541             }
10542             if (name)
10543                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10544                     "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
10545                     ")\"?)",
10546                     SVfARG(name), hash ? "keys " : "", SVfARG(name)
10547                 );
10548             else if (hash)
10549      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
10550                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10551                     "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
10552             else
10553      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
10554                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10555                     "length() used on @array (did you mean \"scalar(@array)\"?)");
10556         }
10557     }
10558
10559     return o;
10560 }
10561
10562 /* Check for in place reverse and sort assignments like "@a = reverse @a"
10563    and modify the optree to make them work inplace */
10564
10565 STATIC void
10566 S_inplace_aassign(pTHX_ OP *o) {
10567
10568     OP *modop, *modop_pushmark;
10569     OP *oright;
10570     OP *oleft, *oleft_pushmark;
10571
10572     PERL_ARGS_ASSERT_INPLACE_AASSIGN;
10573
10574     assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
10575
10576     assert(cUNOPo->op_first->op_type == OP_NULL);
10577     modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
10578     assert(modop_pushmark->op_type == OP_PUSHMARK);
10579     modop = modop_pushmark->op_sibling;
10580
10581     if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
10582         return;
10583
10584     /* no other operation except sort/reverse */
10585     if (modop->op_sibling)
10586         return;
10587
10588     assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
10589     if (!(oright = cUNOPx(modop)->op_first->op_sibling)) return;
10590
10591     if (modop->op_flags & OPf_STACKED) {
10592         /* skip sort subroutine/block */
10593         assert(oright->op_type == OP_NULL);
10594         oright = oright->op_sibling;
10595     }
10596
10597     assert(cUNOPo->op_first->op_sibling->op_type == OP_NULL);
10598     oleft_pushmark = cUNOPx(cUNOPo->op_first->op_sibling)->op_first;
10599     assert(oleft_pushmark->op_type == OP_PUSHMARK);
10600     oleft = oleft_pushmark->op_sibling;
10601
10602     /* Check the lhs is an array */
10603     if (!oleft ||
10604         (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
10605         || oleft->op_sibling
10606         || (oleft->op_private & OPpLVAL_INTRO)
10607     )
10608         return;
10609
10610     /* Only one thing on the rhs */
10611     if (oright->op_sibling)
10612         return;
10613
10614     /* check the array is the same on both sides */
10615     if (oleft->op_type == OP_RV2AV) {
10616         if (oright->op_type != OP_RV2AV
10617             || !cUNOPx(oright)->op_first
10618             || cUNOPx(oright)->op_first->op_type != OP_GV
10619             || cUNOPx(oleft )->op_first->op_type != OP_GV
10620             || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
10621                cGVOPx_gv(cUNOPx(oright)->op_first)
10622         )
10623             return;
10624     }
10625     else if (oright->op_type != OP_PADAV
10626         || oright->op_targ != oleft->op_targ
10627     )
10628         return;
10629
10630     /* This actually is an inplace assignment */
10631
10632     modop->op_private |= OPpSORT_INPLACE;
10633
10634     /* transfer MODishness etc from LHS arg to RHS arg */
10635     oright->op_flags = oleft->op_flags;
10636
10637     /* remove the aassign op and the lhs */
10638     op_null(o);
10639     op_null(oleft_pushmark);
10640     if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
10641         op_null(cUNOPx(oleft)->op_first);
10642     op_null(oleft);
10643 }
10644
10645
10646
10647 /* mechanism for deferring recursion in rpeep() */
10648
10649 #define MAX_DEFERRED 4
10650
10651 #define DEFER(o) \
10652   STMT_START { \
10653     if (defer_ix == (MAX_DEFERRED-1)) { \
10654         OP **defer = defer_queue[defer_base]; \
10655         CALL_RPEEP(*defer); \
10656         S_prune_chain_head(defer); \
10657         defer_base = (defer_base + 1) % MAX_DEFERRED; \
10658         defer_ix--; \
10659     } \
10660     defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
10661   } STMT_END
10662
10663 #define IS_AND_OP(o)   (o->op_type == OP_AND)
10664 #define IS_OR_OP(o)    (o->op_type == OP_OR)
10665
10666
10667 STATIC void
10668 S_null_listop_in_list_context(pTHX_ OP *o)
10669 {
10670     OP *kid;
10671
10672     PERL_ARGS_ASSERT_NULL_LISTOP_IN_LIST_CONTEXT;
10673
10674     /* This is an OP_LIST in list context. That means we
10675      * can ditch the OP_LIST and the OP_PUSHMARK within. */
10676
10677     kid = cLISTOPo->op_first;
10678     /* Find the end of the chain of OPs executed within the OP_LIST. */
10679     while (kid->op_next != o)
10680         kid = kid->op_next;
10681
10682     kid->op_next = o->op_next; /* patch list out of exec chain */
10683     op_null(cUNOPo->op_first); /* NULL the pushmark */
10684     op_null(o); /* NULL the list */
10685 }
10686
10687 /* A peephole optimizer.  We visit the ops in the order they're to execute.
10688  * See the comments at the top of this file for more details about when
10689  * peep() is called */
10690
10691 void
10692 Perl_rpeep(pTHX_ OP *o)
10693 {
10694     dVAR;
10695     OP* oldop = NULL;
10696     OP* oldoldop = NULL;
10697     OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
10698     int defer_base = 0;
10699     int defer_ix = -1;
10700     OP *fop;
10701     OP *sop;
10702
10703     if (!o || o->op_opt)
10704         return;
10705     ENTER;
10706     SAVEOP();
10707     SAVEVPTR(PL_curcop);
10708     for (;; o = o->op_next) {
10709         if (o && o->op_opt)
10710             o = NULL;
10711         if (!o) {
10712             while (defer_ix >= 0) {
10713                 OP **defer =
10714                         defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
10715                 CALL_RPEEP(*defer);
10716                 S_prune_chain_head(defer);
10717             }
10718             break;
10719         }
10720
10721         /* By default, this op has now been optimised. A couple of cases below
10722            clear this again.  */
10723         o->op_opt = 1;
10724         PL_op = o;
10725
10726
10727         /* The following will have the OP_LIST and OP_PUSHMARK
10728          * patched out later IF the OP_LIST is in list context.
10729          * So in that case, we can set the this OP's op_next
10730          * to skip to after the OP_PUSHMARK:
10731          *   a THIS -> b
10732          *   d list -> e
10733          *   b   pushmark -> c
10734          *   c   whatever -> d
10735          *   e whatever
10736          * will eventually become:
10737          *   a THIS -> c
10738          *   - ex-list -> -
10739          *   -   ex-pushmark -> -
10740          *   c   whatever -> e
10741          *   e whatever
10742          */
10743         {
10744             OP *sibling;
10745             OP *other_pushmark;
10746             if (OP_TYPE_IS(o->op_next, OP_PUSHMARK)
10747                 && (sibling = o->op_sibling)
10748                 && sibling->op_type == OP_LIST
10749                 /* This KIDS check is likely superfluous since OP_LIST
10750                  * would otherwise be an OP_STUB. */
10751                 && sibling->op_flags & OPf_KIDS
10752                 && (sibling->op_flags & OPf_WANT) == OPf_WANT_LIST
10753                 && (other_pushmark = cLISTOPx(sibling)->op_first)
10754                 /* Pointer equality also effectively checks that it's a
10755                  * pushmark. */
10756                 && other_pushmark == o->op_next)
10757             {
10758                 o->op_next = other_pushmark->op_next;
10759                 null_listop_in_list_context(sibling);
10760             }
10761         }
10762
10763         switch (o->op_type) {
10764         case OP_DBSTATE:
10765             PL_curcop = ((COP*)o);              /* for warnings */
10766             break;
10767         case OP_NEXTSTATE:
10768             PL_curcop = ((COP*)o);              /* for warnings */
10769
10770             /* Optimise a "return ..." at the end of a sub to just be "...".
10771              * This saves 2 ops. Before:
10772              * 1  <;> nextstate(main 1 -e:1) v ->2
10773              * 4  <@> return K ->5
10774              * 2    <0> pushmark s ->3
10775              * -    <1> ex-rv2sv sK/1 ->4
10776              * 3      <#> gvsv[*cat] s ->4
10777              *
10778              * After:
10779              * -  <@> return K ->-
10780              * -    <0> pushmark s ->2
10781              * -    <1> ex-rv2sv sK/1 ->-
10782              * 2      <$> gvsv(*cat) s ->3
10783              */
10784             {
10785                 OP *next = o->op_next;
10786                 OP *sibling = o->op_sibling;
10787                 if (   OP_TYPE_IS(next, OP_PUSHMARK)
10788                     && OP_TYPE_IS(sibling, OP_RETURN)
10789                     && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
10790                     && OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
10791                     && cUNOPx(sibling)->op_first == next
10792                     && next->op_sibling && next->op_sibling->op_next
10793                     && next->op_next
10794                 ) {
10795                     /* Look through the PUSHMARK's siblings for one that
10796                      * points to the RETURN */
10797                     OP *top = next->op_sibling;
10798                     while (top && top->op_next) {
10799                         if (top->op_next == sibling) {
10800                             top->op_next = sibling->op_next;
10801                             o->op_next = next->op_next;
10802                             break;
10803                         }
10804                         top = top->op_sibling;
10805                     }
10806                 }
10807             }
10808
10809             /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
10810              *
10811              * This latter form is then suitable for conversion into padrange
10812              * later on. Convert:
10813              *
10814              *   nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
10815              *
10816              * into:
10817              *
10818              *   nextstate1 ->     listop     -> nextstate3
10819              *                 /            \
10820              *         pushmark -> padop1 -> padop2
10821              */
10822             if (o->op_next && (
10823                     o->op_next->op_type == OP_PADSV
10824                  || o->op_next->op_type == OP_PADAV
10825                  || o->op_next->op_type == OP_PADHV
10826                 )
10827                 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
10828                 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
10829                 && o->op_next->op_next->op_next && (
10830                     o->op_next->op_next->op_next->op_type == OP_PADSV
10831                  || o->op_next->op_next->op_next->op_type == OP_PADAV
10832                  || o->op_next->op_next->op_next->op_type == OP_PADHV
10833                 )
10834                 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
10835                 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
10836                 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
10837                 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
10838             ) {
10839                 OP *first;
10840                 OP *last;
10841                 OP *newop;
10842
10843                 first = o->op_next;
10844                 last = o->op_next->op_next->op_next;
10845
10846                 newop = newLISTOP(OP_LIST, 0, first, last);
10847                 newop->op_flags |= OPf_PARENS;
10848                 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
10849
10850                 /* Kill nextstate2 between padop1/padop2 */
10851                 op_free(first->op_next);
10852
10853                 first->op_next = last;                /* padop2 */
10854                 first->op_sibling = last;             /* ... */
10855                 o->op_next = cUNOPx(newop)->op_first; /* pushmark */
10856                 o->op_next->op_next = first;          /* padop1 */
10857                 o->op_next->op_sibling = first;       /* ... */
10858                 newop->op_next = last->op_next;       /* nextstate3 */
10859                 newop->op_sibling = last->op_sibling;
10860                 last->op_next = newop;                /* listop */
10861                 last->op_sibling = NULL;
10862                 o->op_sibling = newop;                /* ... */
10863
10864                 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
10865
10866                 /* Ensure pushmark has this flag if padops do */
10867                 if (first->op_flags & OPf_MOD && last->op_flags & OPf_MOD) {
10868                     o->op_next->op_flags |= OPf_MOD;
10869                 }
10870
10871                 break;
10872             }
10873
10874             /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
10875                to carry two labels. For now, take the easier option, and skip
10876                this optimisation if the first NEXTSTATE has a label.  */
10877             if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
10878                 OP *nextop = o->op_next;
10879                 while (nextop && nextop->op_type == OP_NULL)
10880                     nextop = nextop->op_next;
10881
10882                 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
10883                     COP *firstcop = (COP *)o;
10884                     COP *secondcop = (COP *)nextop;
10885                     /* We want the COP pointed to by o (and anything else) to
10886                        become the next COP down the line.  */
10887                     cop_free(firstcop);
10888
10889                     firstcop->op_next = secondcop->op_next;
10890
10891                     /* Now steal all its pointers, and duplicate the other
10892                        data.  */
10893                     firstcop->cop_line = secondcop->cop_line;
10894 #ifdef USE_ITHREADS
10895                     firstcop->cop_stashoff = secondcop->cop_stashoff;
10896                     firstcop->cop_file = secondcop->cop_file;
10897 #else
10898                     firstcop->cop_stash = secondcop->cop_stash;
10899                     firstcop->cop_filegv = secondcop->cop_filegv;
10900 #endif
10901                     firstcop->cop_hints = secondcop->cop_hints;
10902                     firstcop->cop_seq = secondcop->cop_seq;
10903                     firstcop->cop_warnings = secondcop->cop_warnings;
10904                     firstcop->cop_hints_hash = secondcop->cop_hints_hash;
10905
10906 #ifdef USE_ITHREADS
10907                     secondcop->cop_stashoff = 0;
10908                     secondcop->cop_file = NULL;
10909 #else
10910                     secondcop->cop_stash = NULL;
10911                     secondcop->cop_filegv = NULL;
10912 #endif
10913                     secondcop->cop_warnings = NULL;
10914                     secondcop->cop_hints_hash = NULL;
10915
10916                     /* If we use op_null(), and hence leave an ex-COP, some
10917                        warnings are misreported. For example, the compile-time
10918                        error in 'use strict; no strict refs;'  */
10919                     secondcop->op_type = OP_NULL;
10920                     secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
10921                 }
10922             }
10923             break;
10924
10925         case OP_CONCAT:
10926             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
10927                 if (o->op_next->op_private & OPpTARGET_MY) {
10928                     if (o->op_flags & OPf_STACKED) /* chained concats */
10929                         break; /* ignore_optimization */
10930                     else {
10931                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
10932                         o->op_targ = o->op_next->op_targ;
10933                         o->op_next->op_targ = 0;
10934                         o->op_private |= OPpTARGET_MY;
10935                     }
10936                 }
10937                 op_null(o->op_next);
10938             }
10939             break;
10940         case OP_STUB:
10941             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
10942                 break; /* Scalar stub must produce undef.  List stub is noop */
10943             }
10944             goto nothin;
10945         case OP_NULL:
10946             if (o->op_targ == OP_NEXTSTATE
10947                 || o->op_targ == OP_DBSTATE)
10948             {
10949                 PL_curcop = ((COP*)o);
10950             }
10951             /* XXX: We avoid setting op_seq here to prevent later calls
10952                to rpeep() from mistakenly concluding that optimisation
10953                has already occurred. This doesn't fix the real problem,
10954                though (See 20010220.007). AMS 20010719 */
10955             /* op_seq functionality is now replaced by op_opt */
10956             o->op_opt = 0;
10957             /* FALLTHROUGH */
10958         case OP_SCALAR:
10959         case OP_LINESEQ:
10960         case OP_SCOPE:
10961         nothin:
10962             if (oldop) {
10963                 oldop->op_next = o->op_next;
10964                 o->op_opt = 0;
10965                 continue;
10966             }
10967             break;
10968
10969         case OP_PUSHMARK:
10970
10971             /* Convert a series of PAD ops for my vars plus support into a
10972              * single padrange op. Basically
10973              *
10974              *    pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
10975              *
10976              * becomes, depending on circumstances, one of
10977              *
10978              *    padrange  ----------------------------------> (list) -> rest
10979              *    padrange  --------------------------------------------> rest
10980              *
10981              * where all the pad indexes are sequential and of the same type
10982              * (INTRO or not).
10983              * We convert the pushmark into a padrange op, then skip
10984              * any other pad ops, and possibly some trailing ops.
10985              * Note that we don't null() the skipped ops, to make it
10986              * easier for Deparse to undo this optimisation (and none of
10987              * the skipped ops are holding any resourses). It also makes
10988              * it easier for find_uninit_var(), as it can just ignore
10989              * padrange, and examine the original pad ops.
10990              */
10991         {
10992             OP *p;
10993             OP *followop = NULL; /* the op that will follow the padrange op */
10994             U8 count = 0;
10995             U8 intro = 0;
10996             PADOFFSET base = 0; /* init only to stop compiler whining */
10997             U8 gimme       = 0; /* init only to stop compiler whining */
10998             bool defav = 0;  /* seen (...) = @_ */
10999             bool reuse = 0;  /* reuse an existing padrange op */
11000
11001             /* look for a pushmark -> gv[_] -> rv2av */
11002
11003             {
11004                 GV *gv;
11005                 OP *rv2av, *q;
11006                 p = o->op_next;
11007                 if (   p->op_type == OP_GV
11008                     && (gv = cGVOPx_gv(p))
11009                     && GvNAMELEN_get(gv) == 1
11010                     && *GvNAME_get(gv) == '_'
11011                     && GvSTASH(gv) == PL_defstash
11012                     && (rv2av = p->op_next)
11013                     && rv2av->op_type == OP_RV2AV
11014                     && !(rv2av->op_flags & OPf_REF)
11015                     && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
11016                     && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
11017                     && o->op_sibling == rv2av /* these two for Deparse */
11018                     && cUNOPx(rv2av)->op_first == p
11019                 ) {
11020                     q = rv2av->op_next;
11021                     if (q->op_type == OP_NULL)
11022                         q = q->op_next;
11023                     if (q->op_type == OP_PUSHMARK) {
11024                         defav = 1;
11025                         p = q;
11026                     }
11027                 }
11028             }
11029             if (!defav) {
11030                 /* To allow Deparse to pessimise this, it needs to be able
11031                  * to restore the pushmark's original op_next, which it
11032                  * will assume to be the same as op_sibling. */
11033                 if (o->op_next != o->op_sibling)
11034                     break;
11035                 p = o;
11036             }
11037
11038             /* scan for PAD ops */
11039
11040             for (p = p->op_next; p; p = p->op_next) {
11041                 if (p->op_type == OP_NULL)
11042                     continue;
11043
11044                 if ((     p->op_type != OP_PADSV
11045                        && p->op_type != OP_PADAV
11046                        && p->op_type != OP_PADHV
11047                     )
11048                       /* any private flag other than INTRO? e.g. STATE */
11049                    || (p->op_private & ~OPpLVAL_INTRO)
11050                 )
11051                     break;
11052
11053                 /* let $a[N] potentially be optimised into AELEMFAST_LEX
11054                  * instead */
11055                 if (   p->op_type == OP_PADAV
11056                     && p->op_next
11057                     && p->op_next->op_type == OP_CONST
11058                     && p->op_next->op_next
11059                     && p->op_next->op_next->op_type == OP_AELEM
11060                 )
11061                     break;
11062
11063                 /* for 1st padop, note what type it is and the range
11064                  * start; for the others, check that it's the same type
11065                  * and that the targs are contiguous */
11066                 if (count == 0) {
11067                     intro = (p->op_private & OPpLVAL_INTRO);
11068                     base = p->op_targ;
11069                     gimme = (p->op_flags & OPf_WANT);
11070                 }
11071                 else {
11072                     if ((p->op_private & OPpLVAL_INTRO) != intro)
11073                         break;
11074                     /* Note that you'd normally  expect targs to be
11075                      * contiguous in my($a,$b,$c), but that's not the case
11076                      * when external modules start doing things, e.g.
11077                      i* Function::Parameters */
11078                     if (p->op_targ != base + count)
11079                         break;
11080                     assert(p->op_targ == base + count);
11081                     /* all the padops should be in the same context */
11082                     if (gimme != (p->op_flags & OPf_WANT))
11083                         break;
11084                 }
11085
11086                 /* for AV, HV, only when we're not flattening */
11087                 if (   p->op_type != OP_PADSV
11088                     && gimme != OPf_WANT_VOID
11089                     && !(p->op_flags & OPf_REF)
11090                 )
11091                     break;
11092
11093                 if (count >= OPpPADRANGE_COUNTMASK)
11094                     break;
11095
11096                 /* there's a biggest base we can fit into a
11097                  * SAVEt_CLEARPADRANGE in pp_padrange */
11098                 if (intro && base >
11099                         (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)))
11100                     break;
11101
11102                 /* Success! We've got another valid pad op to optimise away */
11103                 count++;
11104                 followop = p->op_next;
11105             }
11106
11107             if (count < 1)
11108                 break;
11109
11110             /* pp_padrange in specifically compile-time void context
11111              * skips pushing a mark and lexicals; in all other contexts
11112              * (including unknown till runtime) it pushes a mark and the
11113              * lexicals. We must be very careful then, that the ops we
11114              * optimise away would have exactly the same effect as the
11115              * padrange.
11116              * In particular in void context, we can only optimise to
11117              * a padrange if see see the complete sequence
11118              *     pushmark, pad*v, ...., list, nextstate
11119              * which has the net effect of of leaving the stack empty
11120              * (for now we leave the nextstate in the execution chain, for
11121              * its other side-effects).
11122              */
11123             assert(followop);
11124             if (gimme == OPf_WANT_VOID) {
11125                 if (OP_TYPE_IS_OR_WAS(followop, OP_LIST)
11126                         && gimme == (followop->op_flags & OPf_WANT)
11127                         && (   followop->op_next->op_type == OP_NEXTSTATE
11128                             || followop->op_next->op_type == OP_DBSTATE))
11129                 {
11130                     followop = followop->op_next; /* skip OP_LIST */
11131
11132                     /* consolidate two successive my(...);'s */
11133
11134                     if (   oldoldop
11135                         && oldoldop->op_type == OP_PADRANGE
11136                         && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
11137                         && (oldoldop->op_private & OPpLVAL_INTRO) == intro
11138                         && !(oldoldop->op_flags & OPf_SPECIAL)
11139                     ) {
11140                         U8 old_count;
11141                         assert(oldoldop->op_next == oldop);
11142                         assert(   oldop->op_type == OP_NEXTSTATE
11143                                || oldop->op_type == OP_DBSTATE);
11144                         assert(oldop->op_next == o);
11145
11146                         old_count
11147                             = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
11148
11149                        /* Do not assume pad offsets for $c and $d are con-
11150                           tiguous in
11151                             my ($a,$b,$c);
11152                             my ($d,$e,$f);
11153                         */
11154                         if (  oldoldop->op_targ + old_count == base
11155                            && old_count < OPpPADRANGE_COUNTMASK - count) {
11156                             base = oldoldop->op_targ;
11157                             count += old_count;
11158                             reuse = 1;
11159                         }
11160                     }
11161
11162                     /* if there's any immediately following singleton
11163                      * my var's; then swallow them and the associated
11164                      * nextstates; i.e.
11165                      *    my ($a,$b); my $c; my $d;
11166                      * is treated as
11167                      *    my ($a,$b,$c,$d);
11168                      */
11169
11170                     while (    ((p = followop->op_next))
11171                             && (  p->op_type == OP_PADSV
11172                                || p->op_type == OP_PADAV
11173                                || p->op_type == OP_PADHV)
11174                             && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
11175                             && (p->op_private & OPpLVAL_INTRO) == intro
11176                             && !(p->op_private & ~OPpLVAL_INTRO)
11177                             && p->op_next
11178                             && (   p->op_next->op_type == OP_NEXTSTATE
11179                                 || p->op_next->op_type == OP_DBSTATE)
11180                             && count < OPpPADRANGE_COUNTMASK
11181                             && base + count == p->op_targ
11182                     ) {
11183                         count++;
11184                         followop = p->op_next;
11185                     }
11186                 }
11187                 else
11188                     break;
11189             }
11190
11191             if (reuse) {
11192                 assert(oldoldop->op_type == OP_PADRANGE);
11193                 oldoldop->op_next = followop;
11194                 oldoldop->op_private = (intro | count);
11195                 o = oldoldop;
11196                 oldop = NULL;
11197                 oldoldop = NULL;
11198             }
11199             else {
11200                 /* Convert the pushmark into a padrange.
11201                  * To make Deparse easier, we guarantee that a padrange was
11202                  * *always* formerly a pushmark */
11203                 assert(o->op_type == OP_PUSHMARK);
11204                 o->op_next = followop;
11205                 o->op_type = OP_PADRANGE;
11206                 o->op_ppaddr = PL_ppaddr[OP_PADRANGE];
11207                 o->op_targ = base;
11208                 /* bit 7: INTRO; bit 6..0: count */
11209                 o->op_private = (intro | count);
11210                 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
11211                                     | gimme | (defav ? OPf_SPECIAL : 0));
11212             }
11213             break;
11214         }
11215
11216         case OP_PADAV:
11217         case OP_GV:
11218             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
11219                 OP* const pop = (o->op_type == OP_PADAV) ?
11220                             o->op_next : o->op_next->op_next;
11221                 IV i;
11222                 if (pop && pop->op_type == OP_CONST &&
11223                     ((PL_op = pop->op_next)) &&
11224                     pop->op_next->op_type == OP_AELEM &&
11225                     !(pop->op_next->op_private &
11226                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
11227                     (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
11228                 {
11229                     GV *gv;
11230                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
11231                         no_bareword_allowed(pop);
11232                     if (o->op_type == OP_GV)
11233                         op_null(o->op_next);
11234                     op_null(pop->op_next);
11235                     op_null(pop);
11236                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
11237                     o->op_next = pop->op_next->op_next;
11238                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
11239                     o->op_private = (U8)i;
11240                     if (o->op_type == OP_GV) {
11241                         gv = cGVOPo_gv;
11242                         GvAVn(gv);
11243                         o->op_type = OP_AELEMFAST;
11244                     }
11245                     else
11246                         o->op_type = OP_AELEMFAST_LEX;
11247                 }
11248                 break;
11249             }
11250
11251             if (o->op_next->op_type == OP_RV2SV) {
11252                 if (!(o->op_next->op_private & OPpDEREF)) {
11253                     op_null(o->op_next);
11254                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
11255                                                                | OPpOUR_INTRO);
11256                     o->op_next = o->op_next->op_next;
11257                     o->op_type = OP_GVSV;
11258                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
11259                 }
11260             }
11261             else if (o->op_next->op_type == OP_READLINE
11262                     && o->op_next->op_next->op_type == OP_CONCAT
11263                     && (o->op_next->op_next->op_flags & OPf_STACKED))
11264             {
11265                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
11266                 o->op_type   = OP_RCATLINE;
11267                 o->op_flags |= OPf_STACKED;
11268                 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
11269                 op_null(o->op_next->op_next);
11270                 op_null(o->op_next);
11271             }
11272
11273             break;
11274
11275 #define HV_OR_SCALARHV(op)                                   \
11276     (  (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \
11277        ? (op)                                                  \
11278        : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \
11279        && (  cUNOPx(op)->op_first->op_type == OP_PADHV          \
11280           || cUNOPx(op)->op_first->op_type == OP_RV2HV)          \
11281          ? cUNOPx(op)->op_first                                   \
11282          : NULL)
11283
11284         case OP_NOT:
11285             if ((fop = HV_OR_SCALARHV(cUNOP->op_first)))
11286                 fop->op_private |= OPpTRUEBOOL;
11287             break;
11288
11289         case OP_AND:
11290         case OP_OR:
11291         case OP_DOR:
11292             fop = cLOGOP->op_first;
11293             sop = fop->op_sibling;
11294             while (cLOGOP->op_other->op_type == OP_NULL)
11295                 cLOGOP->op_other = cLOGOP->op_other->op_next;
11296             while (o->op_next && (   o->op_type == o->op_next->op_type
11297                                   || o->op_next->op_type == OP_NULL))
11298                 o->op_next = o->op_next->op_next;
11299
11300             /* if we're an OR and our next is a AND in void context, we'll
11301                follow it's op_other on short circuit, same for reverse.
11302                We can't do this with OP_DOR since if it's true, its return
11303                value is the underlying value which must be evaluated
11304                by the next op */
11305             if (o->op_next &&
11306                 (
11307                     (IS_AND_OP(o) && IS_OR_OP(o->op_next))
11308                  || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
11309                 )
11310                 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
11311             ) {
11312                 o->op_next = ((LOGOP*)o->op_next)->op_other;
11313             }
11314             DEFER(cLOGOP->op_other);
11315
11316             o->op_opt = 1;
11317             fop = HV_OR_SCALARHV(fop);
11318             if (sop) sop = HV_OR_SCALARHV(sop);
11319             if (fop || sop
11320             ){
11321                 OP * nop = o;
11322                 OP * lop = o;
11323                 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
11324                     while (nop && nop->op_next) {
11325                         switch (nop->op_next->op_type) {
11326                             case OP_NOT:
11327                             case OP_AND:
11328                             case OP_OR:
11329                             case OP_DOR:
11330                                 lop = nop = nop->op_next;
11331                                 break;
11332                             case OP_NULL:
11333                                 nop = nop->op_next;
11334                                 break;
11335                             default:
11336                                 nop = NULL;
11337                                 break;
11338                         }
11339                     }
11340                 }
11341                 if (fop) {
11342                     if (  (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
11343                       || o->op_type == OP_AND  )
11344                         fop->op_private |= OPpTRUEBOOL;
11345                     else if (!(lop->op_flags & OPf_WANT))
11346                         fop->op_private |= OPpMAYBE_TRUEBOOL;
11347                 }
11348                 if (  (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
11349                    && sop)
11350                     sop->op_private |= OPpTRUEBOOL;
11351             }
11352
11353
11354             break;
11355
11356         case OP_COND_EXPR:
11357             if ((fop = HV_OR_SCALARHV(cLOGOP->op_first)))
11358                 fop->op_private |= OPpTRUEBOOL;
11359 #undef HV_OR_SCALARHV
11360             /* GERONIMO! */ /* FALLTHROUGH */
11361
11362         case OP_MAPWHILE:
11363         case OP_GREPWHILE:
11364         case OP_ANDASSIGN:
11365         case OP_ORASSIGN:
11366         case OP_DORASSIGN:
11367         case OP_RANGE:
11368         case OP_ONCE:
11369             while (cLOGOP->op_other->op_type == OP_NULL)
11370                 cLOGOP->op_other = cLOGOP->op_other->op_next;
11371             DEFER(cLOGOP->op_other);
11372             break;
11373
11374         case OP_ENTERLOOP:
11375         case OP_ENTERITER:
11376             while (cLOOP->op_redoop->op_type == OP_NULL)
11377                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
11378             while (cLOOP->op_nextop->op_type == OP_NULL)
11379                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
11380             while (cLOOP->op_lastop->op_type == OP_NULL)
11381                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
11382             /* a while(1) loop doesn't have an op_next that escapes the
11383              * loop, so we have to explicitly follow the op_lastop to
11384              * process the rest of the code */
11385             DEFER(cLOOP->op_lastop);
11386             break;
11387
11388         case OP_ENTERTRY:
11389             assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
11390             DEFER(cLOGOPo->op_other);
11391             break;
11392
11393         case OP_SUBST:
11394             assert(!(cPMOP->op_pmflags & PMf_ONCE));
11395             while (cPMOP->op_pmstashstartu.op_pmreplstart &&
11396                    cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
11397                 cPMOP->op_pmstashstartu.op_pmreplstart
11398                     = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
11399             DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
11400             break;
11401
11402         case OP_SORT: {
11403             OP *oright;
11404
11405             if (o->op_flags & OPf_SPECIAL) {
11406                 /* first arg is a code block */
11407                 OP * const nullop = cLISTOP->op_first->op_sibling;
11408                 OP * kid          = cUNOPx(nullop)->op_first;
11409
11410                 assert(nullop->op_type == OP_NULL);
11411                 assert(kid->op_type == OP_SCOPE
11412                  || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
11413                 /* since OP_SORT doesn't have a handy op_other-style
11414                  * field that can point directly to the start of the code
11415                  * block, store it in the otherwise-unused op_next field
11416                  * of the top-level OP_NULL. This will be quicker at
11417                  * run-time, and it will also allow us to remove leading
11418                  * OP_NULLs by just messing with op_nexts without
11419                  * altering the basic op_first/op_sibling layout. */
11420                 kid = kLISTOP->op_first;
11421                 assert(
11422                       (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
11423                     || kid->op_type == OP_STUB
11424                     || kid->op_type == OP_ENTER);
11425                 nullop->op_next = kLISTOP->op_next;
11426                 DEFER(nullop->op_next);
11427             }
11428
11429             /* check that RHS of sort is a single plain array */
11430             oright = cUNOPo->op_first;
11431             if (!oright || oright->op_type != OP_PUSHMARK)
11432                 break;
11433
11434             if (o->op_private & OPpSORT_INPLACE)
11435                 break;
11436
11437             /* reverse sort ... can be optimised.  */
11438             if (!cUNOPo->op_sibling) {
11439                 /* Nothing follows us on the list. */
11440                 OP * const reverse = o->op_next;
11441
11442                 if (reverse->op_type == OP_REVERSE &&
11443                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
11444                     OP * const pushmark = cUNOPx(reverse)->op_first;
11445                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
11446                         && (cUNOPx(pushmark)->op_sibling == o)) {
11447                         /* reverse -> pushmark -> sort */
11448                         o->op_private |= OPpSORT_REVERSE;
11449                         op_null(reverse);
11450                         pushmark->op_next = oright->op_next;
11451                         op_null(oright);
11452                     }
11453                 }
11454             }
11455
11456             break;
11457         }
11458
11459         case OP_REVERSE: {
11460             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
11461             OP *gvop = NULL;
11462             LISTOP *enter, *exlist;
11463
11464             if (o->op_private & OPpSORT_INPLACE)
11465                 break;
11466
11467             enter = (LISTOP *) o->op_next;
11468             if (!enter)
11469                 break;
11470             if (enter->op_type == OP_NULL) {
11471                 enter = (LISTOP *) enter->op_next;
11472                 if (!enter)
11473                     break;
11474             }
11475             /* for $a (...) will have OP_GV then OP_RV2GV here.
11476                for (...) just has an OP_GV.  */
11477             if (enter->op_type == OP_GV) {
11478                 gvop = (OP *) enter;
11479                 enter = (LISTOP *) enter->op_next;
11480                 if (!enter)
11481                     break;
11482                 if (enter->op_type == OP_RV2GV) {
11483                   enter = (LISTOP *) enter->op_next;
11484                   if (!enter)
11485                     break;
11486                 }
11487             }
11488
11489             if (enter->op_type != OP_ENTERITER)
11490                 break;
11491
11492             iter = enter->op_next;
11493             if (!iter || iter->op_type != OP_ITER)
11494                 break;
11495
11496             expushmark = enter->op_first;
11497             if (!expushmark || expushmark->op_type != OP_NULL
11498                 || expushmark->op_targ != OP_PUSHMARK)
11499                 break;
11500
11501             exlist = (LISTOP *) expushmark->op_sibling;
11502             if (!exlist || exlist->op_type != OP_NULL
11503                 || exlist->op_targ != OP_LIST)
11504                 break;
11505
11506             if (exlist->op_last != o) {
11507                 /* Mmm. Was expecting to point back to this op.  */
11508                 break;
11509             }
11510             theirmark = exlist->op_first;
11511             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
11512                 break;
11513
11514             if (theirmark->op_sibling != o) {
11515                 /* There's something between the mark and the reverse, eg
11516                    for (1, reverse (...))
11517                    so no go.  */
11518                 break;
11519             }
11520
11521             ourmark = ((LISTOP *)o)->op_first;
11522             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
11523                 break;
11524
11525             ourlast = ((LISTOP *)o)->op_last;
11526             if (!ourlast || ourlast->op_next != o)
11527                 break;
11528
11529             rv2av = ourmark->op_sibling;
11530             if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
11531                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
11532                 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
11533                 /* We're just reversing a single array.  */
11534                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
11535                 enter->op_flags |= OPf_STACKED;
11536             }
11537
11538             /* We don't have control over who points to theirmark, so sacrifice
11539                ours.  */
11540             theirmark->op_next = ourmark->op_next;
11541             theirmark->op_flags = ourmark->op_flags;
11542             ourlast->op_next = gvop ? gvop : (OP *) enter;
11543             op_null(ourmark);
11544             op_null(o);
11545             enter->op_private |= OPpITER_REVERSED;
11546             iter->op_private |= OPpITER_REVERSED;
11547
11548             break;
11549         }
11550
11551         case OP_QR:
11552         case OP_MATCH:
11553             if (!(cPMOP->op_pmflags & PMf_ONCE)) {
11554                 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
11555             }
11556             break;
11557
11558         case OP_RUNCV:
11559             if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)) {
11560                 SV *sv;
11561                 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
11562                 else {
11563                     sv = newRV((SV *)PL_compcv);
11564                     sv_rvweaken(sv);
11565                     SvREADONLY_on(sv);
11566                 }
11567                 o->op_type = OP_CONST;
11568                 o->op_ppaddr = PL_ppaddr[OP_CONST];
11569                 o->op_flags |= OPf_SPECIAL;
11570                 cSVOPo->op_sv = sv;
11571             }
11572             break;
11573
11574         case OP_SASSIGN:
11575             if (OP_GIMME(o,0) == G_VOID) {
11576                 OP *right = cBINOP->op_first;
11577                 if (right) {
11578                     /*   sassign
11579                     *      RIGHT
11580                     *      substr
11581                     *         pushmark
11582                     *         arg1
11583                     *         arg2
11584                     *         ...
11585                     * becomes
11586                     *
11587                     *  ex-sassign
11588                     *     substr
11589                     *        pushmark
11590                     *        RIGHT
11591                     *        arg1
11592                     *        arg2
11593                     *        ...
11594                     */
11595                     OP *left = right->op_sibling;
11596                     if (left->op_type == OP_SUBSTR
11597                          && (left->op_private & 7) < 4) {
11598                         op_null(o);
11599                         cBINOP->op_first = left;
11600                         right->op_sibling =
11601                             cBINOPx(left)->op_first->op_sibling;
11602                         cBINOPx(left)->op_first->op_sibling = right;
11603                         left->op_private |= OPpSUBSTR_REPL_FIRST;
11604                         left->op_flags =
11605                             (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
11606                     }
11607                 }
11608             }
11609             break;
11610
11611         case OP_CUSTOM: {
11612             Perl_cpeep_t cpeep =
11613                 XopENTRYCUSTOM(o, xop_peep);
11614             if (cpeep)
11615                 cpeep(aTHX_ o, oldop);
11616             break;
11617         }
11618
11619         }
11620         /* did we just null the current op? If so, re-process it to handle
11621          * eliding "empty" ops from the chain */
11622         if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
11623             o->op_opt = 0;
11624             o = oldop;
11625         }
11626         else {
11627             oldoldop = oldop;
11628             oldop = o;
11629         }
11630     }
11631     LEAVE;
11632 }
11633
11634 void
11635 Perl_peep(pTHX_ OP *o)
11636 {
11637     CALL_RPEEP(o);
11638 }
11639
11640 /*
11641 =head1 Custom Operators
11642
11643 =for apidoc Ao||custom_op_xop
11644 Return the XOP structure for a given custom op.  This macro should be
11645 considered internal to OP_NAME and the other access macros: use them instead.
11646 This macro does call a function.  Prior
11647 to 5.19.6, this was implemented as a
11648 function.
11649
11650 =cut
11651 */
11652
11653 XOPRETANY
11654 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
11655 {
11656     SV *keysv;
11657     HE *he = NULL;
11658     XOP *xop;
11659
11660     static const XOP xop_null = { 0, 0, 0, 0, 0 };
11661
11662     PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
11663     assert(o->op_type == OP_CUSTOM);
11664
11665     /* This is wrong. It assumes a function pointer can be cast to IV,
11666      * which isn't guaranteed, but this is what the old custom OP code
11667      * did. In principle it should be safer to Copy the bytes of the
11668      * pointer into a PV: since the new interface is hidden behind
11669      * functions, this can be changed later if necessary.  */
11670     /* Change custom_op_xop if this ever happens */
11671     keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
11672
11673     if (PL_custom_ops)
11674         he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
11675
11676     /* assume noone will have just registered a desc */
11677     if (!he && PL_custom_op_names &&
11678         (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
11679     ) {
11680         const char *pv;
11681         STRLEN l;
11682
11683         /* XXX does all this need to be shared mem? */
11684         Newxz(xop, 1, XOP);
11685         pv = SvPV(HeVAL(he), l);
11686         XopENTRY_set(xop, xop_name, savepvn(pv, l));
11687         if (PL_custom_op_descs &&
11688             (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
11689         ) {
11690             pv = SvPV(HeVAL(he), l);
11691             XopENTRY_set(xop, xop_desc, savepvn(pv, l));
11692         }
11693         Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
11694     }
11695     else {
11696         if (!he)
11697             xop = (XOP *)&xop_null;
11698         else
11699             xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
11700     }
11701     {
11702         XOPRETANY any;
11703         if(field == XOPe_xop_ptr) {
11704             any.xop_ptr = xop;
11705         } else {
11706             const U32 flags = XopFLAGS(xop);
11707             if(flags & field) {
11708                 switch(field) {
11709                 case XOPe_xop_name:
11710                     any.xop_name = xop->xop_name;
11711                     break;
11712                 case XOPe_xop_desc:
11713                     any.xop_desc = xop->xop_desc;
11714                     break;
11715                 case XOPe_xop_class:
11716                     any.xop_class = xop->xop_class;
11717                     break;
11718                 case XOPe_xop_peep:
11719                     any.xop_peep = xop->xop_peep;
11720                     break;
11721                 default:
11722                     NOT_REACHED;
11723                     break;
11724                 }
11725             } else {
11726                 switch(field) {
11727                 case XOPe_xop_name:
11728                     any.xop_name = XOPd_xop_name;
11729                     break;
11730                 case XOPe_xop_desc:
11731                     any.xop_desc = XOPd_xop_desc;
11732                     break;
11733                 case XOPe_xop_class:
11734                     any.xop_class = XOPd_xop_class;
11735                     break;
11736                 case XOPe_xop_peep:
11737                     any.xop_peep = XOPd_xop_peep;
11738                     break;
11739                 default:
11740                     NOT_REACHED;
11741                     break;
11742                 }
11743             }
11744         }
11745         /* Some gcc releases emit a warning for this function:
11746          * op.c: In function 'Perl_custom_op_get_field':
11747          * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
11748          * Whether this is true, is currently unknown. */
11749         return any;
11750     }
11751 }
11752
11753 /*
11754 =for apidoc Ao||custom_op_register
11755 Register a custom op.  See L<perlguts/"Custom Operators">.
11756
11757 =cut
11758 */
11759
11760 void
11761 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
11762 {
11763     SV *keysv;
11764
11765     PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
11766
11767     /* see the comment in custom_op_xop */
11768     keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
11769
11770     if (!PL_custom_ops)
11771         PL_custom_ops = newHV();
11772
11773     if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
11774         Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
11775 }
11776
11777 /*
11778
11779 =for apidoc core_prototype
11780
11781 This function assigns the prototype of the named core function to C<sv>, or
11782 to a new mortal SV if C<sv> is NULL.  It returns the modified C<sv>, or
11783 NULL if the core function has no prototype.  C<code> is a code as returned
11784 by C<keyword()>.  It must not be equal to 0.
11785
11786 =cut
11787 */
11788
11789 SV *
11790 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
11791                           int * const opnum)
11792 {
11793     int i = 0, n = 0, seen_question = 0, defgv = 0;
11794     I32 oa;
11795 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
11796     char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
11797     bool nullret = FALSE;
11798
11799     PERL_ARGS_ASSERT_CORE_PROTOTYPE;
11800
11801     assert (code);
11802
11803     if (!sv) sv = sv_newmortal();
11804
11805 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
11806
11807     switch (code < 0 ? -code : code) {
11808     case KEY_and   : case KEY_chop: case KEY_chomp:
11809     case KEY_cmp   : case KEY_defined: case KEY_delete: case KEY_exec  :
11810     case KEY_exists: case KEY_eq     : case KEY_ge    : case KEY_goto  :
11811     case KEY_grep  : case KEY_gt     : case KEY_last  : case KEY_le    :
11812     case KEY_lt    : case KEY_map    : case KEY_ne    : case KEY_next  :
11813     case KEY_or    : case KEY_print  : case KEY_printf: case KEY_qr    :
11814     case KEY_redo  : case KEY_require: case KEY_return: case KEY_say   :
11815     case KEY_select: case KEY_sort   : case KEY_split : case KEY_system:
11816     case KEY_x     : case KEY_xor    :
11817         if (!opnum) return NULL; nullret = TRUE; goto findopnum;
11818     case KEY_glob:    retsetpvs("_;", OP_GLOB);
11819     case KEY_keys:    retsetpvs("+", OP_KEYS);
11820     case KEY_values:  retsetpvs("+", OP_VALUES);
11821     case KEY_each:    retsetpvs("+", OP_EACH);
11822     case KEY_push:    retsetpvs("+@", OP_PUSH);
11823     case KEY_unshift: retsetpvs("+@", OP_UNSHIFT);
11824     case KEY_pop:     retsetpvs(";+", OP_POP);
11825     case KEY_shift:   retsetpvs(";+", OP_SHIFT);
11826     case KEY_pos:     retsetpvs(";\\[$*]", OP_POS);
11827     case KEY_splice:
11828         retsetpvs("+;$$@", OP_SPLICE);
11829     case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
11830         retsetpvs("", 0);
11831     case KEY_evalbytes:
11832         name = "entereval"; break;
11833     case KEY_readpipe:
11834         name = "backtick";
11835     }
11836
11837 #undef retsetpvs
11838
11839   findopnum:
11840     while (i < MAXO) {  /* The slow way. */
11841         if (strEQ(name, PL_op_name[i])
11842             || strEQ(name, PL_op_desc[i]))
11843         {
11844             if (nullret) { assert(opnum); *opnum = i; return NULL; }
11845             goto found;
11846         }
11847         i++;
11848     }
11849     return NULL;
11850   found:
11851     defgv = PL_opargs[i] & OA_DEFGV;
11852     oa = PL_opargs[i] >> OASHIFT;
11853     while (oa) {
11854         if (oa & OA_OPTIONAL && !seen_question && (
11855               !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
11856         )) {
11857             seen_question = 1;
11858             str[n++] = ';';
11859         }
11860         if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
11861             && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
11862             /* But globs are already references (kinda) */
11863             && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
11864         ) {
11865             str[n++] = '\\';
11866         }
11867         if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
11868          && !scalar_mod_type(NULL, i)) {
11869             str[n++] = '[';
11870             str[n++] = '$';
11871             str[n++] = '@';
11872             str[n++] = '%';
11873             if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
11874             str[n++] = '*';
11875             str[n++] = ']';
11876         }
11877         else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
11878         if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
11879             str[n-1] = '_'; defgv = 0;
11880         }
11881         oa = oa >> 4;
11882     }
11883     if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
11884     str[n++] = '\0';
11885     sv_setpvn(sv, str, n - 1);
11886     if (opnum) *opnum = i;
11887     return sv;
11888 }
11889
11890 OP *
11891 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
11892                       const int opnum)
11893 {
11894     OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
11895     OP *o;
11896
11897     PERL_ARGS_ASSERT_CORESUB_OP;
11898
11899     switch(opnum) {
11900     case 0:
11901         return op_append_elem(OP_LINESEQ,
11902                        argop,
11903                        newSLICEOP(0,
11904                                   newSVOP(OP_CONST, 0, newSViv(-code % 3)),
11905                                   newOP(OP_CALLER,0)
11906                        )
11907                );
11908     case OP_SELECT: /* which represents OP_SSELECT as well */
11909         if (code)
11910             return newCONDOP(
11911                          0,
11912                          newBINOP(OP_GT, 0,
11913                                   newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
11914                                   newSVOP(OP_CONST, 0, newSVuv(1))
11915                                  ),
11916                          coresub_op(newSVuv((UV)OP_SSELECT), 0,
11917                                     OP_SSELECT),
11918                          coresub_op(coreargssv, 0, OP_SELECT)
11919                    );
11920         /* FALLTHROUGH */
11921     default:
11922         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
11923         case OA_BASEOP:
11924             return op_append_elem(
11925                         OP_LINESEQ, argop,
11926                         newOP(opnum,
11927                               opnum == OP_WANTARRAY || opnum == OP_RUNCV
11928                                 ? OPpOFFBYONE << 8 : 0)
11929                    );
11930         case OA_BASEOP_OR_UNOP:
11931             if (opnum == OP_ENTEREVAL) {
11932                 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
11933                 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
11934             }
11935             else o = newUNOP(opnum,0,argop);
11936             if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
11937             else {
11938           onearg:
11939               if (is_handle_constructor(o, 1))
11940                 argop->op_private |= OPpCOREARGS_DEREF1;
11941               if (scalar_mod_type(NULL, opnum))
11942                 argop->op_private |= OPpCOREARGS_SCALARMOD;
11943             }
11944             return o;
11945         default:
11946             o = convert(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
11947             if (is_handle_constructor(o, 2))
11948                 argop->op_private |= OPpCOREARGS_DEREF2;
11949             if (opnum == OP_SUBSTR) {
11950                 o->op_private |= OPpMAYBE_LVSUB;
11951                 return o;
11952             }
11953             else goto onearg;
11954         }
11955     }
11956 }
11957
11958 void
11959 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
11960                                SV * const *new_const_svp)
11961 {
11962     const char *hvname;
11963     bool is_const = !!CvCONST(old_cv);
11964     SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
11965
11966     PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
11967
11968     if (is_const && new_const_svp && old_const_sv == *new_const_svp)
11969         return;
11970         /* They are 2 constant subroutines generated from
11971            the same constant. This probably means that
11972            they are really the "same" proxy subroutine
11973            instantiated in 2 places. Most likely this is
11974            when a constant is exported twice.  Don't warn.
11975         */
11976     if (
11977         (ckWARN(WARN_REDEFINE)
11978          && !(
11979                 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
11980              && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
11981              && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
11982                  strEQ(hvname, "autouse"))
11983              )
11984         )
11985      || (is_const
11986          && ckWARN_d(WARN_REDEFINE)
11987          && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
11988         )
11989     )
11990         Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
11991                           is_const
11992                             ? "Constant subroutine %"SVf" redefined"
11993                             : "Subroutine %"SVf" redefined",
11994                           SVfARG(name));
11995 }
11996
11997 /*
11998 =head1 Hook manipulation
11999
12000 These functions provide convenient and thread-safe means of manipulating
12001 hook variables.
12002
12003 =cut
12004 */
12005
12006 /*
12007 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
12008
12009 Puts a C function into the chain of check functions for a specified op
12010 type.  This is the preferred way to manipulate the L</PL_check> array.
12011 I<opcode> specifies which type of op is to be affected.  I<new_checker>
12012 is a pointer to the C function that is to be added to that opcode's
12013 check chain, and I<old_checker_p> points to the storage location where a
12014 pointer to the next function in the chain will be stored.  The value of
12015 I<new_pointer> is written into the L</PL_check> array, while the value
12016 previously stored there is written to I<*old_checker_p>.
12017
12018 The function should be defined like this:
12019
12020     static OP *new_checker(pTHX_ OP *op) { ... }
12021
12022 It is intended to be called in this manner:
12023
12024     new_checker(aTHX_ op)
12025
12026 I<old_checker_p> should be defined like this:
12027
12028     static Perl_check_t old_checker_p;
12029
12030 L</PL_check> is global to an entire process, and a module wishing to
12031 hook op checking may find itself invoked more than once per process,
12032 typically in different threads.  To handle that situation, this function
12033 is idempotent.  The location I<*old_checker_p> must initially (once
12034 per process) contain a null pointer.  A C variable of static duration
12035 (declared at file scope, typically also marked C<static> to give
12036 it internal linkage) will be implicitly initialised appropriately,
12037 if it does not have an explicit initialiser.  This function will only
12038 actually modify the check chain if it finds I<*old_checker_p> to be null.
12039 This function is also thread safe on the small scale.  It uses appropriate
12040 locking to avoid race conditions in accessing L</PL_check>.
12041
12042 When this function is called, the function referenced by I<new_checker>
12043 must be ready to be called, except for I<*old_checker_p> being unfilled.
12044 In a threading situation, I<new_checker> may be called immediately,
12045 even before this function has returned.  I<*old_checker_p> will always
12046 be appropriately set before I<new_checker> is called.  If I<new_checker>
12047 decides not to do anything special with an op that it is given (which
12048 is the usual case for most uses of op check hooking), it must chain the
12049 check function referenced by I<*old_checker_p>.
12050
12051 If you want to influence compilation of calls to a specific subroutine,
12052 then use L</cv_set_call_checker> rather than hooking checking of all
12053 C<entersub> ops.
12054
12055 =cut
12056 */
12057
12058 void
12059 Perl_wrap_op_checker(pTHX_ Optype opcode,
12060     Perl_check_t new_checker, Perl_check_t *old_checker_p)
12061 {
12062     dVAR;
12063
12064     PERL_UNUSED_CONTEXT;
12065     PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
12066     if (*old_checker_p) return;
12067     OP_CHECK_MUTEX_LOCK;
12068     if (!*old_checker_p) {
12069         *old_checker_p = PL_check[opcode];
12070         PL_check[opcode] = new_checker;
12071     }
12072     OP_CHECK_MUTEX_UNLOCK;
12073 }
12074
12075 #include "XSUB.h"
12076
12077 /* Efficient sub that returns a constant scalar value. */
12078 static void
12079 const_sv_xsub(pTHX_ CV* cv)
12080 {
12081     dVAR;
12082     dXSARGS;
12083     SV *const sv = MUTABLE_SV(XSANY.any_ptr);
12084     PERL_UNUSED_ARG(items);
12085     if (!sv) {
12086         XSRETURN(0);
12087     }
12088     EXTEND(sp, 1);
12089     ST(0) = sv;
12090     XSRETURN(1);
12091 }
12092
12093 static void
12094 const_av_xsub(pTHX_ CV* cv)
12095 {
12096     dVAR;
12097     dXSARGS;
12098     AV * const av = MUTABLE_AV(XSANY.any_ptr);
12099     SP -= items;
12100     assert(av);
12101 #ifndef DEBUGGING
12102     if (!av) {
12103         XSRETURN(0);
12104     }
12105 #endif
12106     if (SvRMAGICAL(av))
12107         Perl_croak(aTHX_ "Magical list constants are not supported");
12108     if (GIMME_V != G_ARRAY) {
12109         EXTEND(SP, 1);
12110         ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
12111         XSRETURN(1);
12112     }
12113     EXTEND(SP, AvFILLp(av)+1);
12114     Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
12115     XSRETURN(AvFILLp(av)+1);
12116 }
12117
12118 /*
12119  * Local variables:
12120  * c-indentation-style: bsd
12121  * c-basic-offset: 4
12122  * indent-tabs-mode: nil
12123  * End:
12124  *
12125  * ex: set ts=8 sts=4 sw=4 et:
12126  */